🔀 合并上游分支

This commit is contained in:
youzi-3222
2025-01-14 14:21:40 +08:00
118 changed files with 8132 additions and 4812 deletions
+265 -120
View File
@@ -1,4 +1,5 @@
Imports System.IO.Compression
Imports System.Globalization
Imports System.IO.Compression
Imports System.Runtime.CompilerServices
Imports System.Security.Cryptography
Imports System.Security.Principal
@@ -11,12 +12,13 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.8.0" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.0." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.8.12" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.12." & VersionBranchCode '标准格式的四段式版本号
Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换
#If BETA Then
Public Const VersionCode As Integer = 326 'Release
Public Const VersionCode As Integer = 347 'Release
#Else
Public Const VersionCode As Integer = 327 'Snapshot
Public Const VersionCode As Integer = 346 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -64,7 +66,7 @@ Public Module ModBase
''' </summary>
Public ApplicationOpenTime As Date = Date.Now
''' <summary>
''' 设备唯一标识符。
''' 识别码。
''' </summary>
Public UniqueAddress As String = SecretGetUniqueAddress()
''' <summary>
@@ -80,13 +82,9 @@ Public Module ModBase
''' </summary>
Public IsGBKEncoding As Boolean = Encoding.Default.CodePage = 936
''' <summary>
''' 操作系统版本。Win10 为 10.0。
''' </summary>
Public OsVersion As Version = Environment.OSVersion.Version
''' <summary>
''' 系统盘盘符,以 \ 结尾。例如 “C:\”。
''' </summary>
Public OsDrive As String = Environment.GetLogicalDrives().First.ToUpper.First & ":\"
Public OsDrive As String = Environment.GetLogicalDrives().Where(Function(p) Directory.Exists(p)).First.ToUpper.First & ":\" '#3799
''' <summary>
''' 程序的缓存文件夹路径,以 \ 结尾。
''' </summary>
@@ -178,6 +176,10 @@ Public Module ModBase
''' </summary>
Public Const IconButtonOffline As String = "M533.293176 788.841412a60.235294 60.235294 0 1 1 85.202824 85.202823l-42.616471 42.586353c-129.355294 129.385412-339.124706 129.385412-468.510117 0-129.385412-129.385412-129.385412-339.124706 0-468.510117l42.586353-42.616471a60.235294 60.235294 0 1 1 85.202823 85.202824l-42.61647 42.586352a210.823529 210.823529 0 1 0 298.164706 298.164706l42.586352-42.61647z m255.548236-255.548236l42.61647-42.586352a210.823529 210.823529 0 1 0-298.164706-298.164706l-42.586352 42.61647a60.235294 60.235294 0 1 1-85.202824-85.202823l42.616471-42.586353c129.355294-129.385412 339.124706-129.385412 468.510117 0 129.385412 129.385412 129.385412 339.124706 0 468.510117l-42.586353 42.616471a60.235294 60.235294 0 1 1-85.202823-85.202824zM192.542118 192.542118a60.235294 60.235294 0 0 1 85.202823 0l553.712941 553.712941a60.235294 60.235294 0 0 1-85.202823 85.202823L192.542118 277.744941a60.235294 60.235294 0 0 1 0-85.202823z"
''' <summary>
''' 图标,服务端,1x
''' </summary>
Public Const IconButtonServer As String = "M224 160a64 64 0 0 0-64 64v576a64 64 0 0 0 64 64h576a64 64 0 0 0 64-64V224a64 64 0 0 0-64-64H224z m0 384h576v256H224v-256z m192 96v64h320v-64H416z m-128 0v64h64v-64H288zM224 224h576v256H224V224z m192 96v64h320v-64H416z m-128 0v64h64v-64H288z"
''' <summary>
''' 图标,向右箭头,1x
''' </summary>
Public Const IconButtonRight As String = "M757.792745 435.407215L419.597482 96.904967c-40.010393-40.010393-104.886579-40.010393-144.896972 0-40.010393 40.010393-40.010393 104.988908 0 144.9993L540.344959 507.855701 274.70051 773.807135c-40.010393 40.112721-40.010393 104.988908 0 144.9993 40.010393 40.010393 104.886579 40.010393 144.896972 0l338.092935-338.39992c40.112721-40.010393 40.112721-104.988908 0.102328-144.9993z"
@@ -704,7 +706,7 @@ Public Module ModBase
If Not FileName.Contains(":\") Then FileName = $"{Path}PCL\{FileName}.ini"
WriteFile(FileName, FileContent.ToString)
Catch ex As Exception
Log(ex, $"写入文件失败({FileName} -> {Key}:{Value})")
Log(ex, $"写入文件失败({FileName} → {Key}:{Value})", LogLevel.Hint)
End Try
End Sub
@@ -778,10 +780,10 @@ Public Module ModBase
End Try
End Sub
''' <summary>
''' 读取文件,如果失败则返回空字符串。
''' 读取文件,如果失败则返回空数组。
''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
Public Function ReadFile(FilePath As String, Optional Encoding As Encoding = Nothing) As String
Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte()
Try
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
@@ -791,17 +793,25 @@ Public Module ModBase
ReDim FileBytes(ReadStream.Length - 1)
ReadStream.Read(FileBytes, 0, ReadStream.Length)
End Using
ReadFile = If(Encoding Is Nothing, DecodeBytes(FileBytes), Encoding.GetString(FileBytes))
Return FileBytes
Else
Log("[System] 欲读取的文件不存在,已返回空字符串:" & FilePath)
Return ""
Log("[System] 欲读取的文件不存在,已返回空内容:" & FilePath)
Return {}
End If
Catch ex As Exception
Log(ex, "读取文件出错:" & FilePath)
Return ""
Return {}
End Try
End Function
''' <summary>
''' 读取文件,如果失败则返回空字符串。
''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
Public Function ReadFile(FilePath As String, Optional Encoding As Encoding = Nothing) As String
Dim FileBytes = ReadFileBytes(FilePath)
ReadFile = If(Encoding Is Nothing, DecodeBytes(FileBytes), Encoding.GetString(FileBytes))
End Function
''' <summary>
''' 读取流中的所有文本。
''' </summary>
Public Function ReadFile(Stream As Stream, Optional Encoding As Encoding = Nothing) As String
@@ -826,50 +836,39 @@ Public Module ModBase
''' <param name="FilePath">文件完整或相对路径。</param>
''' <param name="Text">文件内容。</param>
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Function WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) As Boolean
Try
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
'确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件
If File.Exists(FilePath) Then
'如果文件存在,刷新目前文件
Using writer As New StreamWriter(FilePath, Append, If(Encoding, GetEncoding(FilePath)))
writer.Write(Text)
writer.Flush()
writer.Close()
End Using
Else
'如果文件不存在,则新建并写入
File.WriteAllText(FilePath, Text, If(Encoding, New UTF8Encoding(False)))
End If
Return True
Catch ex As Exception
Log(ex, "写入文件时出错:" & FilePath)
Return False
End Try
End Function
Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing)
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
'确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件
If File.Exists(FilePath) Then
'如果文件存在,刷新目前文件
Using writer As New StreamWriter(FilePath, Append, If(Encoding, GetEncoding(ReadFileBytes(FilePath))))
writer.Write(Text)
writer.Flush()
writer.Close()
End Using
Else
'如果文件不存在,则新建并写入
File.WriteAllText(FilePath, Text, If(Encoding, New UTF8Encoding(False)))
End If
End Sub
''' <summary>
''' 写入文件。
''' 如果 CanThrow 设置为 False,返回是否写入成功。
''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
''' <param name="Content">文件内容。</param>
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Function WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) As Boolean
Try
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
'确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件
File.WriteAllBytes(FilePath, Content)
Return True
Catch ex As Exception
Log(ex, "写入文件时出错:" & FilePath)
Return False
End Try
End Function
Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
'确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件
File.WriteAllBytes(FilePath, Content)
End Sub
''' <summary>
''' 将流写入文件。
''' </summary>
@@ -899,21 +898,11 @@ Public Module ModBase
'文件编码
''' <summary>
''' 获取文件编码。
''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
Public Function GetEncoding(FilePath As String) As Encoding
'还原文件路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
'获取编码
GetEncoding = GetEncoding(File.ReadAllBytes(FilePath))
End Function
''' <summary>
''' 获取 Bytes 的编码。
''' 根据字节数组分析其编码。
''' </summary>
Public Function GetEncoding(Bytes As Byte()) As Encoding
Dim Length As Integer = Bytes.Count
If Length <= 2 Then Return New UTF8Encoding(False) '不带 BOM 的 UTF8
If Length < 3 Then Return New UTF8Encoding(False) '不带 BOM 的 UTF8
'根据 BOM 判断编码
If Bytes(0) >= &HEF Then
'有 BOM 类型
@@ -986,7 +975,7 @@ Public Module ModBase
End Using
End Function
''' <summary>
''' 弹出选取文件对话框并且要求选取文件。
''' 弹出选取文件对话框,要求选择一个文件。
''' </summary>
''' <param name="FileFilter">要求的格式。如:“常用图片文件(*.png;*.jpg)|*.png;*.jpg”。</param>
''' <param name="Title">弹窗的标题。</param>
@@ -1000,12 +989,32 @@ Public Module ModBase
fileDialog.Title = Title
fileDialog.ValidateNames = True
fileDialog.ShowDialog()
SelectFile = fileDialog.FileName
Log("[UI] 选择文件返回:" & SelectFile)
Log("[UI] 选择单个文件返回:" & fileDialog.FileName)
Return fileDialog.FileName
End Using
End Function
''' <summary>
''' 弹出选取文件夹对话框并且要求选取文件夹。如果没有选择就返回空字符串。
''' 弹出选取文件对话框,要求选择多个文件。
''' </summary>
''' <param name="FileFilter">要求的格式。如:“常用图片文件(*.png;*.jpg)|*.png;*.jpg”。</param>
''' <param name="Title">弹窗的标题。</param>
Public Function SelectFiles(FileFilter As String, Title As String) As String()
Using fileDialog As New Forms.OpenFileDialog
fileDialog.AddExtension = True
fileDialog.AutoUpgradeEnabled = True
fileDialog.CheckFileExists = True
fileDialog.Filter = FileFilter
fileDialog.Multiselect = True
fileDialog.Title = Title
fileDialog.ValidateNames = True
fileDialog.ShowDialog()
Log("[UI] 选择多个文件返回:" & fileDialog.FileNames.Join(","))
Return fileDialog.FileNames
End Using
End Function
''' <summary>
''' 弹出选取文件夹对话框,要求选取文件夹。
''' 返回以 \ 结尾的完整路径,如果没有选择则返回空字符串。
''' </summary>
Public Function SelectFolder(Optional Title As String = "选择文件夹") As String
Dim folderDialog As New Ookii.Dialogs.Wpf.VistaFolderBrowserDialog With {.ShowNewFolderButton = True, .RootFolder = Environment.SpecialFolder.Desktop, .Description = Title, .UseDescriptionForTitle = True}
@@ -1020,7 +1029,7 @@ Public Module ModBase
''' </summary>
Public Function CheckPermission(Path As String) As Boolean
Try
If Path = "" Then Return False
If String.IsNullOrEmpty(Path) Then Return False
If Not Path.EndsWithF("\") Then Path += "\"
If Path.EndsWithF(":\System Volume Information\") OrElse Path.EndsWithF(":\$RECYCLE.BIN\") Then Return False
If Not Directory.Exists(Path) Then Return False
@@ -1112,8 +1121,6 @@ Re:
Dim Retry As Boolean = False
Re:
Try
''检测该文件是否在下载中,若在下载则放弃检测
'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return ""
'获取 SHA1
Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
Dim sha1 As SHA1 = New SHA1CryptoServiceProvider()
@@ -1224,7 +1231,8 @@ Re:
''' 尝试根据后缀名判断文件种类并解压文件,支持 gz 与 zip,会尝试将 jar 以 zip 方式解压。
''' 会尝试创建,但不会清空目标文件夹。
''' </summary>
Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing)
Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing,
Optional ProgressIncrementHandler As Action(Of Double) = Nothing)
Directory.CreateDirectory(DestDirectory)
If CompressFilePath.EndsWithF(".gz", True) Then
'以 gz 方式解压
@@ -1240,7 +1248,9 @@ Re:
Else
'以 zip 方式解压
Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030")))
Dim TotalCount As Integer = Archive.Entries.Count
For Each Entry As ZipArchiveEntry In Archive.Entries
If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / TotalCount)
Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName)
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then
Continue For '不创建空文件夹
@@ -1259,28 +1269,47 @@ Re:
Public Function DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False) As Integer
If Not Directory.Exists(Path) Then Return 0
Dim DeletedCount As Integer = 0
Dim Temp As String()
Temp = Directory.GetFiles(Path)
For Each str As String In Temp
Dim Files As String()
Try
Files = Directory.GetFiles(Path)
Catch ex As DirectoryNotFoundException '#4549
Log(ex, $"疑似为孤立符号链接,尝试直接删除({Path})", LogLevel.Developer)
Directory.Delete(Path)
Return 0
End Try
For Each FilePath As String In Files
Dim RetriedFile As Boolean = False
RetryFile:
Try
File.Delete(str)
File.Delete(FilePath)
DeletedCount += 1
Catch ex As Exception
If IgnoreIssue Then
If Not RetriedFile Then
RetriedFile = True
Log(ex, $"删除文件失败,将在 0.3s 后重试({FilePath})")
Thread.Sleep(300)
GoTo RetryFile
ElseIf IgnoreIssue Then
Log(ex, "删除单个文件可忽略地失败")
Else
Throw
End If
End Try
Next
Temp = Directory.GetDirectories(Path)
For Each str As String In Temp
For Each str As String In Directory.GetDirectories(Path)
DeleteDirectory(str, IgnoreIssue)
Next
Dim RetriedDir As Boolean = False
RetryDir:
Try
Directory.Delete(Path, True)
Catch ex As Exception
If IgnoreIssue Then
If Not RetriedDir Then
RetriedDir = True
Log(ex, $"删除文件夹失败,将在 0.3s 后重试({Path})")
Thread.Sleep(300)
GoTo RetryDir
ElseIf IgnoreIssue Then
Log(ex, "删除单个文件夹可忽略地失败")
Else
Throw
@@ -1291,13 +1320,16 @@ Re:
''' <summary>
''' 复制文件夹,失败会抛出异常。
''' </summary>
Public Sub CopyDirectory(FromPath As String, ToPath As String)
Public Sub CopyDirectory(FromPath As String, ToPath As String, Optional ProgressIncrementHandler As Action(Of Double) = Nothing)
FromPath = FromPath.Replace("/", "\")
If Not FromPath.EndsWithF("\") Then FromPath &= "\"
ToPath = ToPath.Replace("/", "\")
If Not ToPath.EndsWithF("\") Then ToPath &= "\"
For Each File In EnumerateFiles(FromPath)
Dim AllFiles = EnumerateFiles(FromPath).ToList
Dim FileCount As Integer = AllFiles.Count
For Each File In AllFiles
CopyFile(File.FullName, File.FullName.Replace(FromPath, ToPath))
If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / FileCount)
Next
End Sub
''' <summary>
@@ -1346,8 +1378,8 @@ Re:
'常见错误(记得同时修改下面的)
Dim CommonReason As String = Nothing
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。"
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装,请先卸载较新版本的 .NET Framework,然后再尝试安装。"
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
CommonReason = "PCL 的权限不足。请尝试右键 PCL,选择以管理员身份运行。"
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
@@ -1366,7 +1398,7 @@ Re:
If CommonReason Is Nothing Then
Return Desc & Stack & TypeDesc
Else
Dim Result As String = DescList.First & vbCrLf & CommonReason & vbCrLf & "————————————" & vbCrLf
Dim Result As String = CommonReason & vbCrLf & DescList.First & vbCrLf & "————————————" & vbCrLf
DescList(0) = "详细错误信息:"
Return Result & Join(DescList, vbCrLf & "→ ") & Stack & TypeDesc
End If
@@ -1394,8 +1426,8 @@ Re:
'常见错误(记得同时修改上面的)
Dim CommonReason As String = Nothing
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。"
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装,请先卸载较新版本的 .NET Framework,然后再尝试安装。"
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
CommonReason = "PCL 的权限不足。请尝试右键 PCL,选择以管理员身份运行。"
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
@@ -1409,7 +1441,7 @@ Re:
'构造输出信息
If CommonReason IsNot Nothing Then
Return DescList.First & ":" & CommonReason
Return CommonReason & "详细错误:" & DescList.First
Else
DescList.Reverse() '让最深层错误在最左边
Return Join(DescList, " → ")
@@ -1449,14 +1481,14 @@ Re:
End Function
''' <summary>
''' 获取 Json 对象。
''' 获取 JSON 对象。
''' </summary>
Public Function GetJson(Data As String)
Try
Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
Catch ex As Exception
Dim Length As Integer = If(Data, "").Length
Throw New Exception("格式化 json 对象失败:" & If(Length > 10000, Data.Substring(0, 100) & $"...(全长 {Length} 个字符)..." & Right(Data, 100), Data))
Throw New Exception("格式化 JSON 失败:" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data))
End Try
End Function
@@ -1550,10 +1582,10 @@ Re:
End Function
''' <summary>
''' 获取在子字符串之前的部分。
''' 会裁切尽可能多的内容,但如果未找到子字符串则不裁切。
''' 获取在子字符串第一次出现之前的部分,例如对 2024/11/08 拆切 / 会得到 2024。
''' 如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function Before(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
<Extension> Public Function BeforeFirst(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.IndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(0, Pos)
@@ -1562,10 +1594,34 @@ Re:
End If
End Function
''' <summary>
''' 获取在子字符串之后的部分。
''' 会裁切尽可能多的内容,但如果未找到子字符串则不裁切。
''' 获取在子字符串最后一次出现之前的部分,例如对 2024/11/08 拆切 / 会得到 2024/11。
''' 如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function After(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
<Extension> Public Function BeforeLast(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.LastIndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(0, Pos)
Else
Return Str
End If
End Function
''' <summary>
''' 获取在子字符串第一次出现之后的部分,例如对 2024/11/08 拆切 / 会得到 11/08。
''' 如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function AfterFirst(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.IndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(Pos + Text.Length)
Else
Return Str
End If
End Function
''' <summary>
''' 获取在子字符串最后一次出现之后的部分,例如对 2024/11/08 拆切 / 会得到 08。
''' 如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function AfterLast(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.LastIndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(Pos + Text.Length)
@@ -1574,17 +1630,17 @@ Re:
End If
End Function
''' <summary>
''' 获取处于两个子字符串之间的部分。
''' 会裁切尽可能多的内容:匹配开始使用 LastIndexOf,匹配结束使用 IndexOf,但如果未找到子字符串则不裁切。
''' 获取处于两个子字符串之间的部分,裁切尽可能多的内容。
''' 如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function Between(Str As String, Before As String, After As String, Optional IgnoreCase As Boolean = False) As String
Dim StartPos As Integer = If(String.IsNullOrEmpty(Before), -1, Str.LastIndexOfF(Before, IgnoreCase))
<Extension> Public Function Between(Str As String, After As String, Before As String, Optional IgnoreCase As Boolean = False) As String
Dim StartPos As Integer = If(String.IsNullOrEmpty(After), -1, Str.LastIndexOfF(After, IgnoreCase))
If StartPos >= 0 Then
StartPos += Before.Length
StartPos += After.Length
Else
StartPos = 0
End If
Dim EndPos As Integer = If(String.IsNullOrEmpty(After), -1, Str.IndexOfF(After, StartPos, IgnoreCase))
Dim EndPos As Integer = If(String.IsNullOrEmpty(Before), -1, Str.IndexOfF(Before, StartPos, IgnoreCase))
If EndPos >= 0 Then
Return Str.Substring(StartPos, EndPos - StartPos)
ElseIf StartPos > 0 Then
@@ -1645,10 +1701,15 @@ Re:
End Function
''' <summary>
''' 输入 And 字符不会报错的 Val。
''' 不会报错的 Val。
''' 如果输入有误,返回 0。
''' </summary>
Public Function Val(Str As Object) As Double
Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str))
Try
Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str))
Catch
Return 0
End Try
End Function
'转义
@@ -1656,7 +1717,10 @@ Re:
''' 为字符串进行 XML 转义。
''' </summary>
Public Function EscapeXML(Str As String) As String
Return Str.Replace("&", "&amp;").Replace("<", "&lt;").Replace(">", "&gt;").Replace("'", "&apos;").Replace("""", "&quot;").Replace(vbCrLf, "&#xa;")
If Str.StartsWithF("{") Then Str = "{}" & Str '#4187
Return Str.
Replace("&", "&amp;").Replace("<", "&lt;").Replace(">", "&gt;").Replace("'", "&apos;").
Replace("""", "&quot;").Replace(vbCrLf, "&#xa;")
End Function
'正则
@@ -1802,10 +1866,10 @@ Re:
'进行搜索,获取相似信息
For Each Entry In Entries
Entry.Similarity = SearchSimilarityWeighted(Entry.SearchSource, Query)
Entry.AbsoluteRight = False
For Each Pair In Entry.SearchSource
If Pair.Key.Replace(" ", "").ContainsF(Query.Replace(" ", ""), True) Then Entry.AbsoluteRight = True
Next
Entry.AbsoluteRight =
Query.Split(" ").All( '对于按空格分割的每一段
Function(QueryPart) Entry.SearchSource.Any( '若与任意一个搜索源完全匹配,则标记为完全匹配项
Function(Source) Source.Key.Replace(" ", "").ContainsF(QueryPart, True)))
Next
'按照相似度进行排序
Entries = Sort(Entries,
@@ -1834,6 +1898,68 @@ Re:
#Region "系统"
''' <summary>
''' 线程安全的,可以直接使用 For Each 的 List。
''' 在使用 For Each 循环时,列表的结果可能并非最新,但不会抛出异常。
''' </summary>
Public Class SafeList(Of T)
Inherits SynchronizedCollection(Of T)
Implements IEnumerable, IEnumerable(Of T)
'构造函数
Public Sub New()
MyBase.New()
End Sub
Public Sub New(Data As IEnumerable(Of T))
MyBase.New(New Object, Data)
End Sub
Public Shared Widening Operator CType(Data As List(Of T)) As SafeList(Of T)
Return New SafeList(Of T)(Data)
End Operator
Public Shared Widening Operator CType(Data As SafeList(Of T)) As List(Of T)
Return New List(Of T)(Data)
End Operator
'基于 SyncLock 覆写
Public Overloads Function GetEnumerator() As IEnumerator(Of T) Implements IEnumerable(Of T).GetEnumerator
SyncLock SyncRoot
Return Items.ToList.GetEnumerator()
End SyncLock
End Function
Private Overloads Function GetEnumeratorGeneral() As IEnumerator Implements IEnumerable.GetEnumerator
SyncLock SyncRoot
Return Items.ToList.GetEnumerator()
End SyncLock
End Function
End Class
''' <summary>
''' 可用于临时存放文件的,不含任何特殊字符的文件夹路径,以“\”结尾。
''' </summary>
Public PathPure As String = GetPureASCIIDir()
Private Function GetPureASCIIDir() As String
If (Path & "PCL").IsASCII() Then
Return Path & "PCL\"
ElseIf PathAppdata.IsASCII() Then
Return PathAppdata
ElseIf PathTemp.IsASCII() Then
Return PathTemp
Else
Return OsDrive & "ProgramData\PCL\"
End If
End Function
''' <summary>
''' 指示接取到这个异常的函数进行重试。
''' </summary>
Public Class RestartException
Inherits Exception
End Class
''' <summary>
''' 指示用户手动取消了操作,或用户已知晓操作被取消的原因。
''' </summary>
Public Class CancelledException
Inherits Exception
End Class
''' <summary>
''' 当前程序是否拥有管理员权限。
''' </summary>
@@ -1852,6 +1978,13 @@ Re:
Return NewProcess.ExitCode
End Function
''' <summary>
''' 判断当前系统语言是否为中文。
''' </summary>
Public Function IsSystemLanguageChinese() As Boolean
Return CultureInfo.CurrentCulture.TwoLetterISOLanguageName = "zh" OrElse CultureInfo.CurrentUICulture.TwoLetterISOLanguageName = "zh"
End Function
Private Uuid As Integer = 1
Private UuidLock As Object
''' <summary>
@@ -1943,10 +2076,10 @@ NextElement:
'12~60 月,“1 年 2 个月”
GetTimeSpanString = Math.Floor(TotalMonthes / 12) & " 年" & If((TotalMonthes Mod 12) > 0, " " & (TotalMonthes Mod 12) & " 个月", "")
ElseIf TotalMonthes >= 4 Then
'4~11 月,“5 月”
GetTimeSpanString = TotalMonthes & " 月"
'4~11 月,“5 个月”
GetTimeSpanString = TotalMonthes & " 个月"
ElseIf TotalMonthes >= 1 Then
'1~4 月,“2 月 13 天”
'1~4 月,“2 个月 13 天”
GetTimeSpanString = TotalMonthes & " 月" & If((Span.Days Mod 30) > 0, " " & (Span.Days Mod 30) & " 天", "")
ElseIf Span.TotalDays >= 4 Then
'4~30 天,“23 天”
@@ -2068,7 +2201,7 @@ NextElement:
''' <summary>
''' 在新的工作线程中执行代码。
''' </summary>
Public Function RunInNewThread(Action As Action, Name As String, Optional Priority As ThreadPriority = ThreadPriority.Normal) As Thread
Public Function RunInNewThread(Action As Action, Optional Name As String = Nothing, Optional Priority As ThreadPriority = ThreadPriority.Normal) As Thread
Dim th As New Thread(
Sub()
Try
@@ -2078,7 +2211,7 @@ NextElement:
Catch ex As Exception
Log(ex, Name & ":线程执行失败", LogLevel.Feedback)
End Try
End Sub) With {.Name = Name, .Priority = Priority}
End Sub) With {.Name = If(Name, "Runtime New Invoke " & GetUuid() & "#"), .Priority = Priority}
th.Start()
Return th
End Function
@@ -2417,6 +2550,14 @@ Retry:
Return rect.Contains(bounds.TopLeft) OrElse rect.Contains(bounds.BottomRight)
End Function
''' <summary>
''' 控件是否受到 TextTrimming 属性影响,导致内容被截取。
''' </summary>
<Extension> Public Function IsTextTrimmed(Control As TextBlock) As Boolean
Control.Measure(New Size(Double.MaxValue, Double.MaxValue))
Return Control.DesiredSize.Width > Control.ActualWidth
End Function
#End Region
#Region "Debug"
@@ -2657,7 +2798,11 @@ Retry:
End Sub
Public Function CanFeedback(ShowHint As Boolean) As Boolean
If False.Equals(PageSetupSystem.IsLauncherNewest) Then
If ShowHint Then MyMsgBox("你的 PCL 不是最新版,因此无法提交反馈。" & vbCrLf & "请先在 设置 → 启动器 中更新启动器,确认该问题在最新版中依然存在,然后再提交反馈。", "无法提交反馈")
If ShowHint Then
If MyMsgBox($"你的 PCL 不是最新版,因此无法提交反馈。{vbCrLf}请在更新后,确认该问题在最新版中依然存在,然后再提交反馈。", "无法提交反馈", "更新", "取消") = 1 Then
UpdateCheckByButton()
End If
End If
Return False
Else
Return True
@@ -2669,7 +2814,7 @@ Retry:
Public Sub FeedbackInfo()
On Error Resume Next
Log("[System] 诊断信息:" & vbCrLf &
"操作系统:" & My.Computer.Info.OSFullName & vbCrLf &
"操作系统:" & My.Computer.Info.OSFullName & "(32 位:" & Is32BitSystem & ")" & vbCrLf &
"剩余内存:" & Int(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024) & " M / " & Int(My.Computer.Info.TotalPhysicalMemory / 1024 / 1024) & " M" & vbCrLf &
"DPI:" & DPI & "(" & Math.Round(DPI / 96, 2) * 100 & "%)" & vbCrLf &
"MC 文件夹:" & If(PathMcFolder, "Nothing") & vbCrLf &
@@ -91,17 +91,18 @@
_State = value
Log("[Loader] 加载器 " & Name & " 状态改变:" & GetStringFromEnum(value))
'实现 ILoadingTrigger 接口与 OnStateChanged 回调
RunInUi(Sub()
Select Case value
Case LoadState.Loading
LoadingState = MyLoading.MyLoadingState.Run
Case LoadState.Failed
LoadingState = MyLoading.MyLoadingState.Error
Case Else
LoadingState = MyLoading.MyLoadingState.Stop
End Select
RaiseEvent OnStateChangedUi(Me, value, OldState)
End Sub)
RunInUi(
Sub()
Select Case value
Case LoadState.Loading
LoadingState = MyLoading.MyLoadingState.Run
Case LoadState.Failed
LoadingState = MyLoading.MyLoadingState.Error
Case Else
LoadingState = MyLoading.MyLoadingState.Stop
End Select
RaiseEvent OnStateChangedUi(Me, value, OldState)
End Sub)
If HasOnStateChangedThread Then RunInThread(Sub() RaiseEvent OnStateChangedThread(Me, value, OldState))
End Set
End Property
@@ -287,15 +288,13 @@
End SyncLock
End Try
'检验输入以确定情况
If (Not IsForceRestart) AndAlso '不要求强行重启
((Input IsNot Nothing AndAlso Input.Equals(Me.Input)) OrElse (Input Is Nothing AndAlso Me.Input Is Nothing)) AndAlso '输入相同
(State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已加载成功
If IsForceRestart Then Return True '强制要求重启
If ((Input Is Nothing) <> (Me.Input Is Nothing)) OrElse (Input IsNot Nothing AndAlso Not Input.Equals(Me.Input)) Then Return True '输入不同
If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时
'如果输入相同且未出错则不重试
Return False
Return False '则不重试
Else
'需要开始
Return True
Return True '需要开始
End If
End Function
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
@@ -316,7 +315,7 @@
Sub()
Try
IsForceRestarting = IsForceRestart
If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已启动")
If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已" & If(IsForceRestarting, "强制", "") & "启动")
LoadDelegate(Me)
If IsAborted Then
Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已中断但线程正常运行至结束,输出被弃用(最新线程:" & If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId) & ")", LogLevel.Developer)
@@ -440,12 +439,13 @@
Exit Sub
End If
End SyncLock
RunInThread(Sub()
'中断加载器
For Each Loader In Loaders
Loader.Abort()
Next
End Sub)
RunInThread(
Sub()
'中断加载器
For Each Loader In Loaders
Loader.Abort()
Next
End Sub)
End Sub
''' <summary>
@@ -484,7 +484,7 @@
Private Sub Update()
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Exit Sub
Dim IsFinished As Boolean = True
Dim Ignore As Boolean = False
Dim Blocked As Boolean = False
Dim Input As Object = Me.Input
For Each Loader In Loaders
Select Case Loader.State
@@ -492,28 +492,30 @@
'检查是否需要重启
If Loader.GetType.Name.StartsWithF("LoaderTask") Then '类型名后面带有泛型,必须用 StartsWith
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
If ModeDebug Then Log("[Loader] 由于输入条件变更,重启已完成的加载器 " & Loader.Name)
Log("[Loader] 由于输入条件变更,重启已完成的加载器 " & Loader.Name)
GoTo Restart
End If
'更新下一个加载器的输入
Input = CType(Loader, Object).Output
End If
'如果不让继续启动,且已有加载器正在加载中,就不继续启动
If Loader.Block AndAlso Not IsFinished Then Blocked = True
Case LoadState.Loading
'检查是否需要重启
If Loader.GetType.Name.StartsWithF("LoaderTask") Then
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
If ModeDebug Then Log("[Loader] 由于输入条件变更,重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
Log("[Loader] 由于输入条件变更,重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
GoTo Restart
End If
End If
'已经有正在加载中的了,不需要再启动了
IsFinished = False
Ignore = True
Blocked = True
Case Else
Restart:
'未启动,则启动加载器
IsFinished = False
If Ignore Then Continue For
If Blocked Then Continue For
If Input IsNot Nothing Then
'若输入类型与下一个加载器相同才继续
Dim LoaderType As String = Loader.GetType.Name
@@ -527,8 +529,8 @@ Restart:
Else
Loader.Start(IsForceRestart:=IsForceRestarting)
End If
'如果不让继续启动,那就不启动呗
If Loader.Block Then Ignore = True
'阻止继续
If Loader.Block Then Blocked = True
End Select
Next
If IsFinished Then
@@ -566,38 +568,33 @@ Restart:
End Class
'任务栏进度条
Public LoaderTaskbarLock As New Object
Public LoaderTaskbar As New List(Of LoaderBase)
Public LoaderTaskbar As New SafeList(Of LoaderBase)
Public LoaderTaskbarProgress As Double = 0 '平滑后的进度
Private LoaderTaskbarProgressLast As Shell.TaskbarItemProgressState = Shell.TaskbarItemProgressState.None
Public Sub LoaderTaskbarAdd(Of T)(Loader As LoaderCombo(Of T))
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRemove(Loader)
SyncLock LoaderTaskbarLock
LoaderTaskbar.Add(Loader)
Log($"[Taskbar] {Loader.Name} 已加入任务列表")
End SyncLock
LoaderTaskbar.Add(Loader)
Log($"[Taskbar] {Loader.Name} 已加入任务列表")
End Sub
Public Sub LoaderTaskbarProgressRefresh()
Try
Dim NewState As Shell.TaskbarItemProgressState
Dim NewProgress As Double = LoaderTaskbarProgressGet()
'检查任务是否完成,若完成则移除
SyncLock LoaderTaskbarLock
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成,则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
Next
End SyncLock
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar.ToList()
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成,则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
Next
'更新平滑后的进度
If NewProgress <= 0 OrElse NewProgress >= 1 OrElse LoaderTaskbarProgress > NewProgress Then
LoaderTaskbarProgress = NewProgress
@@ -625,15 +622,8 @@ Restart:
End Sub
Public Function LoaderTaskbarProgressGet() As Double
Try
Dim Total As Double = 0, Count As Integer = 0
SyncLock LoaderTaskbarLock
For Each Task In LoaderTaskbar.ToList
Total += Task.Progress
Count += 1 '避免多线程影响导致计数出错
Next
End SyncLock
If Count = 0 Then Return 1
Return MathClamp(Total / Count, 0, 1)
If Not LoaderTaskbar.Any Then Return 1
Return MathClamp(LoaderTaskbar.Select(Function(e) e.Progress).Average(), 0, 1)
Catch ex As Exception
Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
Return 0.5
+150 -156
View File
@@ -1,5 +1,4 @@
Imports System.Net
Imports PCL.ModNet
Public Module ModNet
Public Const NetDownloadEnd As String = ".PCLDownloading"
@@ -141,7 +140,7 @@ Retry:
''' </summary>
''' <param name="Url">网页的 Url。</param>
''' <param name="Encode">网页的编码,通常为 UTF-8。</param>
Public Function NetGetCodeByRequestMulty(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False)
Public Function NetGetCodeByRequestMultiple(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False)
Dim Threads As New List(Of Thread)
Dim RequestResult = Nothing
Dim RequestEx As Exception = Nothing
@@ -207,10 +206,10 @@ RequestFinished:
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If ex.GetType.Equals(GetType(WebException)) AndAlso CType(ex, WebException).Status = WebExceptionStatus.Timeout Then
Throw New TimeoutException("连接服务器超时,已接收 " & Result.Count & " B(" & Url & ")")
If TypeOf ex Is WebException AndAlso CType(ex, WebException).Status = WebExceptionStatus.Timeout Then
Throw New TimeoutException($"获取结果失败({CType(ex, WebException).Status},{ex.Message},{Url})", ex)
Else
Throw New WebException("获取结果失败," & ex.Message & "(" & Url & ")", ex)
Throw New WebException($"获取结果失败({If(TypeOf ex Is WebException, CType(ex, WebException).Status & ",", "")}{ex.Message},{Url})", ex)
End If
Finally
Request.Abort()
@@ -269,12 +268,7 @@ RequestFinished:
'下载
Using Client As New WebClient
Try
If UseBrowserUserAgent Then
Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode
End If
Client.Headers(HttpRequestHeader.Referer) = "http://" & VersionCode & ".pcl2.server/"
SecretHeadersSign(Url, Client, UseBrowserUserAgent)
Client.DownloadFile(Url, LocalFile)
Catch ex As Exception
File.Delete(LocalFile)
@@ -316,7 +310,7 @@ Retry:
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If ex.InnerException IsNot Nothing AndAlso ex.InnerException.Message.Contains("(40") AndAlso DontRetryOnRefused Then RetryCount = 999
If ex.InnerException IsNot Nothing AndAlso ex.InnerException.Message.Contains("(40") AndAlso DontRetryOnRefused Then Throw
Select Case RetryCount
Case 0
If ModeDebug Then Log(ex, "[Net] 网络请求第一次失败(" & Url & ")")
@@ -335,7 +329,7 @@ Retry:
''' <summary>
''' 同时发送多个网络请求并要求返回内容。
''' </summary>
Public Function NetRequestMulty(Url As String, Method As String, Data As Object, ContentType As String, Optional RequestCount As Integer = 4, Optional Headers As Dictionary(Of String, String) = Nothing)
Public Function NetRequestMultiple(Url As String, Method As String, Data As Object, ContentType As String, Optional RequestCount As Integer = 4, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True)
Dim Threads As New List(Of Thread)
Dim RequestResult = Nothing
Dim RequestEx As Exception = Nothing
@@ -344,7 +338,7 @@ Retry:
Dim th As New Thread(
Sub()
Try
RequestResult = NetRequestOnce(Url, Method, Data, ContentType, 30000, Headers)
RequestResult = NetRequestOnce(Url, Method, Data, ContentType, 30000, Headers, MakeLog)
Catch ex As Exception
FailCount += 1
RequestEx = ex
@@ -419,7 +413,7 @@ RequestFinished:
Throw
Catch ex As WebException
If ex.Status = WebExceptionStatus.Timeout Then
Throw New WebException("连接服务器超时,请检查你的网络环境是否良好(" & Url & ")", ex)
ex = New WebException($"连接服务器超时,请检查你的网络环境是否良好({ex.Message},{Url})", ex)
Else
'获取请求失败的返回
Dim Res As String = ""
@@ -433,15 +427,34 @@ RequestFinished:
End Using
Catch
End Try
Throw New WebException("网络请求失败(" & Url & "," & ex.Message & ")" & If(String.IsNullOrEmpty(Res), "", vbCrLf & Res), ex)
If Res = "" Then
ex = New WebException($"网络请求失败({ex.Status},{ex.Message},{Url})", ex)
Else
ex = New ResponsedWebException($"服务器返回错误({ex.Status},{ex.Message},{Url}){vbCrLf}{Res}", Res, ex)
End If
End If
If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer)
Throw ex
Catch ex As Exception
Throw New WebException("网络请求失败(" & Url & ")", ex)
ex = New WebException("网络请求失败(" & Url & ")", ex)
If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer)
Throw ex
Finally
If DataStream IsNot Nothing Then DataStream.Dispose()
If Resp IsNot Nothing Then Resp.Dispose()
End Try
End Function
Public Class ResponsedWebException
Inherits WebException
''' <summary>
''' 远程服务器给予的回复。
''' </summary>
Public Overloads Property Response As String
Public Sub New(Message As String, Response As String, InnerException As Exception)
MyBase.New(Message, InnerException)
Me.Response = Response
End Sub
End Class
''' <summary>
''' 最大线程数。
@@ -688,8 +701,7 @@ RequestFinished:
''' <summary>
''' 所属的文件列表任务。
''' </summary>
Public Tasks As New List(Of LoaderDownload)
Public Tasks As New SafeList(Of LoaderDownload)
''' <summary>
''' 所有下载源。
''' </summary>
@@ -881,7 +893,6 @@ RequestFinished:
Public ReadOnly LockState As New Object
Public ReadOnly LockChain As New Object
Public ReadOnly LockSource As New Object
Public ReadOnly LockTasks As New Object
Public ReadOnly Uuid As Integer = GetUuid()
Public Overrides Function Equals(obj As Object) As Boolean
@@ -919,7 +930,7 @@ RequestFinished:
'条件检测
If NetTaskThreadCount >= NetTaskThreadLimit OrElse IsSourceFailed() OrElse
(IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Error) Then Return Nothing
(IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Error) Then Return Nothing
If State >= NetState.Merge OrElse State = NetState.WaitForCheck Then Return Nothing
SyncLock LockState
If State < NetState.Connect Then State = NetState.Connect
@@ -928,7 +939,6 @@ RequestFinished:
Dim StartPosition As Long, StartSource As NetSource = Nothing
Dim Th As Thread, ThreadInfo As NetThread
SyncLock LockChain
'获取线程起点与下载源
'不分割
If IsNoSplit Then GoTo Capture
@@ -964,7 +974,8 @@ Capture:
Next
'是否禁用多线程,以及规定碎片大小
Dim TargetUrl As String = GetSource().Url
If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("gitcode.net") OrElse TargetUrl.Contains("github.com") OrElse TargetUrl.Contains("modrinth.com") Then Return Nothing
If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("mcimirror") OrElse TargetUrl.Contains("github.com") OrElse
TargetUrl.Contains("optifine.net") OrElse TargetUrl.Contains("modrinth") Then Return Nothing
'寻找最大碎片
'FUTURE: 下载引擎重做,计算下载源平均链接时间和线程下载速度,按最高时间节省来开启多线程
Dim FilePieceMax As NetThread = Threads
@@ -980,10 +991,8 @@ StartThread:
If (StartPosition > FileSize AndAlso FileSize >= 0 AndAlso Not IsUnknownSize) OrElse StartPosition < 0 OrElse IsNothing(StartSource) Then Return Nothing
'构建线程
Dim ThreadUuid As Integer = GetUuid()
SyncLock LockTasks
If Not Tasks.Any() Then Return Nothing '由于中断,已没有可用任务
Th = New Thread(AddressOf Thread) With {.Name = $"NetTask {Tasks(0).Uuid}/{Uuid} Download {ThreadUuid}#", .Priority = ThreadPriority.BelowNormal}
End SyncLock
If Not Tasks.Any() Then Return Nothing '由于中断,已没有可用任务
Th = New Thread(AddressOf Thread) With {.Name = $"NetTask {Tasks(0).Uuid}/{Uuid} Download {ThreadUuid}#", .Priority = ThreadPriority.BelowNormal}
ThreadInfo = New NetThread With {.Uuid = ThreadUuid, .DownloadStart = StartPosition, .Thread = Th, .Source = StartSource, .Task = Me, .State = NetState.WaitForDownload}
'链表处理
If ThreadInfo.IsFirstThread OrElse Threads Is Nothing Then
@@ -1040,6 +1049,15 @@ StartThread:
If ModeDebug AndAlso HttpResponse.ResponseUri.OriginalString <> Info.Source.Url Then
Log($"[Download] {LocalName} {Info.Uuid}#:重定向至 {HttpResponse.ResponseUri.OriginalString}")
End If
''从响应头获取文件名
'If Info.IsFirstThread Then
' Dim FileName As String = GetFileNameFromResponse(HttpResponse)
' If ModeDebug Then Log($"[Download] {LocalName} {Info.Uuid}#:远程文件名:{If(FileName, "未提供")}")
' If FileName IsNot Nothing AndAlso LocalName = "待定" Then
' LocalName = FileName
' Log($"[Download] {LocalName} {Info.Uuid}#:从响应头获取到文件名")
' End If
'End If
'文件大小校验
ContentLength = HttpResponse.ContentLength
If ContentLength = -1 Then
@@ -1124,7 +1142,7 @@ NotSupportRange:
If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount
End SyncLock
Dim DeltaTime = GetTimeTick() - Info.LastReceiveTime
If DeltaTime > 1000000 Then DeltaTime = 0 '时间刻反转导致出现极大值
If DeltaTime > 1000000 Then DeltaTime = 1 '时间刻反转导致出现极大值
If RealDataCount > 0 Then
'有数据
If Info.DownloadDone = 0 Then
@@ -1140,11 +1158,9 @@ NotSupportRange:
End If
SyncLock LockCount
Info.Source.FailCount = 0
SyncLock LockTasks
For Each Task In Tasks
Task.FailCount = 0
Next
End SyncLock
For Each Task In Tasks
Task.FailCount = 0
Next
End SyncLock
NetManager.DownloadDone += RealDataCount
SyncLock LockDone
@@ -1167,7 +1183,7 @@ NotSupportRange:
ResultStream.Write(HttpData, 0, RealDataCount)
End If
'检查速度是否过慢
If DeltaTime > 1000 AndAlso DeltaTime > RealDataCount Then '数据包间隔大于 1s,且速度小于 1K/s
If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount Then '数据包间隔大于 1.5s,且速度小于 1.5K/s
Throw New TimeoutException("由于速度过慢断开链接,下载 " & RealDataCount & " B,消耗 " & DeltaTime & " ms。")
End If
Info.LastReceiveTime = GetTimeTick()
@@ -1198,11 +1214,9 @@ SourceBreak:
'状态变更
SyncLock LockCount
Info.Source.FailCount += 1
SyncLock LockTasks
For Each Task In Tasks
Task.FailCount += 1
Next
End SyncLock
For Each Task In Tasks
Task.FailCount += 1
Next
End SyncLock
Dim IsTimeoutString As String = GetExceptionSummary(ex).ToLower.Replace(" ", "")
Dim IsTimeout As Boolean = IsTimeoutString.Contains("由于连接方在一段时间后没有正确答复或连接的主机没有反应") OrElse
@@ -1281,6 +1295,17 @@ Wrong:
If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso State < NetState.Merge Then Merge()
End Try
End Sub
''' <summary>
''' 从 HTTP 响应头中获取文件名。
''' 如果没有,返回 Nothing。
''' </summary>
Private Function GetFileNameFromResponse(response As HttpWebResponse) As String
Dim header As String = response.Headers("Content-Disposition")
If String.IsNullOrEmpty(header) Then Return Nothing
'attachment; filename="filename.ext"
If Not header.Contains("filename=") Then Return Nothing
Return header.AfterLast("filename=").Trim(""""c, " "c).BeforeFirst(";")
End Function
'下载文件的最终收束事件
''' <summary>
@@ -1307,7 +1332,7 @@ Retry:
'合并文件
If IsNoSplit Then
'仅有一个线程,从缓存中输出
If ModeDebug Then Log($"[Download] {LocalName}:下载结束,从缓存输出文件")
If ModeDebug Then Log($"[Download] {LocalName}:下载结束,从缓存输出文件,长度:" & SmailFileCache.Count)
MergeFile = New FileStream(LocalPath, FileMode.Create)
AddWriter = New BinaryWriter(MergeFile)
AddWriter.Write(SmailFileCache.ToArray)
@@ -1338,13 +1363,13 @@ Retry:
If Check.ActualSize = -1 Then
Check.ActualSize = FileSize
ElseIf Check.ActualSize <> FileSize Then
Throw New Exception("文件大小不一致:任务要求为 " & Check.ActualSize & " B,网络获取结果为 " & FileSize & "B")
Throw New Exception($"文件大小不一致:任务要求为 {Check.ActualSize} B,网络获取结果为 {FileSize}B")
End If
End If
'检查文件
Dim CheckResult As String = Check?.Check(LocalPath)
If CheckResult IsNot Nothing Then
Log($"[Download] {LocalName} 合并文件失败,下载线程细节:")
Log($"[Download] {LocalName} 文件校验失败,下载线程细节:")
For Each Th As NetThread In Threads
Log($"[Download] {Th.Uuid}#,状态 {GetStringFromEnum(Th.State)},范围 {Th.DownloadStart}~{Th.DownloadStart + Th.DownloadDone},完成 {Th.DownloadDone},剩余 {Th.DownloadUndone}")
Next
@@ -1397,10 +1422,8 @@ Retry:
''' </summary>
Public Sub Abort(CausedByTask As LoaderDownload)
'从特定任务中移除,如果它还属于其他任务,则继续下载
SyncLock LockTasks
Tasks.Remove(CausedByTask)
If Tasks.Any Then Exit Sub
End SyncLock
Tasks.Remove(CausedByTask)
If Tasks.Any Then Exit Sub
'确认中断
SyncLock LockState
If State >= NetState.Finish Then Exit Sub
@@ -1430,11 +1453,9 @@ Retry:
NetManager.FileRemain -= 1
If PrintLog Then Log("[Download] " & LocalName & ":已完成,剩余文件 " & NetManager.FileRemain)
End SyncLock
SyncLock LockTasks
For Each Task In Tasks
Task.OnFileFinish(Me)
Next
End SyncLock
For Each Task In Tasks
Task.OnFileFinish(Me)
Next
End Sub
End Class
@@ -1449,8 +1470,7 @@ Retry:
''' <summary>
''' 需要下载的文件。
''' </summary>
Public Files As List(Of NetFile)
Private ReadOnly FilesLock As New Object
Public Files As SafeList(Of NetFile)
''' <summary>
''' 剩余未完成的文件数。(用于减轻 FilesLock 的占用)
''' </summary>
@@ -1463,9 +1483,7 @@ Retry:
Public Overrides Property Progress As Double
Get
If State >= LoadState.Finished Then Return 1
SyncLock FilesLock
If Not Files.Any() Then Return 0 '必须返回 0,否则在获取列表的时候会错觉已经下载完了
End SyncLock
If Not Files.Any() Then Return 0 '必须返回 0,否则在获取列表的时候会错觉已经下载完了
Return _Progress
End Get
Set(value As Double)
@@ -1487,16 +1505,14 @@ Retry:
Log("[Download] 由于同加载器中失败次数过多引发强制失败:连续失败了 " & value & " 次", LogLevel.Debug)
On Error Resume Next
Dim ExList As New List(Of Exception)
SyncLock FilesLock
For Each File In Files
For Each Source In File.Sources
If Source.Ex IsNot Nothing Then
ExList.Add(Source.Ex)
If ExList.Count > 10 Then GoTo FinishExCatch
End If
Next
For Each File In Files
For Each Source In File.Sources
If Source.Ex IsNot Nothing Then
ExList.Add(Source.Ex)
If ExList.Count > 10 Then GoTo FinishExCatch
End If
Next
End SyncLock
Next
FinishExCatch:
OnFail(ExList)
End If
@@ -1513,17 +1529,15 @@ FinishExCatch:
'计算进度
Dim NewProgress As Double = 0
Dim TotalProgress As Double = 0
SyncLock FilesLock
For Each File In Files
If File.IsCopy Then
NewProgress += File.Progress * 0.2
TotalProgress += 0.2
Else
NewProgress += File.Progress
TotalProgress += 1
End If
Next
End SyncLock
For Each File In Files
If File.IsCopy Then
NewProgress += File.Progress * 0.2
TotalProgress += 0.2
Else
NewProgress += File.Progress
TotalProgress += 1
End If
Next
If TotalProgress > 0 Then NewProgress /= TotalProgress
'刷新进度
If NewProgress < 1 AndAlso NewProgress > 0 Then NewProgress = 2 * (NewProgress ^ 3) - 3 * (NewProgress ^ 2) + 2 * NewProgress '2x^3-3x^2+2x,模拟开头和结尾更慢的情况
@@ -1532,27 +1546,25 @@ FinishExCatch:
Public Sub New(Name As String, FileTasks As List(Of NetFile))
Me.Name = Name
Files = FileTasks
Files = New SafeList(Of NetFile)(FileTasks)
End Sub
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
SyncLock FilesLock
If Input IsNot Nothing Then Files = Input
'去重
Dim ResultArray As New List(Of NetFile)
For i = 0 To Files.Count - 1
For ii = i + 1 To Files.Count - 1
If Files(i).LocalPath = Files(ii).LocalPath Then GoTo NextElement
Next
ResultArray.Add(Files(i))
If Input IsNot Nothing Then Files = New SafeList(Of NetFile)(Input)
'去重
Dim ResultArray As New SafeList(Of NetFile)
For i = 0 To Files.Count - 1
For ii = i + 1 To Files.Count - 1
If Files(i).LocalPath = Files(ii).LocalPath Then GoTo NextElement
Next
ResultArray.Add(Files(i))
NextElement:
Next i
Files = ResultArray
'设置剩余文件数
SyncLock FileRemainLock
For Each File In Files
If File.State <> NetState.Finish Then FileRemain += 1
Next
End SyncLock
Next
Files = ResultArray
'设置剩余文件数
SyncLock FileRemainLock
For Each File In Files
If File.State <> NetState.Finish Then FileRemain += 1
Next
End SyncLock
State = LoadState.Loading
'开始执行
@@ -1595,25 +1607,23 @@ NextElement:
Next
End If
'最多 5 个线程,最少每个线程分配 10 个文件
SyncLock FilesLock
Dim FilesPerThread As Integer = Math.Max(5, Files.Count / 10 + 1)
Dim FilesInThread As New List(Of NetFile)
For Each File In Files
FilesInThread.Add(File)
If FilesInThread.Count = FilesPerThread Then
Dim FilesToRun As New List(Of NetFile)
FilesToRun.AddRange(FilesInThread)
RunInNewThread(Sub() StartCopy(FilesToRun, FoldersFinal), "NetTask FileCopy " & Uuid)
FilesInThread.Clear()
End If
Next
If FilesInThread.Any Then
Dim FilesPerThread As Integer = Math.Max(5, Files.Count / 10 + 1)
Dim FilesInThread As New List(Of NetFile)
For Each File In Files
FilesInThread.Add(File)
If FilesInThread.Count = FilesPerThread Then
Dim FilesToRun As New List(Of NetFile)
FilesToRun.AddRange(FilesInThread)
RunInNewThread(Sub() StartCopy(FilesToRun, FoldersFinal), "NetTask FileCopy " & Uuid)
FilesInThread.Clear()
End If
End SyncLock
Next
If FilesInThread.Any Then
Dim FilesToRun As New List(Of NetFile)
FilesToRun.AddRange(FilesInThread)
RunInNewThread(Sub() StartCopy(FilesToRun, FoldersFinal), "NetTask FileCopy " & Uuid)
FilesInThread.Clear()
End If
Catch ex As Exception
OnFail(New List(Of Exception) From {ex})
End Try
@@ -1652,6 +1662,9 @@ NextElement:
'复制已存在的文件
For Each FileToken In ExistFiles
Dim File As NetFile = FileToken.Key
SyncLock LockState
If File.State > NetState.WaitForCopy Then Exit Sub
End SyncLock
Dim LocalPath As String = FileToken.Value
Dim RetryCount As Integer = 0
Retry:
@@ -1705,24 +1718,20 @@ Retry:
Dim UsefulExs = ExList.Where(Function(e) Not e.Message.Contains("(404)")).ToList
[Error] = If(UsefulExs.Any, UsefulExs(0), ExList(0))
'获取实际失败的文件
SyncLock FilesLock
For Each File In Files
If File.State = NetState.Error Then
[Error] = New Exception("文件下载失败:" & File.LocalPath & vbCrLf & Join(
File.Sources.Select(Function(s) If(s.Ex Is Nothing, s.Url, s.Ex.Message & "(" & s.Url & ")")), vbCrLf), [Error])
Exit For
End If
Next
End SyncLock
For Each File In Files
If File.State = NetState.Error Then
[Error] = New Exception("文件下载失败:" & File.LocalPath & vbCrLf & Join(
File.Sources.Select(Function(s) If(s.Ex Is Nothing, s.Url, s.Ex.Message & "(" & s.Url & ")")), vbCrLf), [Error])
Exit For
End If
Next
'在设置 Error 对象后再更改为失败,避免 WaitForExit 无法捕获错误
State = LoadState.Failed
End SyncLock
'中断所有文件
SyncLock FilesLock
For Each TaskFile In Files
If TaskFile.State < NetState.Merge Then TaskFile.State = NetState.Error
Next
End SyncLock
For Each TaskFile In Files
If TaskFile.State < NetState.Merge Then TaskFile.State = NetState.Error
Next
'在退出同步锁后再进行日志输出
Dim ErrOutput As New List(Of String)
For Each Ex As Exception In ExList
@@ -1737,11 +1746,9 @@ Retry:
End SyncLock
Log("[Download] " & Name & " 已取消!")
'中断所有文件
SyncLock FilesLock
For Each TaskFile In Files
TaskFile.Abort(Me)
Next
End SyncLock
For Each TaskFile In Files
TaskFile.Abort(Me)
Next
End Sub
End Class
@@ -1763,8 +1770,7 @@ Retry:
''' <summary>
''' 当前的所有下载任务。
''' </summary>
Public Tasks As New List(Of LoaderDownload)
Private ReadOnly LockTasks As New Object
Public Tasks As New SafeList(Of LoaderDownload)
''' <summary>
''' 已下载完成的大小。
@@ -1837,11 +1843,9 @@ Retry:
End If
#End Region
#Region "刷新下载任务属性"
SyncLock LockTasks
For Each Task In Tasks
Task.RefreshStat()
Next
End SyncLock
For Each Task In Tasks
Task.RefreshStat()
Next
#End Region
Catch ex As Exception
Log(ex, "刷新下载公开属性失败")
@@ -1880,7 +1884,7 @@ Retry:
For Each File As NetFile In WaitingFiles
If NetTaskThreadCount >= NetTaskThreadLimit Then Continue While '最大线程数检查
Dim NewThread = File.TryBeginThread()
If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi.") Then Thread.Sleep(40) '减少 BMCLAPI 请求频率,避免 Too Many Requests
If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(70) '减少 BMCLAPI 请求频率,避免 Too Many Requests
Next
'为进行中的文件追加线程
If Speed >= NetTaskSpeedLimitLow Then Continue While '下载速度足够,无需新增
@@ -1900,7 +1904,7 @@ Retry:
'新增线程
If PreparingCount > DownloadingCount Then Continue For '准备中的线程已多于下载中的线程,不再新增
Dim NewThread = File.TryBeginThread()
If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi.") Then Thread.Sleep(40) '减少 BMCLAPI 请求频率,避免 Too Many Requests
If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(70) '减少 BMCLAPI 请求频率,避免 Too Many Requests
Next
End While
Catch ex As Exception
@@ -1961,9 +1965,7 @@ Retry:
If Files(File.LocalPath).State >= NetState.Finish Then
'该文件已经下载过一次,且下载完成
'将已下载的文件替换成当前文件,重新下载
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
Files(File.LocalPath) = File
SyncLock LockRemain
FileRemain += 1
@@ -1974,15 +1976,11 @@ Retry:
'该文件正在下载中
'将当前文件替换成下载中的文件,即两个任务指向同一个文件
File = Files(File.LocalPath)
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
End If
Else
'没有该文件
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
Files.Add(File.LocalPath, File)
SyncLock LockRemain
FileRemain += 1
@@ -1993,9 +1991,7 @@ Retry:
Task.Files(i) = File '回设
Next
End SyncLock
SyncLock LockTasks
Tasks.Add(Task)
End SyncLock
Tasks.Add(Task)
End Sub
End Class
@@ -2004,14 +2000,12 @@ Retry:
''' 是否有正在进行中、需要在下载管理页面显示的下载任务?
''' </summary>
Public Function HasDownloadingTask(Optional IgnoreCustomDownload As Boolean = False) As Boolean
SyncLock LoaderTaskbarLock
For Each Task In LoaderTaskbar
If (Task.Show AndAlso Task.State = LoadState.Loading) AndAlso
(Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载")) Then
Return True
End If
Next
End SyncLock
For Each Task In LoaderTaskbar.ToList()
If (Task.Show AndAlso Task.State = LoadState.Loading) AndAlso
(Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载")) Then
Return True
End If
Next
Return False
End Function
@@ -233,6 +233,8 @@ Public Class ValidateFolderName
'检查特殊字符串
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %!", True).Validate(Str)
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名(#4505)
If RegexCheck(Str, ".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式!"
'检查文件夹重名
Dim Arr As New List(Of String)
If PathIgnore IsNot Nothing Then
@@ -289,6 +291,8 @@ Public Class ValidateFileName
'检查特殊字符串
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件名不可为 %!", True).Validate(Str)
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名(#4505)
If RegexCheck(Str, ".{2,}~\d") Then Return "文件名不能包含这一特殊格式!"
'检查文件重名
If ParentFolder IsNot Nothing Then
Dim DirInfo As New DirectoryInfo(ParentFolder)
@@ -355,6 +359,8 @@ Fin:
'检查特殊字符串
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %!").Validate(SubStr)
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名(#4505)
If RegexCheck(Str, ".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式!"
Next
Return ""
End Function
@@ -7,7 +7,7 @@ Public Class MyBitmap
''' <summary>
''' 位图缓存。
''' </summary>
Public Shared BitmapCache As New Dictionary(Of String, MyBitmap)
Public Shared BitmapCache As New Concurrent.ConcurrentDictionary(Of String, MyBitmap)
''' <summary>
''' 存储的图片
@@ -17,15 +17,19 @@ Public Class MyBitmap
'自动类型转换
'支持的类:Image,ImageSource,Bitmap,ImageBrush,BitmapSource
Public Shared Widening Operator CType(Image As System.Drawing.Image) As MyBitmap
If Image Is Nothing Then Return Nothing
Return New MyBitmap(Image)
End Operator
Public Shared Widening Operator CType(Image As MyBitmap) As System.Drawing.Image
If Image Is Nothing Then Return Nothing
Return Image.Pic
End Operator
Public Shared Widening Operator CType(Image As ImageSource) As MyBitmap
If Image Is Nothing Then Return Nothing
Return New MyBitmap(Image)
End Operator
Public Shared Widening Operator CType(Image As MyBitmap) As ImageSource
If Image Is Nothing Then Return Nothing
Dim Bitmap = Image.Pic
Dim rect = New System.Drawing.Rectangle(0, 0, Bitmap.Width, Bitmap.Height)
Dim bitmapData = Bitmap.LockBits(rect, ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb)
@@ -37,15 +41,19 @@ Public Class MyBitmap
End Try
End Operator
Public Shared Widening Operator CType(Image As System.Drawing.Bitmap) As MyBitmap
If Image Is Nothing Then Return Nothing
Return New MyBitmap(Image)
End Operator
Public Shared Widening Operator CType(Image As MyBitmap) As System.Drawing.Bitmap
If Image Is Nothing Then Return Nothing
Return Image.Pic
End Operator
Public Shared Widening Operator CType(Image As ImageBrush) As MyBitmap
If Image Is Nothing Then Return Nothing
Return New MyBitmap(Image)
End Operator
Public Shared Widening Operator CType(Image As MyBitmap) As ImageBrush
If Image Is Nothing Then Return Nothing
Return New ImageBrush(New MyBitmap(Image.Pic))
End Operator
@@ -61,23 +69,32 @@ Public Class MyBitmap
Pic = BitmapCache(FilePathOrResourceName).Pic
Else
Pic = New MyBitmap(CType((New ImageSourceConverter).ConvertFromString(FilePathOrResourceName), ImageSource))
BitmapCache.Add(FilePathOrResourceName, Pic)
BitmapCache.TryAdd(FilePathOrResourceName, Pic)
End If
Else
'使用这种自己接管 FileStream 的方法加载才能解除文件占用
Using InputStream As New FileStream(FilePathOrResourceName, FileMode.Open)
Pic = New System.Drawing.Bitmap(InputStream)
InputStream.Dispose()
'判断是否为 WebP 文件头
Dim Header(1) As Byte
InputStream.Read(Header, 0, 2)
InputStream.Seek(0, SeekOrigin.Begin)
If Header(0) = 82 AndAlso Header(1) = 73 Then
'读取 WebP
Dim FileBytes(InputStream.Length - 1) As Byte
InputStream.Read(FileBytes, 0, FileBytes.Length)
Pic = WebPDecoder.DecodeFromBytes(FileBytes) '将代码隔离在另外一个类中,这样只要不走进这个分支就不会加载 Imazen.WebP.dll
Else
Pic = New System.Drawing.Bitmap(InputStream)
End If
End Using
End If
Catch ex As Exception
Pic = My.Application.TryFindResource(FilePathOrResourceName)
If Pic Is Nothing Then
Pic = New System.Drawing.Bitmap(1, 1)
Log(ex, $"加载位图失败({FilePathOrResourceName})")
Throw
Throw New Exception($"加载 MyBitmap 失败({FilePathOrResourceName})", ex)
Else
Log(ex, $"指定类型有误的位图加载({FilePathOrResourceName})", LogLevel.Developer)
Log(ex, $"指定类型有误的 MyBitmap 加载({FilePathOrResourceName})", LogLevel.Developer)
Exit Try
End If
End Try
@@ -104,6 +121,13 @@ Public Class MyBitmap
Pic = New System.Drawing.Bitmap(MS)
End Using
End Sub
Private Class WebPDecoder '将代码隔离在另外一个类中,这样只要不调用这个方法就不会加载 Imazen.WebP.dll
Public Shared Function DecodeFromBytes(Bytes As Byte()) As System.Drawing.Bitmap
If Is32BitSystem Then Throw New Exception("不支持在 32 位系统下加载 WebP 图片。")
Dim Decoder As New Imazen.WebP.SimpleDecoder()
Return Decoder.DecodeFromBytes(Bytes, Bytes.Length)
End Function
End Class
''' <summary>
''' 获取裁切的图片,这个方法不会导致原对象改变且会返回一个新的对象。
@@ -247,7 +247,13 @@
Website = Data("links")("websiteUrl").ToString.TrimEnd("/")
LastUpdate = Data("dateReleased") '#1194
DownloadCount = Data("downloadCount")
If Data("logo").Count > 0 Then LogoUrl = Data("logo")("thumbnailUrl")
If Data("logo").Count > 0 Then
If Data("logo")("thumbnailUrl") Is Nothing OrElse Data("logo")("thumbnailUrl") = "" Then
LogoUrl = Data("logo")("url")
Else
LogoUrl = Data("logo")("thumbnailUrl")
End If
End If
'FileIndexes / GameVersions / ModLoaders
ModLoaders = New List(Of CompModLoaderType)
Dim Files As New List(Of KeyValuePair(Of Integer, List(Of String))) 'FileId, GameVersions
@@ -265,7 +271,7 @@
Next
CurseForgeFileIds = Files.Select(Function(f) f.Key).Distinct.ToList
GameVersions = Files.SelectMany(Function(f) f.Value).Where(Function(v) v.StartsWithF("1.")).
Select(Function(v) CInt(Val(v.Split(".")(1).Before("-")))).Where(Function(v) v > 0).
Select(Function(v) CInt(Val(v.Split(".")(1).BeforeFirst("-")))).Where(Function(v) v > 0).
Distinct.OrderByDescending(Function(v) v).ToList
ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
'Type
@@ -278,7 +284,8 @@
End If
'Tags
Tags = New List(Of String)
For Each Category In Data("categories").Select(Of Integer)(Function(t) t("id")).Distinct.OrderByDescending(Function(c) c)
For Each Category In If(Data("categories"), New JArray). '镜像源 API 可能丢失此字段:https://github.com/Hex-Dragon/PCL2/issues/4267#issuecomment-2254590831
Select(Of Integer)(Function(t) t("id")).Distinct.OrderByDescending(Function(c) c)
Select Case Category
'Mod
Case 406 : Tags.Add("世界元素")
@@ -342,7 +349,7 @@
'搜索结果的键为 versions,获取特定工程的键为 game_versions
GameVersions = If(CType(If(Data("game_versions"), Data("versions")), JArray), New JArray).
Select(Function(v) v.ToString).Where(Function(v) v.StartsWithF("1.")).
Select(Of Integer)(Function(v) Val(v.Split(".")(1).Before("-"))).Where(Function(v) v > 0).
Select(Of Integer)(Function(v) Val(v.Split(".")(1).BeforeFirst("-"))).Where(Function(v) v > 0).
Distinct.OrderByDescending(Function(v) v).ToList
'Type
Select Case Data("project_type").ToString
@@ -385,9 +392,9 @@
Case "technology" : Tags.Add("科技")
Case "magic" : Tags.Add("魔法")
Case "adventure" : Tags.Add("冒险")
Case "kitchen-sink" : Tags.Add("烹饪")
Case "kitchen-sink" : Tags.Add("大杂烩")
Case "lightweight" : Tags.Add("轻量")
'FUTURE: Res
'FUTURE: Res
End Select
Next
If Not Tags.Any() Then Tags.Add("杂项")
@@ -416,7 +423,7 @@
Json("DownloadCount") = DownloadCount
If ModLoaders IsNot Nothing AndAlso ModLoaders.Any Then Json("ModLoaders") = New JArray(ModLoaders.Select(Function(m) CInt(m)))
Json("Tags") = New JArray(Tags)
If LogoUrl IsNot Nothing Then Json("LogoUrl") = LogoUrl
If Not String.IsNullOrEmpty(LogoUrl) Then Json("LogoUrl") = LogoUrl
If GameVersions.Any Then Json("GameVersions") = New JArray(GameVersions)
Json("CacheTime") = Date.Now '用于检查缓存时间
Return Json
@@ -451,14 +458,14 @@
If StartVersion = EndVersion Then
SpaVersions.Add("1." & StartVersion)
ElseIf McVersionHighest > -1 AndAlso StartVersion >= McVersionHighest Then
If EndVersion <= 10 Then
If EndVersion < 10 Then
SpaVersions.Clear()
SpaVersions.Add("全版本")
Exit For
Else
SpaVersions.Add("1." & EndVersion & "+")
End If
ElseIf EndVersion <= 10 Then
ElseIf EndVersion < 10 Then
SpaVersions.Add("1." & StartVersion & "-")
Exit For
ElseIf StartVersion - EndVersion = 1 Then
@@ -471,25 +478,31 @@
End If
'获取 Mod 加载器描述
Dim ModLoaderDescriptionFull As String, ModLoaderDescriptionPart As String
Select Case ModLoaders.Count
Dim ModLoadersForDesc As New List(Of CompModLoaderType)(ModLoaders)
If Setup.Get("ToolDownloadIgnoreQuilt") Then ModLoadersForDesc.Remove(CompModLoaderType.Quilt)
Select Case ModLoadersForDesc.Count
Case 0
ModLoaderDescriptionFull = "未知"
ModLoaderDescriptionPart = ""
If ModLoaders.Count = 1 Then
ModLoaderDescriptionFull = "仅 " & ModLoaders.Single.ToString
ModLoaderDescriptionPart = ModLoaders.Single.ToString
Else
ModLoaderDescriptionFull = "未知"
ModLoaderDescriptionPart = ""
End If
Case 1
ModLoaderDescriptionFull = "仅 " & ModLoaders.Single.ToString
ModLoaderDescriptionPart = ModLoaders.Single.ToString
Case 2, 3
If Setup.Get("ToolDownloadIgnoreQuilt") AndAlso
ModLoaders.Contains(CompModLoaderType.Forge) AndAlso ModLoaders.Contains(CompModLoaderType.Fabric) Then
ModLoaderDescriptionFull = "仅 " & ModLoadersForDesc.Single.ToString
ModLoaderDescriptionPart = ModLoadersForDesc.Single.ToString
Case Else
If ModLoaders.Contains(CompModLoaderType.Forge) AndAlso
(GameVersions.Max < 14 OrElse ModLoaders.Contains(CompModLoaderType.Fabric)) AndAlso
(GameVersions.Max < 20 OrElse ModLoaders.Contains(CompModLoaderType.NeoForge)) AndAlso
(GameVersions.Max < 14 OrElse ModLoaders.Contains(CompModLoaderType.Quilt) OrElse Setup.Get("ToolDownloadIgnoreQuilt")) Then
ModLoaderDescriptionFull = "任意"
ModLoaderDescriptionPart = ""
Else
ModLoaderDescriptionFull = ModLoaders.Join(" / ")
ModLoaderDescriptionPart = ModLoaders.Join(" / ")
ModLoaderDescriptionFull = ModLoadersForDesc.Join(" / ")
ModLoaderDescriptionPart = ModLoadersForDesc.Join(" / ")
End If
Case Else
ModLoaderDescriptionFull = "任意"
ModLoaderDescriptionPart = ""
End Select
'实例化 UI
Dim NewItem As New MyCompItem With {.Tag = Me, .Logo = GetControlLogo()}
@@ -535,7 +548,7 @@
Return NewItem
End Function
Public Function GetControlLogo() As String
If LogoUrl Is Nothing Then
If String.IsNullOrEmpty(LogoUrl) Then
Return PathImage & "Icons/NoIcon.png"
Else
Return LogoUrl
@@ -576,9 +589,9 @@
'有中文翻译
'尝试将文本分为三段:Title (EnglishName) - Suffix
'检查时注意 Carpet:它没有中文译名,但有 Suffix
Title = TranslatedName.Before(" (").Before(" - ")
Title = TranslatedName.BeforeFirst(" (").BeforeFirst(" - ")
Dim Suffix As String = ""
If TranslatedName.After(")").Contains(" - ") Then Suffix = TranslatedName.After(")").After(" - ")
If TranslatedName.AfterLast(")").Contains(" - ") Then Suffix = TranslatedName.AfterLast(")").AfterLast(" - ")
Dim EnglishName As String = TranslatedName
If Suffix <> "" Then EnglishName = EnglishName.Replace(" - " & Suffix, "")
EnglishName = EnglishName.Replace(Title, "").Trim("("c, ")"c, " "c)
@@ -629,19 +642,19 @@ NoSubtitle:
If Id = Project.Id Then Return True '相同实例
'提取字符串中的字母和数字
Dim GetRaw =
Function(Data As String) As String
Dim Result As New StringBuilder()
For Each r As Char In Data.Where(Function(c) Char.IsLetterOrDigit(c))
Result.Append(r)
Next
Return Result.ToString.ToLower
End Function
Function(Data As String) As String
Dim Result As New StringBuilder()
For Each r As Char In Data.Where(Function(c) Char.IsLetterOrDigit(c))
Result.Append(r)
Next
Return Result.ToString.ToLower
End Function
'来自不同的网站
If FromCurseForge = Project.FromCurseForge Then Return False
'Mod 加载器一致
If ModLoaders.Count <> Project.ModLoaders.Count OrElse ModLoaders.Except(Project.ModLoaders).Count > 0 Then Return False
If ModLoaders.Count <> Project.ModLoaders.Count OrElse ModLoaders.Except(Project.ModLoaders).Any() Then Return False
'MC 版本一致
If GameVersions.Count <> Project.GameVersions.Count OrElse GameVersions.Except(Project.GameVersions).Count > 0 Then Return False
If GameVersions.Count <> Project.GameVersions.Count OrElse GameVersions.Except(Project.GameVersions).Any() Then Return False
'MCMOD 翻译名 / 原名 / 描述文本 / Slug 的英文部分相同
If TranslatedName = Project.TranslatedName OrElse
RawName = Project.RawName OrElse Description = Project.Description OrElse
@@ -751,7 +764,7 @@ NoSubtitle:
Case CompType.ResourcePack
'FUTURE: Res
End Select
Address += "&categoryId=" & If(Tag = "", "0", Tag.Before("/"))
Address += "&categoryId=" & If(Tag = "", "0", Tag.BeforeFirst("/"))
If ModLoader <> CompModLoaderType.Any Then Address += "&modLoaderType=" & CType(ModLoader, Integer)
If Not String.IsNullOrEmpty(GameVersion) Then Address += "&gameVersion=" & GameVersion
If Not String.IsNullOrEmpty(SearchText) Then Address += "&searchFilter=" & Net.WebUtility.UrlEncode(SearchText)
@@ -772,7 +785,7 @@ NoSubtitle:
'facets=[["categories:'game-mechanics'"],["categories:'forge'"],["versions:1.19.3"],["project_type:mod"]]
Dim Facets As New List(Of String)
Facets.Add($"[""project_type:{GetStringFromEnum(Type).ToLower}""]")
If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.After("/")}'""]")
If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.AfterLast("/")}'""]")
If ModLoader <> CompModLoaderType.Any Then Facets.Add($"[""categories:'{GetStringFromEnum(ModLoader).ToLower}'""]")
If Not String.IsNullOrEmpty(GameVersion) Then Facets.Add($"[""versions:'{GameVersion}'""]")
Address += "&facets=[" & String.Join(",", Facets) & "]"
@@ -880,7 +893,7 @@ NoSubtitle:
If Not SearchResults(i).AbsoluteRight AndAlso i >= Math.Min(2, SearchResults.Count - 1) Then Exit For '把 3 个结果拼合以提高准确度
If SearchResults(i).Item.CurseForgeSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.CurseForgeSlug.Replace("-", " ").Replace("/", " ") & " "
If SearchResults(i).Item.ModrinthSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.ModrinthSlug.Replace("-", " ").Replace("/", " ") & " "
SearchResult += SearchResults(i).Item.ChineseName.After(" (").TrimEnd(") ").Before(" - ").
SearchResult += SearchResults(i).Item.ChineseName.AfterLast(" (").TrimEnd(") ").BeforeFirst(" - ").
Replace(":", "").Replace("(", "").Replace(")", "").ToLower.Replace("/", " ") & " "
Next
Log("[Comp] 中文搜索原始关键词:" & SearchResult, LogLevel.Developer)
@@ -943,30 +956,30 @@ Retry:
Dim CurseForgeFailed As Boolean = False
If CurseForgeUrl IsNot Nothing Then
CurseForgeThread = RunInNewThread(
Sub()
Try
'获取工程列表
Log("[Comp] 开始从 CurseForge 获取工程列表:" & CurseForgeUrl)
Dim RequestResult As JObject = NetGetCodeByRequestRetry(CurseForgeUrl, IsJson:=True, Encode:=Encoding.UTF8)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("data")
ProjectList.Add(New CompProject(JsonEntry))
Next
'更新结果
SyncLock ResultsLock
RawResults.AddRange(ProjectList)
End SyncLock
Storage.CurseForgeOffset += ProjectList.Count
Storage.CurseForgeTotal = RequestResult("pagination")("totalCount").ToObject(Of Integer)
Log($"[Comp] 从 CurseForge 获取到了 {ProjectList.Count} 个工程(已获取 {Storage.CurseForgeOffset} 个,共 {Storage.CurseForgeTotal} 个)")
Catch ex As Exception
Log(ex, "从 CurseForge 获取工程列表失败")
Storage.CurseForgeTotal = Storage.CurseForgeOffset
[Error] = ex
CurseForgeFailed = True
End Try
End Sub, "CurseForge Project Request")
Sub()
Try
'获取工程列表
Log("[Comp] 开始从 CurseForge 获取工程列表:" & CurseForgeUrl)
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl, IsJson:=True)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("data")
ProjectList.Add(New CompProject(JsonEntry))
Next
'更新结果
SyncLock ResultsLock
RawResults.AddRange(ProjectList)
End SyncLock
Storage.CurseForgeOffset += ProjectList.Count
Storage.CurseForgeTotal = RequestResult("pagination")("totalCount").ToObject(Of Integer)
Log($"[Comp] 从 CurseForge 获取到了 {ProjectList.Count} 个工程(已获取 {Storage.CurseForgeOffset} 个,共 {Storage.CurseForgeTotal} 个)")
Catch ex As Exception
Log(ex, "从 CurseForge 获取工程列表失败")
Storage.CurseForgeTotal = -1 'Storage.CurseForgeOffset
[Error] = ex
CurseForgeFailed = True
End Try
End Sub, "CurseForge Project Request")
End If
'启动 Modrinth 线程
@@ -974,32 +987,32 @@ Retry:
Dim ModrinthFailed As Boolean = False
If ModrinthUrl IsNot Nothing Then
ModrinthThread = RunInNewThread(
Sub()
Try
Log("[Comp] 开始从 Modrinth 获取工程列表:" & ModrinthUrl)
Dim RequestResult As JObject = NetGetCodeByRequestRetry(ModrinthUrl, IsJson:=True, Encode:=Encoding.UTF8)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("hits")
ProjectList.Add(New CompProject(JsonEntry))
Sub()
Try
Log("[Comp] 开始从 Modrinth 获取工程列表:" & ModrinthUrl)
Dim RequestResult As JObject = DlModRequest(ModrinthUrl, IsJson:=True)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("hits")
ProjectList.Add(New CompProject(JsonEntry))
Next
'更新结果
SyncLock ResultsLock
For Each Project In ProjectList
If Task.Input.Type = CompType.Mod AndAlso Not Project.ModLoaders.Any() Then Continue For '过滤插件(#2458)
RawResults.Add(Project)
Next
'更新结果
SyncLock ResultsLock
For Each Project In ProjectList
If Task.Input.Type = CompType.Mod AndAlso Not Project.ModLoaders.Any() Then Continue For '过滤插件(#2458)
RawResults.Add(Project)
Next
End SyncLock
Storage.ModrinthOffset += ProjectList.Count
Storage.ModrinthTotal = RequestResult("total_hits").ToObject(Of Integer)
Log($"[Comp] 从 Modrinth 获取到了 {ProjectList.Count} 个工程(已获取 {Storage.ModrinthOffset} 个,共 {Storage.ModrinthTotal} 个)")
Catch ex As Exception
Log(ex, "从 Modrinth 获取工程列表失败")
Storage.ModrinthTotal = Storage.ModrinthOffset
[Error] = ex
ModrinthFailed = True
End Try
End Sub, "Modrinth Project Request")
End SyncLock
Storage.ModrinthOffset += ProjectList.Count
Storage.ModrinthTotal = RequestResult("total_hits").ToObject(Of Integer)
Log($"[Comp] 从 Modrinth 获取到了 {ProjectList.Count} 个工程(已获取 {Storage.ModrinthOffset} 个,共 {Storage.ModrinthTotal} 个)")
Catch ex As Exception
Log(ex, "从 Modrinth 获取工程列表失败")
Storage.ModrinthTotal = -1 'Storage.ModrinthOffset
[Error] = ex
ModrinthFailed = True
End Try
End Sub, "Modrinth Project Request")
End If
'等待线程结束
@@ -1021,7 +1034,7 @@ Retry:
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWithF("/") Then
Throw New Exception("Modrinth 不兼容所选的类型")
Else
Throw New Exception("没有符合条件的结果")
Throw New Exception("没有搜索结果")
End If
End If
ElseIf [Error] IsNot Nothing Then
@@ -1076,7 +1089,7 @@ Retry:
If String.IsNullOrEmpty(Task.Input.SearchText) Then
'如果没有搜索文本,按下载量将结果排序
For Each Result As CompProject In RealResults
Scores.Add(Result, Result.DownloadCount * If(Result.FromCurseForge, 1, 30))
Scores.Add(Result, Result.DownloadCount * If(Result.FromCurseForge, 1, 10))
Next
Else
'如果有搜索文本,按关联度将结果排序
@@ -1084,7 +1097,7 @@ Retry:
Dim Entry As New List(Of SearchEntry(Of CompProject))
For Each Result As CompProject In RealResults
Scores.Add(Result, If(Result.WikiId > 0, 0.2, 0) +
Math.Log10(Math.Max(Result.DownloadCount, 1) * If(Result.FromCurseForge, 1, 30)) / 9)
Math.Log10(Math.Max(Result.DownloadCount, 1) * If(Result.FromCurseForge, 1, 10)) / 9)
Entry.Add(New SearchEntry(Of CompProject) With {.Item = Result, .SearchSource = New List(Of KeyValuePair(Of String, Double)) From {
New KeyValuePair(Of String, Double)(If(IsChineseSearch, Result.TranslatedName, Result.RawName), 1),
New KeyValuePair(Of String, Double)(Result.Description, 0.05)}})
@@ -1149,7 +1162,7 @@ Retry:
''' </summary>
Public ReadOnly ModLoaders As List(Of CompModLoaderType)
''' <summary>
''' 支持的游戏版本列表。类型包括:"1.18.5","1.18","1.18 快照","21w15a","未知版本"。
''' 支持的游戏版本列表。类型包括:"1.18.5","1.18","1.18 预览版","21w15a","未知版本"。
''' </summary>
Public ReadOnly GameVersions As List(Of String)
''' <summary>
@@ -1253,7 +1266,9 @@ Retry:
DownloadUrls = (New List(Of String) From {Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"),
Url}).Distinct().ToList()
Url}).Distinct.ToList '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源,这个写法是为了让镜像源排在后面
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
@@ -1263,7 +1278,7 @@ Retry:
End If
'GameVersions
Dim RawVersions As List(Of String) = Data("gameVersions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.")).Select(Function(v) v.Replace("-snapshot", " 快照")).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.")).Select(Function(v) v.Replace("-snapshot", " 预览版")).ToList
If GameVersions.Count > 1 Then
GameVersions = Sort(GameVersions, AddressOf VersionSortBoolean).ToList
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
@@ -1287,11 +1302,10 @@ Retry:
ReleaseDate = Data("date_published")
Status = If(Data("version_type").ToString = "release", CompFileStatus.Release, If(Data("version_type").ToString = "beta", CompFileStatus.Beta, CompFileStatus.Alpha))
DownloadCount = Data("downloads")
'可能为空
If CType(Data("files"), JArray).Any() Then
If CType(Data("files"), JArray).Any() Then '可能为空
Dim File As JToken = Data("files")(0)
FileName = File("filename")
DownloadUrls = New List(Of String) From {File("url")}
DownloadUrls = New List(Of String) From {File("url"), DlSourceModGet(File("url"))}.Distinct.ToList '同时添加了镜像源
Hash = File("hashes")("sha1")
End If
'Dependencies
@@ -1305,7 +1319,7 @@ Retry:
'GameVersions
Dim RawVersions As List(Of String) = Data("game_versions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.") OrElse v.StartsWithF("b1.")).
Select(Function(v) If(v.Contains("-"), v.Before("-") & " 快照", If(v.StartsWithF("b1."), "远古版本", v))).ToList
Select(Function(v) If(v.Contains("-"), v.BeforeFirst("-") & " 预览版", If(v.StartsWithF("b1."), "远古版本", v))).ToList
If GameVersions.Count > 1 Then
GameVersions = Sort(GameVersions, AddressOf VersionSortBoolean).ToList
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
@@ -1354,28 +1368,26 @@ Retry:
Optional BadDisplayName As Boolean = False) As MyListItem
'获取描述信息
Dim Info As String = ""
Dim Title As String = If(BadDisplayName, FileName, DisplayName)
Dim Info As New List(Of String)
If Title <> FileName.BeforeLast(".") Then Info.Add(FileName.BeforeLast("."))
Select Case Type
Case CompType.Mod
Info += If(ModLoaders.Any,
"适用于 " & Join(ModLoaders.Select(Function(m) GetStringFromEnum(m)).ToList, "/") & ",", "")
Info += If(ModeDebug AndAlso Dependencies.Any, Dependencies.Count & " 个前置 Mod,", "")
If Dependencies.Any Then Info.Add(Dependencies.Count & " 个前置 Mod")
Case CompType.ModPack
If GameVersions.All(Function(v) v.Contains("w")) Then
Info += $"游戏版本 {Join(GameVersions, "、")},"
End If
If GameVersions.All(Function(v) v.Contains("w")) Then Info.Add($"游戏版本 {Join(GameVersions, "、")}")
End Select
If DownloadCount > 0 Then 'CurseForge 的下载次数经常错误地返回 0
Info += If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次下载,", DownloadCount & " 次下载,")
Info.Add("下载 " & If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次", DownloadCount & " 次"))
End If
Info += GetTimeSpanString(ReleaseDate - Date.Now, False) & "更新"
Info += If(Status = CompFileStatus.Release, "", "," & StatusDescription)
Info.Add("更新于 " & GetTimeSpanString(ReleaseDate - Date.Now, False))
If Status <> CompFileStatus.Release Then Info.Add(StatusDescription)
'建立控件
Dim NewItem As New MyListItem With {
.Title = If(BadDisplayName, FileName, DisplayName),
.Title = Title,
.SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Me,
.Info = Info
.Info = Info.Join(",")
}
Select Case Status
Case CompFileStatus.Release
@@ -1414,54 +1426,52 @@ Retry:
''' <summary>
''' 已知文件信息的缓存。
''' </summary>
Private CompFilesCache As New Dictionary(Of String, List(Of CompFile))
Public CompFilesCache As New Dictionary(Of String, List(Of CompFile))
''' <summary>
''' 获取某个工程下的全部文件列表。
''' 必须在工作线程执行,失败会抛出异常。
''' </summary>
Public Function CompFilesGet(ProjectId As String, FromCurseForge As Boolean) As List(Of CompFile)
'使用缓存
If CompFilesCache.ContainsKey(ProjectId) Then Return CompFilesCache(ProjectId)
'获取工程对象
Dim TargetProject As CompProject
If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存
TargetProject = CompProjectCache(ProjectId)
ElseIf FromCurseForge Then 'CurseForge
TargetProject = New CompProject(NetGetCodeByRequestRetry("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True, Encode:=Encoding.UTF8)("data"))
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data"))
Else 'Modrinth
TargetProject = New CompProject(NetGetCodeByRequestRetry("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True, Encode:=Encoding.UTF8))
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True))
End If
'获取工程对象的文件列表
Log("[Comp] 开始获取文件列表:" & ProjectId)
Dim ResultJsonArray As JArray
If FromCurseForge Then
'CurseForge
If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
ResultJsonArray = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data")
Else '否则使用全部文件
ResultJsonArray = NetGetCodeByRequestRetry($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", Accept:="application/json", IsJson:=True)("data")
If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回,这时候前置 Mod 可能没获取(#5173)
Log("[Comp] 开始获取文件列表:" & ProjectId)
Dim ResultJsonArray As JArray
If FromCurseForge Then
'CurseForge
If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data")
Else '否则使用全部文件
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data")
End If
Else
'Modrinth
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True)
End If
Else
'Modrinth
ResultJsonArray = NetGetCodeByRequestRetry($"https://api.modrinth.com/v2/project/{ProjectId}/version", Accept:="application/json", IsJson:=True)
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
Where(Function(a) a.Available).ToList.Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项(#1330)
End If
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
Where(Function(a) a.Available).ToList.Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项(#1330)
'获取前置 Mod 列表
If TargetProject.Type <> CompType.Mod Then Return CompFilesCache(ProjectId)
Dim Deps As List(Of String) = CompFilesCache(ProjectId).
SelectMany(Function(f) f.RawDependencies).Distinct().ToList
Dim Deps As List(Of String) = CompFilesCache(ProjectId).SelectMany(Function(f) f.RawDependencies).Distinct().ToList
Dim UndoneDeps = Deps.Where(Function(f) Not CompProjectCache.ContainsKey(f)).ToList
'获取前置 Mod 工程信息
If UndoneDeps.Any Then
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置 Mod:{Join(UndoneDeps, ",")}")
Dim Projects As JArray
If TargetProject.FromCurseForge Then
Projects = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods",
Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods",
"POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data")
Else
Projects = NetGetCodeByRequestRetry($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]",
Accept:="application/json", IsJson:=True)
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]", IsJson:=True)
End If
For Each Project In Projects
Dim NewProject As New CompProject(Project) '在 New 的时候就添加了缓存
@@ -1469,7 +1479,7 @@ Retry:
End If
'更新前置 Mod 信息
If Deps.Any Then
For Each DepProject In Deps.Select(Function(id) CompProjectCache(id))
For Each DepProject In Deps.Where(Function(id) CompProjectCache.ContainsKey(id)).Select(Function(id) CompProjectCache(id))
For Each File In CompFilesCache(ProjectId)
If File.RawDependencies.Contains(DepProject.Id) AndAlso DepProject.Id <> ProjectId Then
File.Dependencies.Add(DepProject.Id)
@@ -1489,10 +1499,11 @@ Retry:
Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList()
Deps.Sort()
If Not Deps.Any() Then Exit Sub
Deps = Deps.Where(Function(dep)
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置 Mod 信息", LogLevel.Debug)
Return CompProjectCache.ContainsKey(dep)
End Function).ToList
Deps = Deps.Where(
Function(dep)
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置 Mod 信息", LogLevel.Debug)
Return CompProjectCache.ContainsKey(dep)
End Function).ToList
'添加开头间隔
Stack.Children.Add(New TextBlock With {.Text = "前置 Mod", .FontSize = 14, .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 2, 0, 5)})
'添加前置 Mod 列表
@@ -381,6 +381,7 @@ Extracted:
没有可用的分析文件
使用32位Java导致JVM无法分配足够多的内存
Mod重复安装
Mod互不兼容
OptiFine与Forge不兼容
Fabric报错
Fabric报错并给出解决方案
@@ -389,7 +390,7 @@ Extracted:
版本Json中存在多个Forge
Mod过多导致超出ID限制
NightConfig的Bug
ShadersMod与Optifine同时安装
ShadersMod与OptiFine同时安装
Forge安装不完整
Mod需要Java11
Mod缺少前置或MC版本错误
@@ -413,7 +414,7 @@ Extracted:
'崩溃日志
If LogCrash IsNot Nothing Then
Log("[Crash] 开始进行崩溃日志堆栈分析")
Keywords.AddRange(AnalyzeStackKeyword(LogCrash.Before("System Details")))
Keywords.AddRange(AnalyzeStackKeyword(LogCrash.BeforeFirst("System Details")))
End If
'Minecraft 日志
If LogMc IsNot Nothing Then
@@ -516,7 +517,7 @@ Done:
If LogMc.Contains("java.lang.ClassNotFoundException: org.spongepowered.asm.launch.MixinTweaker") Then AppendReason(CrashReason.MixinBootstrap缺失)
If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
If LogMc.Contains("java.lang.OutOfMemoryError") OrElse LogMc.Contains("an out of memory error") Then AppendReason(CrashReason.内存不足)
If LogMc.Contains("java.lang.RuntimeException: Shaders Mod detected. Please remove it, OptiFine has built-in support for shaders.") Then AppendReason(CrashReason.ShadersMod与Optifine同时安装)
If LogMc.Contains("java.lang.RuntimeException: Shaders Mod detected. Please remove it, OptiFine has built-in support for shaders.") Then AppendReason(CrashReason.ShadersMod与OptiFine同时安装)
If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容)
If LogMc.Contains("1282: Invalid operation") Then AppendReason(CrashReason.光影或资源包导致OpenGL1282错误)
If LogMc.Contains("signer information does not match signer information of other classes in the same package") Then AppendReason(CrashReason.文件或内容校验失败, If(RegexSeek(LogMc, "(?<=class "")[^']+(?=""'s signer information)"), "").TrimEnd(vbCrLf))
@@ -525,6 +526,7 @@ Done:
If LogMc.Contains("Unsupported class file major version") Then AppendReason(CrashReason.Java版本不兼容)
If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") Then AppendReason(CrashReason.NightConfig的Bug)
If LogMc.Contains("Cannot find launch target fmlclient, unable to launch") Then AppendReason(CrashReason.Forge安装不完整)
If LogMc.Contains("Invalid paths argument, contained no existing paths") AndAlso LogMc.Contains("libraries\net\minecraftforge\fmlcore") Then AppendReason(CrashReason.Forge安装不完整)
If LogMc.Contains("Invalid module name: '' is not a Java identifier") Then AppendReason(CrashReason.Mod名称包含特殊字符)
If LogMc.Contains("has been compiled by a more recent version of the Java Runtime (class file version 55.0), this version of the Java Runtime only recognizes class file versions up to") Then AppendReason(CrashReason.Mod需要Java11)
If LogMc.Contains("java.lang.RuntimeException: java.lang.NoSuchMethodException: no such method: sun.misc.Unsafe.defineAnonymousClass(Class,byte[],Object[])Class/invokeVirtual") Then AppendReason(CrashReason.Mod需要Java11)
@@ -540,12 +542,14 @@ Done:
End If
'确定的 Mod 导致崩溃
If LogMc.Contains("Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(RegexSeek(LogMc, "(?<=Caught exception from )[^\n]+?")?.TrimEnd((vbCrLf & " ").ToCharArray)))
'Mod 重复安装
'Mod 重复 / 前置问题
If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]{1}:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList)
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
'Mod 缺少前置
If LogMc.Contains("Incompatible mods found!") Then '#5006
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), ""))
End If
If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then
AppendReason(CrashReason.Mod缺少前置或MC版本错误,
RegexSearch(LogMc, "(?<=Missing or unsupported mandatory dependencies:)([\n\r]+\t(.*))+", RegularExpressions.RegexOptions.IgnoreCase).
@@ -591,40 +595,57 @@ Done:
''' </summary>
Private Sub AnalyzeCrit2()
'Mixin 分析
Dim MixinAnalyze =
Function(LogText As String) As Boolean
Dim IsMixin As Boolean =
LogText.Contains("Mixin prepare failed ") OrElse LogText.Contains("Mixin apply failed ") OrElse
LogText.Contains("MixinApplyError") OrElse LogText.Contains("MixinTransformerError") OrElse
LogText.Contains("mixin.injection.throwables.") OrElse LogText.Contains(".json] FAILED during )")
If Not IsMixin Then Return False
'Mod 名称匹配
Dim ModName As String = RegexSeek(LogText, "(?<=from mod )[^.\/ ]+(?=\] from)")
If ModName Is Nothing Then ModName = RegexSeek(LogText, "(?<=for mod )[^.\/ ]+(?= failed)")
If ModName IsNot Nothing Then
AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(ModName.TrimEnd((vbCrLf & " ").ToCharArray)))
Return True
End If
'JSON 名称匹配
For Each JsonName In RegexSearch(LogText, "(?<=^[^\t]+[ \[{(]{1})[^ \[{(]+\.[^ ]+(?=\.json)", RegularExpressions.RegexOptions.Multiline)
AppendReason(CrashReason.ModMixin失败,
TryAnalyzeModName(JsonName.Replace("mixins", "mixin").Replace(".mixin", "").Replace("mixin.", "")))
Return True
Next
'没有明确匹配
AppendReason(CrashReason.ModMixin失败)
Return True
End Function
'游戏日志分析
If LogMc IsNot Nothing Then
'Mixin 崩溃
Dim IsMixin As Boolean = MixinAnalyze(LogMc)
'常规信息
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, RegexSeek(LogMc, "(?<=the game will display an error screen and halt.[\n\r]+[^\n]+?Exception: )[\s\S]+?(?=\n\tat)")?.Trim(vbCrLf))
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法,这样做可能会解决你的问题:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法,这样做可能会解决你的问题:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
'Mixin 崩溃
If LogMc.Contains("Mixin prepare failed ") OrElse LogMc.Contains("Mixin apply failed ") OrElse LogMc.Contains("MixinApplyError") OrElse
LogMc.Contains("mixin.injection.throwables.") OrElse LogMc.Contains(".json] FAILED during )") Then
Dim ModId As String = RegexSeek(LogMc, "(?<=in )[^./ ]+(?=.mixins.json.+failed injection check)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=in mixins.)[^./ ]+(?=.json.+failed injection check)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= failed .+ in )[^./ ]+(?=.mixins.json)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= failed .+ in mixins.)[^./ ]+(?=.json)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= failed mixins.)[^./ ]+(?=.json:)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= in config \[)[^./ ]+(?=.mixins.json\] FAILED during )")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= in config \[mixins.)[^./ ]+(?=.json\] FAILED during )")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=from mod )[^./ ]+(?=\] from)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=for mod )[^./ ]+(?= failed)")
'兜底名称判断
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "[^./ \]]+(?=.mixins.json)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=mixins.)[^./ \]]+(?=.json)")
AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(If(ModId, "").TrimEnd((vbCrLf & " ").ToCharArray)))
Else
'在 #3104 的情况下,这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败
If LogMc.Contains("due to errors, provided by ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If Not IsMixin AndAlso LogMc.Contains("due to errors, provided by ") Then '在 #3104 的情况下,这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败
AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
End If
End If
'崩溃报告分析
If LogCrash IsNot Nothing Then
'Mixin 崩溃
MixinAnalyze(LogCrash)
'常规信息
If LogCrash.Contains("Suspected Mod") Then
Dim Suspects = RegexSearch(LogCrash.Between("Suspected Mod", "Stacktrace"), "(?<=\n\t[^(\t]+\()[^)\n]+")
If Suspects.Any Then AppendReason(CrashReason.怀疑Mod导致游戏崩溃, TryAnalyzeModName(Suspects))
Dim SuspectsRaw As String = LogCrash.Between("Suspected Mod", "Stacktrace")
If Not SuspectsRaw.StartsWithF("s: None") Then 'Suspected Mods: None
Dim Suspects = RegexSearch(SuspectsRaw, "(?<=\n\t[^(\t]+\()[^)\n]+")
If Suspects.Any Then AppendReason(CrashReason.怀疑Mod导致游戏崩溃, TryAnalyzeModName(Suspects))
End If
End If
End If
@@ -640,6 +661,8 @@ Done:
If Not (LogMc.Contains("at net.") OrElse LogMc.Contains("INFO]")) AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing AndAlso LogMc.Length < 100 Then
AppendReason(CrashReason.极短的程序输出, LogMc)
End If
'Mod 解析错误(常见于 Fabric 前置校验失败)
If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错)
'Mixin 失败可以导致大量 Mod 实例创建失败
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
'注意:Fabric 的 Warnings were found! 不一定是崩溃原因,它可能是单纯的警报
@@ -695,7 +718,7 @@ NextStack:
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top", "mcp",
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi", "impl", "data", "pool", "task",
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world",
"gitlab", "common", "server", "config", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events",
"gitlab", "common", "server", "config", "mixins", "compat", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events",
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
"fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge",
"injection", "listeners", "scheduler", "minecraft", "transformer", "transformers", "neoforged", "universal", "multipart", "minecraftforge", "blockentity", "spongepowered", "electronwill"
@@ -738,13 +761,13 @@ NextStack:
Details = Details.Replace("Fabric Mods", "¨")
Log("[Crash] 崩溃报告中检测到 Fabric Mod 信息格式")
End If
Details = Details.After("¨")
Details = Details.AfterLast("¨")
'[Forge] 获取所有包含 .jar 的行
'[Fabric] 获取所有包含 Mod 信息的行
Dim ModNameLines As New List(Of String)
For Each Line In Details.Split(vbLf)
If Line.ContainsF(".jar", True) OrElse
If (Line.ContainsF(".jar", True) AndAlso Line.Length - Line.Replace(".jar", "").Length = 4) OrElse '只有一个 .jar
(IsFabricDetail AndAlso Line.StartsWithF(vbTab & vbTab) AndAlso Not RegexCheck(Line, "\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
Next
Log("[Crash] 崩溃报告中找到 " & ModNameLines.Count & " 个可能的 Mod 项目行")
@@ -844,8 +867,11 @@ NextStack:
Public Sub Output(IsHandAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing)
'弹窗提示
FrmMain.ShowWindowToTop()
Dim ShowLog As Action =
Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
"确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"),
Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing,
Sub()
'弹窗选择:查看日志
If File.Exists(DirectFile.Value.Key) Then
ShellOnly("notepad", DirectFile.Value.Key)
Else
@@ -853,11 +879,9 @@ NextStack:
WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf))
ShellOnly(FilePath)
End If
End Sub
Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
"确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"),
Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing, ShowLog))
End Sub))
Case 3
'弹窗选择:导出错误报告
Dim FileAddress As String = Nothing
Try
'获取文件路径
@@ -872,16 +896,23 @@ NextStack:
If ExtraFiles IsNot Nothing Then OutputFiles.AddRange(ExtraFiles)
For Each OutputFile In OutputFiles
Dim FileName As String = GetFileNameFromPath(OutputFile)
Dim FileEncoding As Encoding = Nothing
Select Case FileName
Case "LatestLaunch.bat"
FileName = "启动脚本.bat"
Case "Log1.txt"
FileName = "PCL 启动器日志.txt"
FileEncoding = Encoding.UTF8
Case "RawOutput.log"
FileName = "游戏崩溃前的输出.txt"
FileEncoding = Encoding.UTF8
End Select
If File.Exists(OutputFile) Then
WriteFile(TempFolder & "Report\" & FileName, SecretFilter(ReadFile(OutputFile), If(FileName = "启动脚本.bat", "F", "*")))
If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile))
WriteFile(TempFolder & "Report\" & FileName,
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
Encoding:=FileEncoding)
Log($"[Crash] 导出文件:{FileName},编码:{FileEncoding.HeaderName}")
End If
Next
'导出报告
@@ -905,7 +936,7 @@ NextStack:
If IsHandAnalyze Then
Return "很抱歉,PCL 无法确定错误原因。"
Else
Return $"很抱歉,你的游戏出现了一些问题……{vbCrLf}如果要寻求帮助,请导出错误报告并发给他人,而不是发送这个窗口的截图。"
Return $"很抱歉,你的游戏出现了一些问题……{vbCrLf}如果要寻求帮助,请把错误报告文件发给对方,而不是发送这个窗口的照片或者截图。"
End If
End If
@@ -938,9 +969,9 @@ NextStack:
End If
Case CrashReason.Mod缺少前置或MC版本错误
If Additional.Any Then
Results.Add("由于未满足 Mod 的依赖项,导致游戏退出。\n未满足的依赖项:\n - " & Join(Additional, "\n - ") & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Results.Add("由于未安装正确的前置 Mod,导致游戏退出。\n缺失的依赖项:\n - " & Join(Additional, "\n - ") & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("由于未满足 Mod 的依赖项,导致游戏退出。\n请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
Results.Add("由于未安装正确的前置 Mod,导致游戏退出。\n请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.堆栈分析发现关键字
If Additional.Count = 1 Then
@@ -961,7 +992,9 @@ NextStack:
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.ModMixin失败
If Additional.Count = 1 Then
If Additional.Count = 0 Then
Results.Add("部分 Mod 注入失败,导致游戏出错。\n这一般代表着部分 Mod 与其他 Mod 或当前环境不兼容,或是它存在 Bug。\n你可以尝试逐步禁用 Mod,然后观察游戏是否还会崩溃,以此定位导致崩溃的 Mod。\n\e\h")
ElseIf Additional.Count = 1 Then
Results.Add("名为 " & Additional.First & " 的 Mod 注入失败,导致游戏出错。\n这一般代表着它与其他 Mod 或当前环境不兼容,或是它存在 Bug。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n这一般代表着它们与其他 Mod 或当前环境不兼容,或是它存在 Bug。\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
@@ -976,7 +1009,7 @@ NextStack:
If Additional.Count = 1 Then
Results.Add("名为 " & Additional.First & " 的 Mod 初始化失败,导致游戏无法继续加载。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("以下 Mod 初始化失败,导致游戏无法继续加载:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Results.Add("以下 Mod 初始化失败,导致游戏出错:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.特定方块导致崩溃
If Additional.Count = 1 Then
@@ -988,7 +1021,7 @@ NextStack:
If Additional.Count >= 2 Then
Results.Add("你重复安装了多个相同的 Mod:\n - " & Join(Additional, "\n - ") & "\n\n每个 Mod 只能出现一次,请删除重复的 Mod,然后再启动游戏。")
Else
Results.Add("你可能重复安装了多个相同的 Mod,导致游戏无法继续加载。\n\n每个 Mod 只能出现一次,请删除重复的 Mod,然后再启动游戏。\e\h")
Results.Add("你可能重复安装了多个相同的 Mod,导致游戏出错。\n\n每个 Mod 只能出现一次,请删除重复的 Mod,然后再启动游戏。\e\h")
End If
Case CrashReason.特定实体导致崩溃
If Additional.Count = 1 Then
@@ -998,12 +1031,12 @@ NextStack:
End If
Case CrashReason.OptiFine与Forge不兼容
Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容,导致了游戏崩溃。\n\n请前往 OptiFine 官网(https://optifine.net/downloads)查看 OptiFine 所兼容的 Forge 版本,并严格按照对应版本重新安装游戏。")
Case CrashReason.ShadersMod与Optifine同时安装
Results.Add("无需同时安装 Optifine 和 Shaders Mod,Optifine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后,游戏即可正常运行。")
Case CrashReason.ShadersMod与OptiFine同时安装
Results.Add("无需同时安装 Optifine 和 Shaders Mod,OptiFine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后,游戏即可正常运行。")
Case CrashReason.低版本Forge与高版本Java不兼容
Results.Add("由于低版本 Forge 与当前 Java 不兼容,导致了游戏崩溃。\n\n请尝试以下解决方案:\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 1.8.0.320 的 Java")
Case CrashReason.版本Json中存在多个Forge
Results.Add("可能由于使用其他启动器修改了 Forge 版本,当前版本的文件存在异常,导致了游戏崩溃。\n请尝试重新全新安装 Forge,而非使用其他启动器修改 Forge 版本。")
Results.Add("可能由于其他启动器修改了 Forge 版本,当前版本的文件存在异常,导致了游戏崩溃。\n请尝试重新全新安装 Forge,而非使用其他启动器修改 Forge 版本。")
Case CrashReason.玩家手动触发调试崩溃
Results.Add("* 事实上,你的游戏没有任何问题,这是你自己触发的崩溃。\n* 你难道没有更重要的事要做吗?")
Case CrashReason.Mod需要Java11
@@ -1029,30 +1062,36 @@ NextStack:
Case CrashReason.文件或内容校验失败
Results.Add("部分文件或内容校验失败,导致游戏出现了问题。\n\n请尝试删除游戏(包括 Mod)并重新下载,或尝试在重新下载时使用 VPN。\h")
Case CrashReason.Forge安装不完整
Results.Add("由于 Forge 安装不完整,导致游戏无法正常运行。\n请尝试重新安装 Forge。\h")
Results.Add("由于安装的 Forge 文件丢失,导致游戏无法正常运行。\n请重新安装一次相同版本的 Forge,然后再启动游戏。\n在打包游戏时删除 libraries 文件夹可能导致此错误。\h")
Case CrashReason.Fabric报错
If Additional.Count = 1 Then
Results.Add("Fabric 提供了以下错误信息:\n" & Additional.First & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("Fabric 可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息,可以查看错误报告了解错误具体是如何发生的。\h")
Results.Add("Fabric 可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.Mod互不兼容
If Additional.Count = 1 Then
Results.Add("你所安装的 Mod 不兼容:\n" & Additional.First & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("你所安装的 Mod 不兼容,Mod 加载器可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.Mod加载器报错
If Additional.Count = 1 Then
Results.Add("Mod 加载器提供了以下错误信息:\n" & Additional.First & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("Mod 加载器可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息,可以查看错误报告了解错误具体是如何发生的。\h")
Results.Add("Mod 加载器可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.Fabric报错并给出解决方案
If Additional.Count = 1 Then
Results.Add("Fabric 提供了以下解决方案:\n" & Additional.First & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("Fabric 可能已经提供了解决方案,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息,可以查看错误报告了解错误具体是如何发生的。\h")
Results.Add("Fabric 可能已经提供了解决方案,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.Forge报错
If Additional.Count = 1 Then
Results.Add("Forge 提供了以下错误信息:\n" & Additional.First & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("Forge 可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息,可以查看错误报告了解错误具体是如何发生的。\h")
Results.Add("Forge 可能已经提供了错误信息,请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
End If
Case CrashReason.没有可用的分析文件
Results.Add("你的游戏出现了一些问题,但 PCL 未能找到相关记录文件,因此无法进行分析。\h")
@@ -1068,7 +1107,7 @@ NextStack:
Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf).
Trim(vbCrLf.ToCharArray) &
If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "",
vbCrLf & "如果要寻求帮助,请向他人发送错误报告文件,而不是发送这个窗口的截图。" &
vbCrLf & "如果要寻求帮助,请把错误报告文件发给对方,而不是发送这个窗口的照片或者截图。" &
If(If(PageSetupSystem.IsLauncherNewest(), True), "",
vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。"))
End Function
@@ -8,21 +8,20 @@
''' </summary>
Public Function DlClientJarGet(Version As McVersion, ReturnNothingOnFileUseable As Boolean) As NetFile
'获取底层继承版本
Do While Not String.IsNullOrEmpty(Version.InheritVersion)
Version = New McVersion(Version.InheritVersion)
Loop
Try
Do While Not String.IsNullOrEmpty(Version.InheritVersion)
Version = New McVersion(Version.InheritVersion)
Loop
Catch ex As Exception
Log(ex, "获取底层继承版本失败")
End Try
'检查 Json 是否标准
If Version.JsonObject("downloads") Is Nothing OrElse Version.JsonObject("downloads")("client") Is Nothing OrElse Version.JsonObject("downloads")("client")("url") Is Nothing Then
Throw New Exception("底层版本 " & Version.Name & " 中无 jar 文件下载信息")
End If
'检查文件
Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(Version.JsonObject("downloads")("client")("size"), -1), Hash:=Version.JsonObject("downloads")("client")("sha1"))
If ReturnNothingOnFileUseable Then
'是否跳过
Dim IsSetupSkip As Boolean = ShouldIgnoreFileCheck(Version)
If IsSetupSkip AndAlso File.Exists(Version.Path & Version.Name & ".jar") Then Return Nothing '跳过校验
If Checker.Check(Version.Path & Version.Name & ".jar") Is Nothing Then Return Nothing '通过校验
End If
If ReturnNothingOnFileUseable AndAlso Checker.Check(Version.Path & Version.Name & ".jar") Is Nothing Then Return Nothing '通过校验
'返回下载信息
Dim JarUrl As String = Version.JsonObject("downloads")("client")("url")
Return New NetFile(DlSourceLauncherOrMetaGet(JarUrl), Version.Path & Version.Name & ".jar", Checker)
@@ -52,7 +51,7 @@
''' <summary>
''' 构造补全某 Minecraft 版本的所有文件的加载器列表。失败会抛出异常。
''' </summary>
Public Function DlClientFix(Version As McVersion, CheckAssetsHash As Boolean, AssetsIndexBehaviour As AssetsIndexExistsBehaviour, SkipAssetsDownloadWhileSetupRequired As Boolean) As List(Of LoaderBase)
Public Function DlClientFix(Version As McVersion, CheckAssetsHash As Boolean, AssetsIndexBehaviour As AssetsIndexExistsBehaviour) As List(Of LoaderBase)
Dim Loaders As New List(Of LoaderBase)
#Region "下载支持库文件"
@@ -65,9 +64,9 @@
#End Region
#Region "下载资源文件"
Dim IsSetupSkip As Boolean = ShouldIgnoreFileCheck(Version)
If IsSetupSkip Then Log("[Download] 已跳过 Assets 下载")
If (Not SkipAssetsDownloadWhileSetupRequired) OrElse Not IsSetupSkip Then
If ShouldIgnoreFileCheck(Version) Then
Log("[Download] 已跳过所有 Assets 检查")
Else
Dim LoadersAssets As New List(Of LoaderBase)
'获取资源文件索引地址
LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析资源文件索引地址",
@@ -100,7 +99,7 @@
Task.Output = New List(Of NetFile) From {BackAssetsFile}
'检查是否需要更新:每天只更新一次
If File.Exists(RealAddress) AndAlso Math.Abs((File.GetLastWriteTime(RealAddress).Date - Now.Date).TotalDays) < 1 Then
Log("[Download] 无需更新资源文件索引")
Log("[Download] 无需更新资源文件索引,取消")
Task.Abort()
End If
End Sub))
@@ -117,7 +116,7 @@
'获取资源文件地址
LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析缺失资源文件",
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Task.Output = McAssetsFixList(McAssetsGetIndexName(Version), CheckAssetsHash, Task)
Task.Output = McAssetsFixList(Version, CheckAssetsHash, Task)
End Sub) With {.ProgressWeight = 3})
'下载资源文件
LoadersAssets.Add(New LoaderDownload("下载资源文件", New List(Of NetFile)) With {.ProgressWeight = 25})
@@ -168,24 +167,25 @@
End Structure
''' <summary>
''' Minecraft 客户端 版本列表,主加载器。
''' 若要求镜像源必须包含某个版本,则将该版本 ID 作为输入(#5195)。
''' </summary>
Public DlClientListLoader As New LoaderTask(Of Integer, DlClientListResult)("DlClientList Main", AddressOf DlClientListMain)
Private Sub DlClientListMain(Loader As LoaderTask(Of Integer, DlClientListResult))
Public DlClientListLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Main", AddressOf DlClientListMain)
Private Sub DlClientListMain(Loader As LoaderTask(Of String, DlClientListResult))
Select Case Setup.Get("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListMojangLoader, 60)
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListMojangLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListMojangLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListBmclapiLoader, 35)
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListMojangLoader, 5),
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListMojangLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlClientListResult), Integer)(DlClientListBmclapiLoader, 60)
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListMojangLoader, 60),
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -194,9 +194,9 @@
''' <summary>
''' Minecraft 客户端 版本列表,Mojang 官方源加载器。
''' </summary>
Public DlClientListMojangLoader As New LoaderTask(Of Integer, DlClientListResult)("DlClientList Mojang", AddressOf DlClientListMojangMain)
Public DlClientListMojangLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Mojang", AddressOf DlClientListMojangMain)
Private IsNewClientVersionHinted As Boolean = False
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of Integer, DlClientListResult))
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim Json As JObject = NetGetCodeByRequestRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", IsJson:=True)
Try
Dim Versions As JArray = Json("versions")
@@ -226,14 +226,21 @@
''' <summary>
''' Minecraft 客户端 版本列表,BMCLAPI 源加载器。
''' </summary>
Public DlClientListBmclapiLoader As New LoaderTask(Of Integer, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of Integer, DlClientListResult))
Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", IsJson:=True)
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
'添加 PCL 特供项
If File.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(ReadFile(PathTemp & "Cache\download.json")))
'检查是否有要求的版本(#5195)
If Not String.IsNullOrEmpty(Loader.Input) Then
Dim Id = Loader.Input
If Not DlClientListLoader.Output.Value("versions").Any(Function(v) v("id") = Id) Then
Throw New Exception("BMCLAPI 源未包含目标版本 " & Id)
End If
End If
'返回
Loader.Output = New DlClientListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Json}
Catch ex As Exception
@@ -246,26 +253,31 @@
''' </summary>
Public Function DlClientListGet(Id As String)
Try
'确认 Minecraft 版本列表已完成获取
Select Case DlClientListLoader.State
Case LoadState.Loading
DlClientListLoader.WaitForExit()
Case LoadState.Failed, LoadState.Aborted, LoadState.Waiting
DlClientListLoader.WaitForExit(IsForceRestart:=True)
End Select
'确认版本格式标准
Id = Id.Replace("_", "-") '1.7.10_pre4 在版本列表中显示为 1.7.10-pre4
If Id <> "1.0" AndAlso Id.EndsWithF(".0") Then Id = Left(Id, Id.Length - 2) 'OptiFine 1.8 的下载会触发此问题,显示版本为 1.8.0
'查找版本并开始
'获取 Minecraft 版本列表
Select Case DlClientListLoader.State
Case LoadState.Finished
'从当前的结果获取目标版本…
For Each Version As JObject In DlClientListLoader.Output.Value("versions")
If Version("id") = Id Then Return Version("url").ToString
Next
'…如果没有,则重新尝试获取(在版本刚更新时可能出现这种情况,#5195)
DlClientListLoader.WaitForExit(Id, IsForceRestart:=True)
Case LoadState.Loading
DlClientListLoader.WaitForExit(Id)
Case LoadState.Failed, LoadState.Aborted, LoadState.Waiting
DlClientListLoader.WaitForExit(Id, IsForceRestart:=True)
End Select
'重新查找版本
For Each Version As JObject In DlClientListLoader.Output.Value("versions")
If Version("id") = Id Then
Return Version("url").ToString
End If
If Version("id") = Id Then Return Version("url").ToString
Next
Log("未发现版本 " & Id & " 的 json 下载地址,版本列表返回为:" & vbCrLf & DlClientListLoader.Output.Value.ToString, LogLevel.Debug)
Log($"未发现版本 {Id} 的 json 下载地址,版本列表返回为:{vbCrLf}{DlClientListLoader.Output.Value.ToString}", LogLevel.Debug)
Return Nothing
Catch ex As Exception
Log(ex, "获取版本 " & Id & " 的 json 下载地址失败")
Log(ex, $"获取版本 {Id} 的 json 下载地址失败")
Return Nothing
End Try
End Function
@@ -338,17 +350,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -444,17 +456,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -589,17 +601,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -610,7 +622,9 @@
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Result As String
Try
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input & ".html", UseBrowserUserAgent:=True)
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4,#4057
".html", UseBrowserUserAgent:=True)
Catch ex As Exception
If GetExceptionSummary(ex).Contains("(404)") Then
Throw New Exception("没有可用版本")
@@ -679,7 +693,9 @@
''' Forge 版本列表,BMCLAPI。
''' </summary>
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & Loader.Input, IsJson:=True)
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
Loader.Input.Replace("-", "_"), '兼容 Forge 1.7.10-pre4,#4057
IsJson:=True)
Dim Versions As New List(Of DlForgeVersionEntry)
Try
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
@@ -777,7 +793,7 @@
Inherit = "1.20.1"
Else '20.4.30-beta
VersionName = ApiName
Version = New Version(ApiName.Before("-"))
Version = New Version(ApiName.BeforeFirst("-"))
Inherit = $"1.{Version.Major}" & If(Version.Minor = 0, "", "." & Version.Minor)
End If
End Sub
@@ -792,17 +808,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -828,8 +844,8 @@
''' <summary>
''' NeoForge 版本列表,BMCLAPI。
''' </summary>
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListOfficialMain)
Public Sub DlNeoForgeVersionBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain)
Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON
Dim ResultLatest As String = NetGetCodeByDownload("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLegacy As String = NetGetCodeByDownload("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
@@ -917,17 +933,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -1016,17 +1032,17 @@
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 30),
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListOfficialLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListOfficialLoader, 30 + 60)
}, Loader.IsForceRestarting)
Case 1
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListOfficialLoader, 5),
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 35)
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 5 + 30)
}, Loader.IsForceRestarting)
Case Else
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListOfficialLoader, 60),
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 60)
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 60 + 60)
}, Loader.IsForceRestarting)
End Select
End Sub
@@ -1075,29 +1091,155 @@
#End Region
#Region "DlMod | Mod 镜像源请求"
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理,返回字符串或 JObject。
''' 调用 NetGetCodeByRequest。
''' </summary>
Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As Object
Dim McimUrl As String = DlSourceModGet(Url)
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
If McimUrl <> Url Then
Select Case Setup.Get("ToolDownloadMod")
'TODO: 在 MCIM 源稳定后回调
Case 0
If ModeDebug Then
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End If
Case 1
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Case Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End Select
End If
Dim Exs As String = ""
For Each Source In Urls
Try
Return NetGetCodeByRequestOnce(Source.Key, Encode:=Encoding.UTF8, Timeout:=Source.Value * 1000, IsJson:=IsJson, UseBrowserUserAgent:=True)
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
Next
Throw New Exception(Exs)
End Function
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理。
''' 调用 NetRequest。
''' </summary>
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String) As String
Dim McimUrl As String = DlSourceModGet(Url)
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
If McimUrl <> Url Then
Select Case Setup.Get("ToolDownloadMod")
'TODO: 在 MCIM 源稳定后回调
Case 0
If ModeDebug Then
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End If
Case 1
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Case Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End Select
End If
Dim Exs As String = ""
For Each Source In Urls
Try
Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000)
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
Next
Throw New Exception(Exs)
End Function
#End Region
#Region "DlSource | 镜像下载源"
Public Function DlSourceResourceGet(MojangBase As String) As String()
MojangBase = MojangBase.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
Public Function DlSourceResourceGet(Original As String) As String()
Original = Original.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").
Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
Original
}
End Function
Public Function DlSourceLibraryGet(MojangBase As String) As String()
Public Function DlSourceLibraryGet(Original As String) As String()
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
Original
}
End Function
Public Function DlSourceLauncherOrMetaGet(MojangBase As String) As String()
If MojangBase Is Nothing Then Throw New Exception("无对应的 json 下载地址")
Public Function DlSourceModGet(Original As String) As String
Return Original.
Replace("api.modrinth.com", "mod.mcimirror.top/modrinth").
Replace("staging-api.modrinth.com", "mod.mcimirror.top/modrinth").
Replace("cdn.modrinth.com", "mod.mcimirror.top").
Replace("api.curseforge.com", "mod.mcimirror.top/curseforge").
Replace("edge.forgecdn.net", "mod.mcimirror.top").
Replace("mediafilez.forgecdn.net", "mod.mcimirror.top").
Replace("media.forgecdn.net", "mod.mcimirror.top")
End Function
Public Function DlSourceLauncherOrMetaGet(Original As String) As String()
If Original Is Nothing Then Throw New Exception("无对应的 json 下载地址")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
Original
}
End Function
@@ -1106,71 +1248,63 @@
Optional IsForceRestart As Boolean = False)
Dim WaitCycle As Integer = 0
Do While True
'检查加载结束
Dim IsAllFailed As Boolean = True
'检查状态
Dim BeforeLoadersAllFailed As Boolean = True
For Each SubLoader In LoaderList
If WaitCycle = 0 Then
'如果要强制刷新,就不使用已经加载好的值
If IsForceRestart Then Exit For
'如果输入不一样,就不使用已经加载好的值
If WaitCycle = 0 Then '判断是否可以不加载,直接使用已经加载好的结果
If IsForceRestart Then Continue For '强制刷新,不行
If (SubLoader.Key.Input Is Nothing Xor MainLoader.Input Is Nothing) OrElse
(SubLoader.Key.Input IsNot Nothing AndAlso Not SubLoader.Key.Input.Equals(MainLoader.Input)) Then Continue For
(SubLoader.Key.Input IsNot Nothing AndAlso Not SubLoader.Key.Input.Equals(MainLoader.Input)) Then Continue For '父子加载器的输入不一样,也不行
End If
If SubLoader.Key.State <> LoadState.Failed Then IsAllFailed = False
If SubLoader.Key.State <> LoadState.Failed Then BeforeLoadersAllFailed = False
If SubLoader.Key.State = LoadState.Finished Then
'检查加载器成功
MainLoader.Output = SubLoader.Key.Output
DlSourceLoaderAbort(LoaderList)
Exit Sub
ElseIf IsAllFailed Then
ElseIf BeforeLoadersAllFailed Then
'此前的加载器全部失败,直接启动后续加载器
If WaitCycle < SubLoader.Value * 100 Then WaitCycle = SubLoader.Value * 100
End If
'由于 Forge BMCLAPI 没有可用版本导致强制失败
'在没有可用版本时,官方源会一直卡住,直接使用 BMCLAPI 判定失败即可
If SubLoader.Key.Error IsNot Nothing AndAlso SubLoader.Key.Error.Message.Contains("没有可用版本") Then
For Each SubLoader2 In LoaderList
If WaitCycle < SubLoader2.Value * 100 Then WaitCycle = SubLoader2.Value * 100
Next
End If
Next
'启动加载源
'第一轮时:既然不直接使用已经加载好的结果,那就启动第一个加载器
If WaitCycle = 0 Then
'启动第一个源
LoaderList(0).Key.Start(MainLoader.Input, IsForceRestart)
'将其他源标记为未启动,以确保可以切换下载源(#184)
For i = 1 To LoaderList.Count - 1
LoaderList(i).Key.State = LoadState.Waiting
LoaderList.First.Key.Start(MainLoader.Input, IsForceRestart)
For Each Loader In LoaderList.Skip(1)
Loader.Key.State = LoadState.Waiting '将其他源标记为未启动,以确保可以切换下载源(#184)
Next
End If
'检查加载器失败或超时
For i = 0 To LoaderList.Count - 1
If WaitCycle = LoaderList(i).Value * 100 Then
If i < LoaderList.Count - 1 Then
'启动下一个源
LoaderList(i + 1).Key.Start(MainLoader.Input, IsForceRestart)
Else
'失败
Dim ErrorInfo As Exception = Nothing
For ii = 0 To LoaderList.Count - 1
LoaderList(ii).Key.Input = Nothing '重置输入,以免以同样的输入“重试加载”时直接失败
If LoaderList(ii).Key.Error IsNot Nothing Then
If ErrorInfo Is Nothing OrElse LoaderList(ii).Key.Error.Message.Contains("没有可用版本") Then
ErrorInfo = LoaderList(ii).Key.Error
End If
If WaitCycle <> LoaderList(i).Value * 100 Then Continue For
If i < LoaderList.Count - 1 AndAlso Not LoaderList.All(Function(l) l.Key.State = LoadState.Failed) Then
'若还有下一个源,则启动下一个源
LoaderList(i + 1).Key.Start(MainLoader.Input, IsForceRestart)
Else
'若没有,则失败
Dim ErrorInfo As Exception = Nothing
For ii = 0 To LoaderList.Count - 1
LoaderList(ii).Key.Input = Nothing '重置输入,以免以同样的输入“重试加载”时直接失败
If LoaderList(ii).Key.Error IsNot Nothing Then
If ErrorInfo Is Nothing OrElse LoaderList(ii).Key.Error.Message.Contains("没有可用版本") Then
ErrorInfo = LoaderList(ii).Key.Error
End If
Next
If ErrorInfo Is Nothing Then ErrorInfo = New TimeoutException("下载源连接超时")
DlSourceLoaderAbort(LoaderList)
Throw ErrorInfo
End If
Exit For
End If
Next
If ErrorInfo Is Nothing Then ErrorInfo = New TimeoutException("下载源连接超时")
DlSourceLoaderAbort(LoaderList)
Throw ErrorInfo
End If
Exit For
Next
'计时
Thread.Sleep(10)
WaitCycle += 1
'检查父加载器中断
If MainLoader.IsAborted Then
DlSourceLoaderAbort(LoaderList)
Exit Sub
End If
Thread.Sleep(10)
WaitCycle += 1
Loop
End Sub
Private Sub DlSourceLoaderAbort(Of InputType, OutputType)(LoaderList As List(Of KeyValuePair(Of LoaderTask(Of InputType, OutputType), Integer)))
@@ -1,5 +1,5 @@
Public Module ModJava
Public JavaListCacheVersion As Integer = 6
Public JavaListCacheVersion As Integer = 7
''' <summary>
''' 目前所有可用的 Java。
@@ -216,10 +216,12 @@
'添加特定的 Java
Dim JavaPreList As New Dictionary(Of String, Boolean)
If PathMcFolder.Split("\").Count > 3 Then
JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹(如果不是根目录的话)
If PathMcFolder.Split("\").Count > 3 AndAlso Not PathMcFolder.Contains("AppData\Roaming") Then
JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹(如果不是根目录或 %APPDATA% 的话)
End If
JavaSearchFolder(PathMcFolder, JavaPreList, False, True) 'Minecraft 文件夹
JavaPreList = JavaPreList.Where(Function(j) Not j.Key.Contains(".minecraft\runtime")).
ToDictionary(Function(j) j.Key, Function(j) j.Value) '排除官启自带 Java(#4286)
If RelatedVersion IsNot Nothing Then JavaSearchFolder(RelatedVersion.Path, JavaPreList, False, True) '所选版本文件夹
Dim TargetJavaList As New List(Of JavaEntry)
For Each Entry In JavaPreList
@@ -487,16 +489,18 @@ NoUserJava:
Public JavaSearchLoader As New LoaderTask(Of Integer, Integer)("查找 Java", AddressOf JavaSearchLoaderSub) With {.ProgressWeight = 2}
Private Sub JavaSearchLoaderSub(Loader As LoaderTask(Of Integer, Integer))
If FrmSetupLaunch IsNot Nothing Then
RunInUiWait(Sub()
FrmSetupLaunch.ComboArgumentJava.Items.Clear()
FrmSetupLaunch.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True})
End Sub)
RunInUiWait(
Sub()
FrmSetupLaunch.ComboArgumentJava.Items.Clear()
FrmSetupLaunch.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True})
End Sub)
End If
If FrmVersionSetup IsNot Nothing Then
RunInUiWait(Sub()
FrmVersionSetup.ComboArgumentJava.Items.Clear()
FrmVersionSetup.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True})
End Sub)
RunInUiWait(
Sub()
FrmVersionSetup.ComboArgumentJava.Items.Clear()
FrmVersionSetup.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True})
End Sub)
End If
Try
@@ -518,6 +522,7 @@ NoUserJava:
Next
'查找磁盘中的 Java
For Each Disk As DriveInfo In DriveInfo.GetDrives()
If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器(#3705)
JavaSearchFolder(Disk.Name, JavaPreList, False)
Next
'查找 APPDATA 文件夹中的 Java
@@ -550,7 +555,7 @@ NoUserJava:
'若不全为特殊引用,则清除特殊引用的地址
Dim JavaWithoutInherit As New Dictionary(Of String, Boolean)
For Each Pair In JavaPreList
If Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") Then
If Pair.Key.Contains("java8path_target_") OrElse Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") Then
Log("[Java] 位于 " & Pair.Key & " 的 Java 包含特殊引用")
Else
Log("[Java] 位于 " & Pair.Key & " 的 Java 不含特殊引用")
@@ -679,8 +684,8 @@ Wait:
For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories
If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接
Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).ToLower '用于搜索的字符串
If IsFullSearch OrElse FolderInfo.Parent.Name.ToLower = "users" OrElse
Keywords.Any(Function(w) SearchEntry.Contains(w)) OrElse SearchEntry = "bin" Then
If IsFullSearch OrElse
FolderInfo.Parent.Name.ToLower = "users" OrElse Val(SearchEntry) > 0 OrElse Keywords.Any(Function(w) SearchEntry.Contains(w)) OrElse SearchEntry = "bin" Then
JavaSearchFolder(FolderInfo, Results, Source)
End If
Next
@@ -4,6 +4,7 @@ Public Module ModLaunch
#Region "开始"
Public CurrentLaunchOptions As McLaunchOptions = Nothing
Public Class McLaunchOptions
''' <summary>
''' 强制指定在启动后进入的服务器 IP。
@@ -20,32 +21,34 @@ Public Module ModLaunch
''' 默认值:Nothing。使用 McVersionCurrent。
''' </summary>
Public Version As McVersion = Nothing
''' <summary>
''' 额外的启动参数。
''' </summary>
Public ExtraArgs As New List(Of String)
End Class
''' <summary>
''' 尝试启动 Minecraft。必须在 UI 线程调用。
''' 返回是否实际开始了启动(如果没有,则一定弹出了错误提示)。
''' </summary>
Public Function McLaunchStart(Optional Options As McLaunchOptions = Nothing) As Boolean
Options = If(Options, New McLaunchOptions)
CurrentLaunchOptions = If(Options, New McLaunchOptions)
'预检查
If Not RunInUi() Then
Throw New Exception("McLaunchStart 必须在 UI 线程调用!")
End If
If Not RunInUi() Then Throw New Exception("McLaunchStart 必须在 UI 线程调用!")
If McLaunchLoader.State = LoadState.Loading Then
Hint("已有游戏正在启动中!", HintType.Critical)
Return False
End If
'强制切换需要启动的版本
If Options.Version IsNot Nothing AndAlso McVersionCurrent <> Options.Version Then
McLaunchLog("在启动前切换到版本 " & Options.Version.Name)
If CurrentLaunchOptions.Version IsNot Nothing AndAlso McVersionCurrent <> CurrentLaunchOptions.Version Then
McLaunchLog("在启动前切换到版本 " & CurrentLaunchOptions.Version.Name)
'检查版本
Options.Version.Load()
If Options.Version.State = McVersionState.Error Then
Hint("无法启动 Minecraft:" & Options.Version.Info, HintType.Critical)
CurrentLaunchOptions.Version.Load()
If CurrentLaunchOptions.Version.State = McVersionState.Error Then
Hint("无法启动 Minecraft:" & CurrentLaunchOptions.Version.Info, HintType.Critical)
Return False
End If
'切换版本
McVersionCurrent = Options.Version
McVersionCurrent = CurrentLaunchOptions.Version
Setup.Set("LaunchVersionSelect", McVersionCurrent.Name)
FrmLaunchLeft.RefreshButtonsUI()
FrmLaunchLeft.RefreshPage(False, False)
@@ -95,7 +98,7 @@ Public Module ModLaunch
McLaunchPrecheck()
McLaunchLog("预检测已通过")
Catch ex As Exception
Hint(ex.Message, HintType.Critical)
If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical)
Throw
End Try
'正式加载
@@ -103,8 +106,8 @@ Public Module ModLaunch
'构造主加载器
Dim Loaders As New List(Of LoaderBase) From {
New LoaderTask(Of Integer, Integer)("获取 Java", AddressOf McLaunchJava) With {.ProgressWeight = 4, .Block = False},
McLoginLoader,
New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground, True)) With {.ProgressWeight = 15, .Show = False},
McLoginLoader, '.ProgressWeight = 15, .Block = False
New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground)) With {.ProgressWeight = 15, .Show = False},
New LoaderTask(Of String, List(Of McLibToken))("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2},
New LoaderTask(Of List(Of McLibToken), Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2},
New LoaderTask(Of Integer, Integer)("预启动处理", AddressOf McLaunchPrerun) With {.ProgressWeight = 1},
@@ -144,7 +147,7 @@ Public Module ModLaunch
Hint(McVersionCurrent.Name & " 启动成功!", HintType.Finish)
Case LoadState.Aborted
If AbortHint Is Nothing Then
Hint(If(Loader.Input.SaveBatch Is Nothing, "已取消启动!", "已取消导出启动脚本!"), HintType.Info)
Hint(If(CurrentLaunchOptions?.SaveBatch Is Nothing, "已取消启动!", "已取消导出启动脚本!"), HintType.Info)
Else
Hint(AbortHint, HintType.Finish)
End If
@@ -159,7 +162,7 @@ NextInner:
If CurrentEx.Message.StartsWithF("$") Then
'若有以 $ 开头的错误信息,则以此为准显示提示
'若错误信息为 $$,则不提示
If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(Loader.Input.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
Throw
ElseIf CurrentEx.InnerException IsNot Nothing Then
'检查下一级错误
@@ -168,7 +171,9 @@ NextInner:
Else
'没有特殊处理过的错误信息
McLaunchLog("错误:" & GetExceptionDetail(ex))
Log(ex, If(Loader.Input.SaveBatch Is Nothing, "Minecraft 启动失败", "导出启动脚本失败"), LogLevel.Msgbox, If(Loader.Input.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
Log(ex,
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "Minecraft 启动失败", "导出启动脚本失败"), LogLevel.Msgbox,
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
Throw
End If
End Try
@@ -211,36 +216,45 @@ NextInner:
If McVersionCurrent.State = McVersionState.Error Then Throw New Exception("Minecraft 存在问题:" & McVersionCurrent.Info)
'检查输入信息
Dim CheckResult As String = ""
RunInUiWait(Sub()
Dim LoginInput As McLoginData = McLoginInput()
CheckResult = McLoginAble(LoginInput)
End Sub)
RunInUiWait(Sub() CheckResult = McLoginAble(McLoginInput()))
If CheckResult <> "" Then Throw New ArgumentException(CheckResult)
#If BETA Then
'求赞助
RunInNewThread(Sub()
Select Case Setup.Get("SystemLaunchCount")
Case 20, 50, 100, 150, 200, 250, 300, 350, 400, 450, 500, 600, 700, 800, 900, 1000, 1100, 1200, 1300, 1400, 1500, 1700, 1900, 2100, 2300, 2500
If MyMsgBox("PCL 已经为你启动了 " & Setup.Get("SystemLaunchCount") & " 次游戏啦!" & vbCrLf &
"如果觉得 PCL 还算好用的话,也可以考虑赞助一下作者……一点心意也行……" & vbCrLf &
"毕竟一个人开发也不容易(悲)……",
"求赞助啦……", "这就赞助!", "但是我拒绝") = 1 Then
OpenWebsite("https://afdian.net/a/LTCat")
End If
End Select
End Sub, "Donate")
RunInNewThread(
Sub()
Select Case Setup.Get("SystemLaunchCount")
Case 10, 20, 40, 60, 80, 100, 120, 150, 200, 250, 300, 350, 400, 500, 600, 700, 800, 900, 1000, 1200, 1400, 1600, 1800, 2000
If MyMsgBox("PCL 已经为你启动了 " & Setup.Get("SystemLaunchCount") & " 次游戏啦!" & vbCrLf &
"如果 PCL 还算好用的话,能不能考虑赞助一下 PCL……" & vbCrLf &
"如果没有大家的支持,PCL 很难在免费、无任何广告的情况下维持数年的更新(磕头)……!",
Setup.Get("SystemLaunchCount") & " 次启动!", "支持 PCL!", "但是我拒绝") = 1 Then
OpenWebsite("https://afdian.com/a/LTCat")
End If
End Select
End Sub, "Donate")
#End If
'正版购买提示
If Not Setup.Get("HintBuy") AndAlso Setup.Get("LoginType") <> McLoginType.Ms Then
Select Case Setup.Get("SystemLaunchCount")
Case 10, 35, 75, 125, 175, 225, 275, 325, 375, 425, 475, 550, 650, 750, 850, 950, 1050, 1150, 1250, 1350, 1450, 1600, 1800, 2000, 2200, 2400
If MyMsgBox("你已经启动了 " & Setup.Get("SystemLaunchCount") & " 次 Minecraft 啦!" & vbCrLf &
"如果觉得 Minecraft 还不错,也可以考虑购买正版支持一下,毕竟开发游戏也很不容易……" & vbCrLf &
"在你登录一次正版账号后,就不会再出现这个提示了。",
"考虑一下正版?", "购买正版游戏", "下次一定") = 1 Then
OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj")
End If
End Select
If IsSystemLanguageChinese() Then
Select Case Setup.Get("SystemLaunchCount")
Case 3, 8, 15, 30, 50, 70, 90, 110, 130, 180, 220, 280, 330, 380, 450, 550, 660, 750, 880, 950, 1100, 1300, 1500, 1700, 1900
If MyMsgBox("你已经启动了 " & Setup.Get("SystemLaunchCount") & " 次 Minecraft 啦!" & vbCrLf &
"如果觉得 Minecraft 还不错,可以购买正版支持一下,毕竟开发游戏也真的很不容易……不要一直白嫖啦。" & vbCrLf & vbCrLf &
"在登录一次正版账号后,就不会再出现这个提示了!",
"考虑一下正版?", "支持正版游戏!", "下次一定") = 1 Then
OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj")
End If
End Select
ElseIf Setup.Get("LoginType") = McLoginType.Legacy Then
Select Case MyMsgBox("你必须先登录正版账号,才能进行离线登录!", "正版验证", "购买正版", "试玩", "返回",
Button1Action:=Sub() OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj"))
Case 2
Hint("游戏将以试玩模式启动!", HintType.Critical)
CurrentLaunchOptions.ExtraArgs.Add("--demo")
Case 3
Throw New Exception("$$")
End Select
End If
End If
End Sub
@@ -364,19 +378,19 @@ NextInner:
'根据当前登录方式优先返回
Select Case Setup.Get("LoginType")
Case McLoginType.Ms
If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
If Setup.Get("CacheMsV2Name") <> "" Then Return Setup.Get("CacheMsV2Name")
Case McLoginType.Legacy
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Before("¨")
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.BeforeFirst("¨")
Case McLoginType.Nide
If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
Case McLoginType.Auth
If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName")
End Select
'查找所有可能的项
If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
If Setup.Get("CacheMsV2Name") <> "" Then Return Setup.Get("CacheMsV2Name")
If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName")
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Before("¨")
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.BeforeFirst("¨")
Return Nothing
End Function
''' <summary>
@@ -385,7 +399,7 @@ NextInner:
Public Function McLoginAble() As String
Select Case Setup.Get("LoginType")
Case McLoginType.Ms
If Setup.Get("CacheMsOAuthRefresh") = "" Then
If Setup.Get("CacheMsV2OAuthRefresh") = "" Then
Return FrmLoginMs.IsVaild()
Else
Return ""
@@ -436,7 +450,7 @@ NextInner:
Case McLoginType.Legacy
LoginData = PageLoginLegacy.GetLoginData()
Case McLoginType.Ms
If Setup.Get("CacheMsOAuthRefresh") = "" Then
If Setup.Get("CacheMsV2OAuthRefresh") = "" Then
LoginData = PageLoginMs.GetLoginData()
Else
LoginData = PageLoginMsSkin.GetLoginData()
@@ -487,19 +501,22 @@ NextInner:
#Region "分方式登录模块"
'各个登录方式的主对象与输入构造
Public McLoginMsLoader As New LoaderTask(Of McLoginMs, McLoginResult)("Loader Login Ms", AddressOf McLoginMsStart) With {.ReloadTimeout = 300000}
Public McLoginMsLoader As New LoaderTask(Of McLoginMs, McLoginResult)("Loader Login Ms", AddressOf McLoginMsStart) With {.ReloadTimeout = 1}
Public McLoginLegacyLoader As New LoaderTask(Of McLoginLegacy, McLoginResult)("Loader Login Legacy", AddressOf McLoginLegacyStart)
Public McLoginNideLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Nide", AddressOf McLoginServerStart) With {.ReloadTimeout = 60000}
Public McLoginAuthLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Auth", AddressOf McLoginServerStart) With {.ReloadTimeout = 60000}
Public McLoginNideLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Nide", AddressOf McLoginServerStart) With {.ReloadTimeout = 1000 * 60 * 10}
Public McLoginAuthLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Auth", AddressOf McLoginServerStart) With {.ReloadTimeout = 1000 * 60 * 10}
'主加载函数,返回所有需要的登录信息
Private McLoginMsRefreshTime As Long = 0 '上次刷新登录的时间
Private Sub McLoginMsStart(Data As LoaderTask(Of McLoginMs, McLoginResult))
Dim Input As McLoginMs = Data.Input
Dim LogUsername As String = Input.UserName
McLaunchLog("登录方式:正版(" & If(LogUsername = "", "尚未登录", LogUsername) & ")")
Data.Progress = 0.05
'检查是否已经登录完成
If Input.AccessToken <> "" AndAlso Not Data.IsForceRestarting Then
If Not Data.IsForceRestarting AndAlso '不要求强行重启
Input.AccessToken <> "" AndAlso '已经登录过了
(McLoginMsRefreshTime > 0 AndAlso GetTimeTick() - McLoginMsRefreshTime < 1000 * 60 * 10) Then '完成时间在 10 分钟内
Data.Output = New McLoginResult With
{.AccessToken = Input.AccessToken, .Name = Input.UserName, .Uuid = Input.Uuid, .Type = "Microsoft", .ClientToken = Input.Uuid, .ProfileJson = Input.ProfileJson}
GoTo SkipLogin
@@ -509,49 +526,47 @@ NextInner:
If Input.OAuthRefreshToken = "" Then
'无 RefreshToken
Relogin:
Dim OAuthCode As String = MsLoginStep1(Data)
If Data.IsAborted Then Throw New ThreadInterruptedException
Data.Progress = 0.2
OAuthTokens = MsLoginStep2(OAuthCode, False)
OAuthTokens = MsLoginStep1New(Data)
Else
'有 RefreshToken
OAuthTokens = MsLoginStep2(Input.OAuthRefreshToken, True)
OAuthTokens = MsLoginStep1Refresh(Input.OAuthRefreshToken)
If OAuthTokens(0) = "Relogin" Then GoTo Relogin '要求重新打开登录网页认证
End If
'要求重新打开登录网页认证
If OAuthTokens(0) = "Relogin" Then GoTo Relogin
Data.Progress = 0.35
If Data.IsAborted Then Throw New ThreadInterruptedException
Data.Progress = 0.25
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim OAuthAccessToken As String = OAuthTokens(0)
Dim OAuthRefreshToken As String = OAuthTokens(1)
Dim XBLToken As String = MsLoginStep3(OAuthAccessToken)
Data.Progress = 0.5
Dim XBLToken As String = MsLoginStep2(OAuthAccessToken)
Data.Progress = 0.4
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim Tokens = MsLoginStep4(XBLToken)
Data.Progress = 0.65
Dim Tokens = MsLoginStep3(XBLToken)
Data.Progress = 0.55
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim AccessToken As String = MsLoginStep5(Tokens)
Data.Progress = 0.8
Dim AccessToken As String = MsLoginStep4(Tokens)
Data.Progress = 0.7
If Data.IsAborted Then Throw New ThreadInterruptedException
MsLoginStep6(AccessToken)
Data.Progress = 0.9
MsLoginStep5(AccessToken)
Data.Progress = 0.85
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim Result = MsLoginStep7(AccessToken)
Dim Result = MsLoginStep6(AccessToken)
Data.Progress = 0.98
'输出登录结果
Setup.Set("CacheMsOAuthRefresh", OAuthRefreshToken)
Setup.Set("CacheMsAccess", AccessToken)
Setup.Set("CacheMsUuid", Result(0))
Setup.Set("CacheMsName", Result(1))
Setup.Set("CacheMsProfileJson", Result(2))
Setup.Set("CacheMsV2OAuthRefresh", OAuthRefreshToken)
Setup.Set("CacheMsV2Access", AccessToken)
Setup.Set("CacheMsV2Uuid", Result(0))
Setup.Set("CacheMsV2Name", Result(1))
Setup.Set("CacheMsV2ProfileJson", Result(2))
Dim MsJson As JObject = GetJson(Setup.Get("LoginMsJson"))
MsJson.Remove(Input.UserName) '如果更改了玩家名……
MsJson(Result(1)) = OAuthRefreshToken
Setup.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None))
Data.Output = New McLoginResult With {.AccessToken = AccessToken, .Name = Result(1), .Uuid = Result(0), .Type = "Microsoft", .ClientToken = Result(0), .ProfileJson = Result(2)}
'解锁主题
SkipLogin:
'结束
McLoginMsRefreshTime = GetTimeTick()
McLaunchLog("微软登录完成")
SkipLogin:
Setup.Set("HintBuy", True) '关闭正版购买提示
Data.Progress = 0.98
If ThemeUnlock(10, False) Then MyMsgBox("感谢你对正版游戏的支持!" & vbCrLf & "隐藏主题 跳票红 已解锁!", "提示")
End Sub
Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
@@ -668,6 +683,7 @@ LoginFinish:
Url:=Data.Input.BaseUrl & "/validate",
Method:="POST",
Data:=RequestData.ToString(0),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh_CN"}},
ContentType:="application/json; charset=utf-8") '没有返回值的
'将登录结果输出
Data.Output.AccessToken = AccessToken
@@ -691,6 +707,7 @@ LoginFinish:
""name"":""" & Setup.Get("Cache" & Data.Input.Token & "Name") & """},", "") & "
""accessToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Access") & """,
""clientToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Client") & """}",
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh_CN"}},
ContentType:="application/json; charset=utf-8"))
'将登录结果输出
If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效!")
@@ -721,6 +738,7 @@ LoginFinish:
Url:=Data.Input.BaseUrl & "/authenticate",
Method:="POST",
Data:=RequestData.ToString(0),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh_CN"}},
ContentType:="application/json; charset=utf-8"))
'检查登录结果
If LoginJson("availableProfiles").Count = 0 Then
@@ -780,6 +798,28 @@ LoginFinish:
Catch ex As Exception
Dim AllMessage As String = GetExceptionSummary(ex)
Log(ex, "登录失败原始错误信息", LogLevel.Normal)
'读取服务器返回的错误
If TypeOf ex Is ResponsedWebException Then
Dim ErrorMessage As String = Nothing
Try
ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage")
Catch
End Try
If Not String.IsNullOrWhiteSpace(ErrorMessage) Then
If ErrorMessage.Contains("密码错误") OrElse ErrorMessage.ContainsF("Incorrect username or password", True) Then
'密码错误,退出登录 (#5090)
McLaunchLog("密码错误,退出登录")
Select Case Data.Input.Type
Case McLoginType.Auth
RunInUi(AddressOf PageLoginAuthSkin.ExitLogin)
Case McLoginType.Nide
RunInUi(AddressOf PageLoginNideSkin.ExitLogin)
End Select
End If
Throw New Exception("$登录失败:" & ErrorMessage)
End If
End If
'通用关键字检测
If AllMessage.Contains("403") Then
Select Case Data.Input.Type
Case McLoginType.Auth
@@ -805,90 +845,48 @@ LoginFinish:
End Try
End Function
'微软登录步骤 1:打开网页认证,获取 OAuth Code
Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
McLaunchLog("开始微软登录步骤 1")
If True OrElse OsVersion <= New Version(10, 0, 17763, 0) Then '由于 #3849,WebBrowser 已经无法正常加载微软登录网页了
SystemBrowser:
'Windows 7 或老版 Windows 10 登录
OpenWebsite(FormLoginOAuth.LoginUrl1)
Dim Result As String =
MyMsgBoxInput("等待网页登录",
"登录完成后,网页会变得完全空白,把那个空白网页的网址复制到下面的框中就行了!" & vbCrLf &
"如果网络环境不佳,它可能一直加载不出来,那就只能试试用 VPN 或加速器了。",
ValidateRules:=New ObjectModel.Collection(Of Validate) From {New ValidateRegex("(?<=code\=)[^&]+", "返回网址应以 https://login.live.com/oauth20_desktop.srf?code= 开头")},
HintText:="https://login.live.com/oauth20_desktop.srf?code=XXXXXX")
If Result Is Nothing Then
McLaunchLog("微软登录已在步骤 1 被取消")
Throw New ThreadInterruptedException("$$")
'微软登录步骤 1,原始登录:获取 DeviceCode 并开启登录网页
Private Function MsLoginStep1New(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String()
'参考:https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code
'初始请求
Retry:
McLaunchLog("开始微软登录步骤 1/6(原始登录)")
Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded"))
McLaunchLog("网页登录地址:" & PrepareJson("verification_uri").ToString)
'弹窗
Dim Converter As New MyMsgBoxConverter With {.Content = PrepareJson, .ForceWait = True, .Type = MyMsgBoxType.Login}
WaitingMyMsgBox.Add(Converter)
While Converter.Result Is Nothing
Thread.Sleep(100)
End While
If TypeOf Converter.Result Is RestartException Then
If MyMsgBox($"请在登录时选择 {vbLQ}其他登录方法{vbRQ},然后选择 {vbLQ}使用我的密码{vbRQ}。{vbCrLf}如果没有该选项,请选择 {vbLQ}设置密码{vbRQ},设置完毕后再登录。",
"需要使用密码登录", "重新登录", "设置密码", "取消",
Button2Action:=Sub() OpenWebsite("https://account.live.com/password/Change")) = 1 Then
GoTo Retry
Else
Return RegexSeek(Result, "(?<=code\=)[^&]+")
Throw New Exception("$$")
End If
Hint("网页登录成功,你可以关闭浏览器啦!", HintType.Finish)
ElseIf TypeOf Converter.Result Is Exception Then
Throw CType(Converter.Result, Exception)
Else
'Windows 10 登录
Dim ReturnCode As String = Nothing
Dim ReturnEx As Exception = Nothing
Dim IsFinished As LoadState = LoadState.Loading
Dim LoginForm As FormLoginOAuth = Nothing
Dim IsSwitchToSystemBrowser As Boolean = False
RunInUi(Sub()
Try
LoginForm = New FormLoginOAuth
LoginForm.Show()
AddHandler LoginForm.OnLoginSuccess, Sub(Code As String)
ReturnCode = Code
IsFinished = LoadState.Finished
End Sub
AddHandler LoginForm.OnLoginCanceled, Sub(IsSwitch As Boolean)
IsFinished = LoadState.Aborted
IsSwitchToSystemBrowser = IsSwitch
End Sub
Catch ex As Exception
ReturnEx = ex
IsFinished = LoadState.Failed
End Try
End Sub)
Do While IsFinished = LoadState.Loading AndAlso Not Data.IsAborted
Thread.Sleep(20)
Loop
RunInUi(Sub() If LoginForm IsNot Nothing Then LoginForm.Close())
If IsFinished = LoadState.Finished Then
Return ReturnCode
ElseIf IsFinished = LoadState.Failed Then
Throw ReturnEx
ElseIf IsSwitchToSystemBrowser Then
McLaunchLog("微软登录在步骤 1 要求切换到系统浏览器")
GoTo SystemBrowser
Else
McLaunchLog("微软登录已在步骤 1 被取消")
Throw New ThreadInterruptedException("$$")
End If
Return Converter.Result
End If
End Function
'微软登录步骤 2:从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
Private Function MsLoginStep2(Code As String, IsRefresh As Boolean) As String()
McLaunchLog("开始微软登录步骤 2(" & If(IsRefresh, "", "非") & "刷新登录)")
'微软登录步骤 1,刷新登录:从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
Private Function MsLoginStep1Refresh(Code As String) As String()
McLaunchLog("开始微软登录步骤 1/6(刷新登录)")
Dim Request As String
If IsRefresh Then
Request = "client_id=00000000402b5328" & "&" &
"refresh_token=" & Uri.EscapeDataString(Code) & "&" &
"grant_type=refresh_token" & "&" &
"redirect_uri=" & Uri.EscapeDataString("https://login.live.com/oauth20_desktop.srf") & "&" &
"scope=" & Uri.EscapeDataString("service::user.auth.xboxlive.com::MBI_SSL")
Else
Request = "client_id=00000000402b5328" & "&" &
"code=" & Uri.EscapeDataString(Code) & "&" &
"grant_type=authorization_code" & "&" &
"redirect_uri=" & Uri.EscapeDataString("https://login.live.com/oauth20_desktop.srf") & "&" &
"scope=" & Uri.EscapeDataString("service::user.auth.xboxlive.com::MBI_SSL")
End If
Dim Result As String
Try
Result = NetRequestMulty("https://login.live.com/oauth20_token.srf", "POST", Request, "application/x-www-form-urlencoded", 2)
Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST",
$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
"application/x-www-form-urlencoded", 2)
Catch ex As Exception
If ex.Message.Contains("must sign in again") OrElse ex.Message.Contains("invalid_grant") Then '#269
If ex.Message.Contains("must sign in again") OrElse (ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269
Return {"Relogin", ""}
Else
Throw
@@ -900,28 +898,28 @@ SystemBrowser:
Dim RefreshToken As String = ResultJson("refresh_token").ToString
Return {AccessToken, RefreshToken}
End Function
'微软登录步骤 3:从 OAuth AccessToken 获取 XBLToken
Private Function MsLoginStep3(AccessToken As String) As String
McLaunchLog("开始微软登录步骤 3")
'微软登录步骤 2:从 OAuth AccessToken 获取 XBLToken
Private Function MsLoginStep2(AccessToken As String) As String
McLaunchLog("开始微软登录步骤 2/6")
Dim Request As String = "{
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}"
Dim Result As String = NetRequestMulty("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & If(AccessToken.StartsWithF("d="), "", "d=") & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}"
Dim Result As String = NetRequestMultiple("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
Dim ResultJson As JObject = GetJson(Result)
Dim XBLToken As String = ResultJson("Token").ToString
Return XBLToken
End Function
'微软登录步骤 4:从 XBLToken 获取 {XSTSToken, UHS}
Private Function MsLoginStep4(XBLToken As String) As String()
McLaunchLog("开始微软登录步骤 4")
'微软登录步骤 3:从 XBLToken 获取 {XSTSToken, UHS}
Private Function MsLoginStep3(XBLToken As String) As String()
McLaunchLog("开始微软登录步骤 3/6")
Dim Request As String = "{
""Properties"": {
@@ -935,7 +933,7 @@ SystemBrowser:
}"
Dim Result As String
Try
Result = NetRequestMulty("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
Catch ex As Net.WebException
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
If ex.Message.Contains("2148916227") Then
@@ -971,14 +969,14 @@ SystemBrowser:
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
Return {XSTSToken, UHS}
End Function
'微软登录步骤 5:从 {XSTSToken, UHS} 获取 Minecraft AccessToken
Private Function MsLoginStep5(Tokens As String()) As String
McLaunchLog("开始微软登录步骤 5")
'微软登录步骤 4:从 {XSTSToken, UHS} 获取 Minecraft AccessToken
Private Function MsLoginStep4(Tokens As String()) As String
McLaunchLog("开始微软登录步骤 4/6")
Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0)
Dim Result As String
Try
Result = NetRequestMulty("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json", 2)
Result = NetRequestRetry("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json")
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then
@@ -996,11 +994,11 @@ SystemBrowser:
Dim AccessToken As String = ResultJson("access_token").ToString
Return AccessToken
End Function
'微软登录步骤 6:验证微软账号是否持有 MC,这也会刷新 XGP
Private Sub MsLoginStep6(AccessToken As String)
McLaunchLog("开始微软登录步骤 6")
'微软登录步骤 5:验证微软账号是否持有 MC,这也会刷新 XGP
Private Sub MsLoginStep5(AccessToken As String)
McLaunchLog("开始微软登录步骤 5/6")
Dim Result As String = NetRequestMulty("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Dim Result As String = NetRequestMultiple("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Try
Dim ResultJson As JObject = GetJson(Result)
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
@@ -1015,13 +1013,13 @@ SystemBrowser:
Throw
End Try
End Sub
'微软登录步骤 7:从 Minecraft AccessToken 获取 {UUID, UserName, ProfileJson}
Private Function MsLoginStep7(AccessToken As String) As String()
McLaunchLog("开始微软登录步骤 7")
'微软登录步骤 6:从 Minecraft AccessToken 获取 {UUID, UserName, ProfileJson}
Private Function MsLoginStep6(AccessToken As String) As String()
McLaunchLog("开始微软登录步骤 6/6")
Dim Result As String
Try
Result = NetRequestMulty("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then
@@ -1069,7 +1067,7 @@ SystemBrowser:
Case 3
'使用正版用户名
Try
If Not SkinName = "" Then
If SkinName <> "" AndAlso McVersionCurrent.Version.McCodeMain < 20 Then '1.20+ 或快照版不能使用该项(#3746)
Log("[Skin] 由于离线皮肤设置,使用正版 UUID:" & SkinName)
Uuid = McLoginMojangUuid(SkinName, False)
End If
@@ -1199,7 +1197,7 @@ SystemBrowser:
'统一通行证检测
If Setup.Get("LoginType") = McLoginType.Nide Then
'至少 Java 8u101
MinVer = If(New Version(1, 8, 0, 101) > MinVer, New Version(1, 8, 0, 101), MinVer)
MinVer = If(New Version(1, 8, 0, 141) > MinVer, New Version(1, 8, 0, 141), MinVer)
End If
SyncLock JavaLock
@@ -1226,12 +1224,12 @@ SystemBrowser:
ElseIf MaxVer < New Version(1, 8, 0, 0) Then
JavaCode = 7
If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 100) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = "8u101"
If Not JavaDownloadConfirm("Java 8.0.101 ~ 8.0.320", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 100) Then
JavaCode = "8u101"
If Not JavaDownloadConfirm("Java 8.0.101 或更高版本的 Java 8", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 140) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = "8u141"
If Not JavaDownloadConfirm("Java 8.0.141 ~ 8.0.320", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 140) Then
JavaCode = "8u141"
If Not JavaDownloadConfirm("Java 8.0.141 或更高版本的 Java 8", True) Then Throw New Exception("$$")
ElseIf MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = 8
If Not JavaDownloadConfirm("Java 8.0.320 或更低版本的 Java 8") Then Throw New Exception("$$")
@@ -1276,28 +1274,35 @@ SystemBrowser:
''' 释放 Java Wrapper 并返回完整文件路径。
''' </summary>
Public Function ExtractJavaWrapper() As String
Dim WrapperPath As String = GetJavaWrapperDir() & "\JavaWrapper.jar"
Dim WrapperPath As String = PathPure & "JavaWrapper.jar"
Log("[Java] 选定的 Java Wrapper 路径:" & WrapperPath)
SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突
WriteFile(WrapperPath, GetResources("JavaWrapper"))
Try
WriteFile(WrapperPath, GetResources("JavaWrapper"))
Catch ex As Exception
If File.Exists(WrapperPath) Then
'因为未知原因 Java Wrapper 可能变为只读文件(#4243)
Log(ex, "Java Wrapper 文件释放失败,但文件已存在,将在删除后尝试重新生成", LogLevel.Developer)
Try
File.Delete(WrapperPath)
WriteFile(WrapperPath, GetResources("JavaWrapper"))
Catch ex2 As Exception
Log(ex2, "Java Wrapper 文件重新释放失败,将尝试更换文件名重新生成", LogLevel.Developer)
WrapperPath = PathPure & "JavaWrapper2.jar"
Try
WriteFile(WrapperPath, GetResources("JavaWrapper"))
Catch ex3 As Exception
Throw New FileNotFoundException("释放 Java Wrapper 最终尝试失败", ex3)
End Try
End Try
Else
Throw New FileNotFoundException("释放 Java Wrapper 失败", ex)
End If
End Try
End SyncLock
Log("[Java] 已释放 Java Wrapper:" & WrapperPath)
Return WrapperPath
End Function
Private ExtractJavaWrapperLock As New Object
''' <summary>
''' 获取 Java Wrapper 所在的文件夹,不以 \ 结尾。
''' </summary>
Public Function GetJavaWrapperDir() As String
If PathAppdata.IsASCII() Then
Return PathAppdata.TrimEnd("\")
ElseIf PathTemp.IsASCII() Then
Log("[Java] Wrapper:AppData 路径中包含非 ASCII 字符,换用 Temp 目录")
Return PathTemp.TrimEnd("\")
Else
Log("[Java] Wrapper:AppData 路径与 Temp 路径中均包含非 ASCII 字符,换用 ProgramData 目录")
Return OsDrive & "ProgramData\PCL"
End If
End Function
'主方法,合并 Jvm、Game、Replace 三部分的参数数据
Private Sub McLaunchArgumentMain(Loader As LoaderTask(Of String, List(Of McLibToken)))
@@ -1339,8 +1344,12 @@ SystemBrowser:
Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
'全屏
If Setup.Get("LaunchArgumentWindowType") = 0 Then Arguments += " --fullscreen"
'由 Option 传入的额外参数
For Each Arg In CurrentLaunchOptions.ExtraArgs
Arguments += " " & Arg.Trim
Next
'进服
Dim Server As String = If(String.IsNullOrEmpty(McLaunchLoader.Input.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), McLaunchLoader.Input.ServerIp)
Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp)
If Server.Length > 0 Then
If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then
'QuickPlay
@@ -1394,7 +1403,7 @@ SystemBrowser:
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
Try
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
DataList.Insert(0, "-javaagent:""" & PathAppdata & "authlib-injector.jar""=" & Server &
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
Catch ex As Exception
@@ -1404,7 +1413,7 @@ SystemBrowser:
'添加 Java Wrapper 作为主 Jar
If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
DataList.Add("-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
DataList.Add("-Doolloo.jlw.tmpdir=""" & PathPure.TrimEnd("\") & """")
DataList.Add("-jar """ & ExtractJavaWrapper() & """")
'添加 MainClass
@@ -1461,7 +1470,7 @@ NextVersion:
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
Try
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
DataList.Insert(0, "-javaagent:""" & PathAppdata & "authlib-injector.jar""=" & Server &
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
Catch ex As Exception
@@ -1471,7 +1480,7 @@ NextVersion:
'添加 Java Wrapper 作为主 Jar
If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
DataList.Add("-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
DataList.Add("-Doolloo.jlw.tmpdir=""" & PathPure.TrimEnd("\") & """")
DataList.Add("-jar """ & ExtractJavaWrapper() & """")
'将 "-XXX" 与后面 "XXX" 合并到一起
@@ -1646,8 +1655,11 @@ NextVersion:
GameSize = New Size(875 - 2, 540 - 2)
End Select
GameSize.Height -= 29.5 * DPI / 96 '标题栏高度
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso McLaunchJavaSelected.VersionCode <= 8 AndAlso
Not McVersionCurrent.Version.HasOptiFine AndAlso Not McVersionCurrent.Version.HasForge Then '修复 #3463:1.12.2-,JRE 8 下窗口大小为设置大小的 DPI% 倍
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso
McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso
Not McVersionCurrent.Version.HasOptiFine AndAlso Not McVersionCurrent.Version.HasForge Then
'修复 #3463:1.12.2-,JRE 8u200~321 下窗口大小为设置大小的 DPI% 倍
McLaunchLog($"已应用窗口大小过大修复({McLaunchJavaSelected.Version.Revision})")
GameSize.Width /= DPI / 96
GameSize.Height /= DPI / 96
End If
@@ -1770,7 +1782,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1801,7 +1812,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1877,16 +1887,12 @@ NextVersion:
End Try
'离线皮肤 Alex 警告
Try
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.7 ~ 1.2
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.2 ~ 1.7
McLoginLoader.Input.Type = McLoginType.Legacy AndAlso '离线登录
(Setup.Get("LaunchSkinType") = 2 OrElse '强制 Alex
(Setup.Get("LaunchSkinType") = 4 AndAlso Setup.Get("LaunchSkinSlim"))) Then '或选用 Alex 皮肤
Hint("此 Minecraft 版本尚不支持 Alex 皮肤,你的皮肤可能会显示为 Steve!", HintType.Critical)
End If
Catch ex As Exception
Log(ex, "检查离线皮肤失效失败")
End Try
Hint("此 Minecraft 版本尚不支持 Alex 皮肤,你的皮肤可能会显示为 Steve!", HintType.Critical)
End If
'离线皮肤资源包
Try
@@ -2046,18 +2052,18 @@ IgnoreCustomSkin:
"""" & McLaunchJavaSelected.PathJava & """ " & McLaunchArgument & vbCrLf &
"echo 游戏已退出。" & vbCrLf &
"pause"
WriteFile(If(McLaunchLoader.Input.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"),
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"),
Encoding:=If(Encoding.Default.Equals(Encoding.UTF8), Encoding.UTF8, Encoding.GetEncoding("GB18030")))
If McLaunchLoader.Input.SaveBatch IsNot Nothing Then
If CurrentLaunchOptions.SaveBatch IsNot Nothing Then
McLaunchLog("导出启动脚本完成,强制结束启动过程")
AbortHint = "导出启动脚本成功!"
OpenExplorer("/select,""" & McLaunchLoader.Input.SaveBatch & """")
OpenExplorer("/select,""" & CurrentLaunchOptions.SaveBatch & """")
Loader.Parent.Abort()
Exit Sub '导出脚本完成
End If
Catch ex As Exception
Log(ex, "输出启动脚本失败")
If McLaunchLoader.Input.SaveBatch IsNot Nothing Then Throw ex '直接触发启动失败
If CurrentLaunchOptions.SaveBatch IsNot Nothing Then Throw ex '直接触发启动失败
End Try
'执行自定义命令
@@ -2128,6 +2134,8 @@ IgnoreCustomSkin:
StartInfo.EnvironmentVariables("Path") = Join(Paths.Distinct.ToList, ";")
'设置其他参数
StartInfo.StandardErrorEncoding = Encoding.UTF8
StartInfo.StandardOutputEncoding = Encoding.UTF8
StartInfo.WorkingDirectory = McVersionCurrent.PathIndie
StartInfo.UseShellExecute = False
StartInfo.RedirectStandardOutput = True
@@ -85,7 +85,7 @@ Public Module ModMinecraft
Next
If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = Name, .Path = Path, .Type = McFolderType.Custom})
Else
Hint("无效的 Minecraft 文件夹:" & Path, HintType.Critical)
Hint("无法访问 Minecraft 文件夹:" & Path, HintType.Critical)
End If
Next
@@ -475,22 +475,27 @@ VersionSearchFinish:
''' </summary>
Public Property JsonText As String
Get
'快速检查 JSON 是否以 { 开头、} 结尾;忽略空白字符
Dim FastJsonCheck =
Function(Json As String) As Boolean
Dim TrimedJson As String = Json.Trim()
Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}")
End Function
If _JsonText Is Nothing Then
If Not File.Exists(Path & Name & ".json") Then Throw New Exception("未找到版本 json 文件:" & Path & Name & ".json")
If Not File.Exists(Path & Name & ".json") Then Throw New Exception($"未找到版本 JSON 文件:{Path}{Name}.json")
_JsonText = ReadFile(Path & Name & ".json")
'如果 ReadFile 失败会返回空字符串;这可能是由于文件被临时占用,故延时后重试
If _JsonText.Length = 0 Then
If Not FastJsonCheck(_JsonText) Then
If RunInUi() Then
Log("[Minecraft] 版本 json 文件为空或读取失败,由于代码在主线程运行,将不再进行重试", LogLevel.Debug)
Throw New Exception("版本 Json 文件为空或读取失败")
Log("[Minecraft] 版本 JSON 文件为空或有误,由于代码在主线程运行,将不再进行重试", LogLevel.Debug)
GetJson(_JsonText) '触发异常
Else
Log("[Minecraft] 版本 json 文件为空或读取失败,将在 2s 后重试读取(" & Path & Name & ".json)", LogLevel.Debug)
Log("[Minecraft] 版本 JSON 文件为空或有误,将在 2s 后重试读取(" & Path & Name & ".json)", LogLevel.Debug)
Thread.Sleep(2000)
_JsonText = ReadFile(Path & Name & ".json")
If _JsonText.Length = 0 Then Throw New Exception("版本 json 文件为空或读取失败")
If Not FastJsonCheck(_JsonText) Then GetJson(_JsonText) '触发异常
End If
End If
If _JsonText.Length < 100 Then Throw New Exception("版本 json 文件有误,内容为:" & _JsonText)
End If
Return _JsonText
End Get
@@ -562,10 +567,10 @@ Recheck:
GoTo Recheck
End If
Catch ex As Exception
Log(ex, "合并版本依赖项 json 失败(" & If(InheritVersion, "null").ToString & ")")
Log(ex, "合并版本依赖项 JSON 失败(" & If(InheritVersion, "null").ToString & ")")
End Try
Catch ex As Exception
Throw New Exception("版本 json 不规范(" & If(Name, "null") & ")", ex)
Throw New Exception("初始化版本 JSON 时失败(" & If(Name, "null") & ")", ex)
End Try
Try
'处理 JumpLoader
@@ -665,7 +670,7 @@ Recheck:
Try
Dim JsonObjCheck = JsonObject
Catch ex As Exception
Log(ex, "版本 json 可用性检查失败(" & Path & ")")
Log(ex, "版本 JSON 可用性检查失败(" & Path & ")")
JsonText = ""
JsonObject = Nothing
Info = ex.Message
@@ -1029,21 +1034,21 @@ ExitDataLoad:
Public Function GetMcFoolName(Name As String) As String
Name = Name.ToLower
If Name.StartsWithF("2.0") Then
Return "这个秘密计划了两年的更新将游戏推向了一个新高度!"
ElseIf Name.StartsWithF("20w14inf") OrElse Name = "20w14∞" Then
Return "我们加入了 20 亿个新的维度,让无限的想象变成了现实!"
Return "2013 | 这个秘密计划了两年的更新将游戏推向了一个新高度!"
ElseIf Name = "15w14a" Then
Return "作为一款全年龄向的游戏,我们需要和平,需要爱与拥抱。"
Return "2015 | 作为一款全年龄向的游戏,我们需要和平,需要爱与拥抱。"
ElseIf Name = "1.rv-pre1" Then
Return "是时候将现代科技带入 Minecraft 了!"
Return "2016 | 是时候将现代科技带入 Minecraft 了!"
ElseIf Name = "3d shareware v1.34" Then
Return "我们从地下室的废墟里找到了这个开发于 1994 年的杰作!"
Return "2019 | 我们从地下室的废墟里找到了这个开发于 1994 年的杰作!"
ElseIf Name.StartsWithF("20w14inf") OrElse Name = "20w14∞" Then
Return "2020 | 我们加入了 20 亿个新的维度,让无限的想象变成了现实!"
ElseIf Name = "22w13oneblockatatime" Then
Return "一次一个方块更新!迎接全新的挖掘、合成与骑乘玩法吧!"
Return "2022 | 一次一个方块更新!迎接全新的挖掘、合成与骑乘玩法吧!"
ElseIf Name = "23w13a_or_b" Then
Return "研究表明:玩家喜欢作出选择——越多越好!"
Return "2023 | 研究表明:玩家喜欢作出选择——越多越好!"
ElseIf Name = "24w14potato" Then
Return "毒马铃薯一直都被大家忽视和低估,于是我们超级加强了它!"
Return "2024 | 毒马铃薯一直都被大家忽视和低估,于是我们超级加强了它!"
Else
Return ""
End If
@@ -1251,9 +1256,8 @@ OnLoaded:
Dim VersionList As New List(Of McVersion)
#Region "循环加载每个版本的信息"
Dim Dirs As DirectoryInfo() = New DirectoryInfo(Path & "versions").GetDirectories
For Each Folder As DirectoryInfo In Dirs
If Not Folder.EnumerateFiles.Any Then
For Each Folder As DirectoryInfo In New DirectoryInfo(Path & "versions").GetDirectories
If Not Folder.Exists OrElse Not Folder.EnumerateFiles.Any Then
Log("[Minecraft] 跳过空文件夹:" & Folder.FullName)
Continue For
End If
@@ -1287,8 +1291,11 @@ OnLoaded:
'单独列出收藏的版本
Dim StaredVersions As New List(Of McVersion)
For Each Version As McVersion In VersionList
If Version.IsStar AndAlso Not Version.DisplayType = McVersionCardType.Hidden Then StaredVersions.Add(Version)
For Each Version As McVersion In VersionList.ToList
If Version.IsStar AndAlso Not Version.DisplayType = McVersionCardType.Hidden Then
StaredVersions.Add(Version)
VersionList.Remove(Version)
End If
Next
If StaredVersions.Any Then VersionListOriginal.Add(McVersionCardType.Star, StaredVersions)
@@ -1523,7 +1530,7 @@ OnLoaded:
''' 要求玩家选择一个皮肤文件,并进行相关校验。
''' </summary>
Public Function McSkinSelect() As McSkinInfo
Dim FileName As String = SelectFile("皮肤文件(*.png)|*.png", "选择皮肤文件")
Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.webp)|*.png;*.jpg;*.webp", "选择皮肤文件")
'验证有效性
If FileName = "" Then Return New McSkinInfo With {.IsVaild = False}
@@ -1930,7 +1937,7 @@ OnLoaded:
''' <summary>
''' 获取版本缺失的支持库文件所对应的 NetTaskFile。
''' </summary>
Public Function McLibFix(Version As McVersion, Optional CoreJarOnly As Boolean = False) As List(Of NetFile)
Public Function McLibFix(Version As McVersion) As List(Of NetFile)
If Not Version.IsLoaded Then Version.Load() '确保例如 JumpLoader 等项被合并入 Json
Dim Result As New List(Of NetFile)
@@ -1943,91 +1950,99 @@ OnLoaded:
Catch ex As Exception
Log(ex, "版本缺失主 jar 文件所必须的信息", LogLevel.Developer)
End Try
If CoreJarOnly Then Return Result
'是否跳过校验
Dim IsSetupSkip As Boolean = ShouldIgnoreFileCheck(Version)
'Library 文件
Result.AddRange(McLibFixFromLibToken(McLibListGet(Version, False), JumpLoaderFolder:=Version.PathIndie & ".jumploader\", AllowUnsameFile:=IsSetupSkip))
Result.AddRange(McLibFixFromLibToken(McLibListGet(Version, False), JumpLoaderFolder:=Version.PathIndie & ".jumploader\"))
'统一通行证文件
If Setup.Get("VersionServerLogin", Version:=Version) = 3 Then
Dim TargetFile = PathAppdata & "nide8auth.jar"
If Not (IsSetupSkip AndAlso File.Exists(TargetFile)) Then
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取统一通行证下载信息")
'测试链接:https://auth.mc-user.com:233/00000000000000000000000000000000/
DownloadInfo = GetJson(NetGetCodeByDownload({
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取统一通行证下载信息")
'测试链接:https://auth.mc-user.com:233/00000000000000000000000000000000/
DownloadInfo = GetJson(NetGetCodeByDownload({
"https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取统一通行证下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("jarHash").ToString)
If (IsSetupSkip AndAlso File.Exists(TargetFile)) OrElse Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Log("[Minecraft] 统一通行证需要更新:Hash - " & Checker.Hash, LogLevel.Developer)
Result.Add(New NetFile({"https://login.mc-user.com:233/index/jar"}, TargetFile, Checker))
End If
Catch ex As Exception
Log(ex, "获取统一通行证下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("jarHash").ToString)
If Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Log("[Minecraft] 统一通行证需要更新:Hash - " & Checker.Hash, LogLevel.Developer)
Result.Add(New NetFile({"https://login.mc-user.com:233/index/jar"}, TargetFile, Checker))
End If
End If
End If
'Authlib-Injector 文件
If Setup.Get("VersionServerLogin", Version:=Version) = 4 OrElse
(PageLinkHiper.HiperState = LoadState.Finished AndAlso Setup.Get("LoginType") = McLoginType.Legacy) Then 'HiPer 登录转接
Dim TargetFile = PathAppdata & "authlib-injector.jar"
If Not (IsSetupSkip AndAlso File.Exists(TargetFile)) Then
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByDownload({"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)
If (IsSetupSkip AndAlso File.Exists(TargetFile)) OrElse Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Dim DownloadAddress As String = DownloadInfo("download_url")
Log("[Minecraft] Authlib-Injector 需要更新:" & DownloadAddress, LogLevel.Developer)
Result.Add(New NetFile({DownloadAddress}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
End If
If Setup.Get("VersionServerLogin", Version:=Version) = 4 Then
Dim TargetFile = PathPure & "\authlib-injector.jar"
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByDownload({
"https://authlib-injector.yushi.moe/artifact/latest.json",
"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"
}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)
If Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Dim DownloadAddress As String = DownloadInfo("download_url").ToString.
Replace("bmclapi2.bangbang93.com/mirrors/authlib-injector", "authlib-injector.yushi.moe")
Log("[Minecraft] Authlib-Injector 需要更新:" & DownloadAddress, LogLevel.Developer)
Result.Add(New NetFile({
DownloadAddress,
DownloadAddress.Replace("authlib-injector.yushi.moe", "bmclapi2.bangbang93.com/mirrors/authlib-injector")
}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
End If
End If
End If
'跳过校验
If ShouldIgnoreFileCheck(Version) Then
Log("[Minecraft] 用户要求尽量忽略文件检查,这可能会保留有误的文件")
Result = Result.Where(
Function(f)
If File.Exists(f.LocalPath) Then
Log("[Minecraft] 跳过下载的支持库文件:" & f.LocalPath, LogLevel.Debug)
Return False
Else
Return True
End If
End Function).ToList
End If
Return Result
End Function
''' <summary>
''' 将 McLibToken 列表转换为 NetFile。无需下载的文件会被自动过滤。
''' </summary>
Public Function McLibFixFromLibToken(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing, Optional JumpLoaderFolder As String = Nothing, Optional AllowUnsameFile As Boolean = False) As List(Of NetFile)
Public Function McLibFixFromLibToken(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing, Optional JumpLoaderFolder As String = Nothing) As List(Of NetFile)
CustomMcFolder = If(CustomMcFolder, PathMcFolder)
Dim Result As New List(Of NetFile)
'获取
For Each Token As McLibToken In Libs
'检查文件
Dim Checker As FileChecker
If AllowUnsameFile Then '只要文件存在则通过检查,用于放宽完整性校验的情况
Checker = New FileChecker(MinSize:=1)
Else
Checker = New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
End If
Dim Checker As New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
If Checker.Check(Token.LocalPath) Is Nothing Then Continue For
'文件不符合,添加下载
Dim Urls As New List(Of String)
If Token.Url IsNot Nothing Then
'获取 Url 的真实地址
Urls.Add(Token.Url)
If Token.Url.Contains("launcher.mojang.com/v1/objects") Then
Urls = DlSourceLauncherOrMetaGet(Token.Url).ToList() 'Mappings
If Token.Url.Contains("launcher.mojang.com/v1/objects") OrElse Token.Url.Contains("client.txt") OrElse
Token.Url.Contains(".tsrg") Then
Urls.AddRange(DlSourceLauncherOrMetaGet(Token.Url).ToList()) 'Mappings(#4425)
End If
If Token.Url.Contains("maven") Then
Urls.Insert(0, Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOfF("maven")), "https://bmclapi2.bangbang93.com/").
@@ -2049,7 +2064,7 @@ OnLoaded:
'普通文件
Urls.AddRange(DlSourceLibraryGet("https://libraries.minecraft.net" & Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries", "").Replace("\", "/")))
End If
Result.Add(New NetFile(Urls.Distinct.ToArray, Token.LocalPath, Checker))
Result.Add(New NetFile(Urls.Distinct, Token.LocalPath, Checker))
Next
'去重并返回
Return Result.Distinct(Function(a, b) a.LocalPath = b.LocalPath)
@@ -2157,77 +2172,50 @@ OnLoaded:
''' </summary>
Public Size As Long
''' <summary>
''' 是否为 Virtual 资源文件。
''' </summary>
Public IsVirtual As Boolean
''' <summary>
''' 文件的 Hash 校验码。
''' </summary>
Public Hash As String
Public Overrides Function ToString() As String
Return If(IsVirtual, "[Virtual] ", "") & GetString(Size) & " | " & LocalPath
Return GetString(Size) & " | " & LocalPath
End Function
End Structure
''' <summary>
''' 获取 Minecraft 的资源文件列表。失败会抛出异常。
''' </summary>
''' <param name="Name">版本的资源名称,如“1.13.1”。</param>
Private Function McAssetsListGet(Name As String) As List(Of McAssetsToken)
Private Function McAssetsListGet(Version As McVersion) As List(Of McAssetsToken)
Dim IndexName = McAssetsGetIndexName(Version)
Try
'初始化
If Not File.Exists(PathMcFolder & "assets\indexes\" & Name & ".json") Then Throw New FileNotFoundException("Assets 索引文件未找到", PathMcFolder & "assets\indexes\" & Name & ".json")
McAssetsListGet = New List(Of McAssetsToken)
Dim Json = GetJson(ReadFile(PathMcFolder & "assets\indexes\" & Name & ".json"))
If Not File.Exists($"{PathMcFolder}assets\indexes\{IndexName}.json") Then Throw New FileNotFoundException("未找到 Asset Index", PathMcFolder & "assets\indexes\" & IndexName & ".json")
Dim Result As New List(Of McAssetsToken)
Dim Json As JObject = GetJson(ReadFile($"{PathMcFolder}assets\indexes\{IndexName}.json"))
'确认 Virtual 与 Map 状态
Dim IsVirtual As Boolean = False
If Json("virtual") IsNot Nothing AndAlso Json("virtual").ToString Then IsVirtual = True
If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToString Then
IsVirtual = True
'刷新 resources 文件夹符号链接(#2182)
'Dim Info As FileSystemInfo = New FileInfo(PathMcFolder & "resources\pack.mcmeta")
'If Info.Attributes.HasFlag(FileAttributes.ReparsePoint) Then
If Not File.Exists(PathMcFolder & "resources\pack.mcmeta") Then
Log("[Minecraft] 尝试刷新 resources 文件夹符号链接", LogLevel.Debug)
Try
DeleteDirectory(PathMcFolder & "resources\", True)
Directory.CreateDirectory(PathMcFolder & "assets\virtual\legacy\")
Dim Result = ShellAndGetOutput("cmd", $"/C mklink /D /J ""{PathMcFolder}resources"" ""{PathMcFolder}assets\virtual\legacy""")
Log($"[Minecraft] 符号链接创建结果:{Result}")
If Not Result.Contains("<<===>>") Then Throw New Exception($"非预期的结果({Result})")
Catch ex As Exception
Log(ex, "创建资源文件夹链接失败,游戏可能会没有声音", LogLevel.Msgbox)
End Try
'读取列表
For Each File As JProperty In Json("objects").Children
Dim LocalPath As String
If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToObject(Of Boolean) Then
'Remap
LocalPath = Version.PathIndie & "resources\" & File.Name.Replace("/", "\")
ElseIf Json("virtual") IsNot Nothing AndAlso Json("virtual").ToObject(Of Boolean) Then
'Virtual
LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\")
Else
'正常
LocalPath = PathMcFolder & "assets\objects\" & Left(File.Value("hash").ToString, 2) & "\" & File.Value("hash").ToString
End If
End If
'加载列表
If IsVirtual Then
For Each File As JProperty In Json("objects").Children
McAssetsListGet.Add(New McAssetsToken With {
.IsVirtual = True,
.LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\"),
.SourcePath = File.Name,
.Hash = File.Value("hash").ToString,
.Size = File.Value("size").ToString
})
Next
Else
For Each File As JProperty In Json("objects").Children
McAssetsListGet.Add(New McAssetsToken With {
.IsVirtual = False,
.LocalPath = PathMcFolder & "assets\objects\" & Left(File.Value("hash").ToString, 2) & "\" & File.Value("hash").ToString,
.SourcePath = File.Name,
.Hash = File.Value("hash").ToString,
.Size = File.Value("size").ToString
})
Next
End If
Result.Add(New McAssetsToken With {
.LocalPath = LocalPath,
.SourcePath = File.Name,
.Hash = File.Value("hash").ToString,
.Size = File.Value("size").ToString
})
Next
Return Result
Catch ex As Exception
Log(ex, "获取资源文件列表失败:" & Name)
Log(ex, "获取资源文件列表失败:" & IndexName)
Throw
End Try
End Function
@@ -2236,12 +2224,12 @@ OnLoaded:
''' <summary>
''' 获取版本缺失的资源文件所对应的 NetTaskFile。
''' </summary>
Public Function McAssetsFixList(IndexAddress As String, CheckHash As Boolean, Optional ByRef ProgressFeed As LoaderBase = Nothing) As List(Of NetFile)
Public Function McAssetsFixList(Version As McVersion, CheckHash As Boolean, Optional ByRef ProgressFeed As LoaderBase = Nothing) As List(Of NetFile)
Dim Result As New List(Of NetFile)
Dim AssetsList As List(Of McAssetsToken)
Try
AssetsList = McAssetsListGet(IndexAddress)
AssetsList = McAssetsListGet(Version)
Dim Token As McAssetsToken
If ProgressFeed IsNot Nothing Then ProgressFeed.Progress = 0.04
For i = 0 To AssetsList.Count - 1
@@ -2320,8 +2308,8 @@ OnLoaded:
End If
Left = Left.ToLowerInvariant
Right = Right.ToLowerInvariant
Dim Lefts = RegexSearch(Left.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Dim Rights = RegexSearch(Right.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Dim Lefts = RegexSearch(Left.Replace("快照", "snapshot").Replace("预览版", "pre"), "[a-z]+|[0-9]+")
Dim Rights = RegexSearch(Right.Replace("快照", "snapshot").Replace("预览版", "pre"), "[a-z]+|[0-9]+")
Dim i As Integer = 0
While True
'两边均缺失,感觉是一个东西
@@ -2370,15 +2358,11 @@ NextEntry:
''' <summary>
''' 比较两个版本名的排序器。
''' </summary>
Public Class VersionSorter
Public Class VersionComparer
Implements IComparer(Of String)
Public IsDecreased As Boolean = True
Public Function Compare(x As String, y As String) As Integer Implements IComparer(Of String).Compare
Return VersionSortInteger(x, y) * If(IsDecreased, -1, 1)
Return VersionSortInteger(x, y)
End Function
Public Sub New(Optional IsDecreased As Boolean = True)
Me.IsDecreased = IsDecreased
End Sub
End Class
''' <summary>
@@ -1,6 +1,7 @@
Imports System.IO.Compression
Public Module ModMod
Private Const LocalModCacheVersion As Integer = 7
Public Class McMod
@@ -47,7 +48,7 @@ Public Module ModMod
Get
Load()
If Not IsFileAvailable Then
Return McModState.Unavaliable
Return McModState.Unavailable
ElseIf Path.EndsWithF(".disabled", True) OrElse Path.EndsWithF(".old", True) Then
Return McModState.Disabled
Else
@@ -58,7 +59,7 @@ Public Module ModMod
Public Enum McModState As Integer
Fine = 0
Disabled = 1
Unavaliable = 2
Unavailable = 2
End Enum
#End Region
@@ -687,7 +688,7 @@ Finished:
''' </summary>
Public ReadOnly Property CanUpdate As Boolean
Get
Return ChangelogUrls.Any()
Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso ChangelogUrls.Any()
End Get
End Property
@@ -701,13 +702,13 @@ Finished:
Dim Info As New FileInfo(Path)
Dim CacheKey As String = GetHash($"{RawPath}-{Info.LastWriteTime.ToLongTimeString}-{Info.Length}-C")
Dim Cached As String = ReadIni(PathTemp & "Cache\ModHash.ini", CacheKey)
If Cached <> "" Then
If Cached <> "" AndAlso RegexCheck(Cached, "^\d+$") Then '#5062
_CurseForgeHash = Cached
Return _CurseForgeHash
End If
'读取文件
Dim data As New List(Of Byte)
For Each b As Byte In File.ReadAllBytes(Path)
For Each b As Byte In ReadFileBytes(Path)
If b = 9 OrElse b = 10 OrElse b = 13 OrElse b = 32 Then Continue For
data.Add(b)
Next
@@ -814,7 +815,7 @@ Finished:
'等待 Mod 更新完成
If PageVersionMod.UpdatingVersions.Contains(Loader.Input) Then
Log($"[Mod] 等待 Mod 更新完成后才能继续加载 Mod 列表")
Log($"[Mod] 等待 Mod 更新完成后才能继续加载 Mod 列表:" & Loader.Input)
Try
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod")
Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input)
@@ -824,6 +825,7 @@ Finished:
Finally
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在加载 Mod 列表")
End Try
FrmVersionMod.LoaderRun(LoaderFolderRunType.UpdateOnly)
End If
'获取 Mod 文件夹下的可用文件列表
@@ -852,7 +854,7 @@ Finished:
Dim Cache As New JObject
Try
Dim CacheContent As String = ReadFile(CachePath)
If CacheContent <> "" Then
If Not String.IsNullOrWhiteSpace(CacheContent) Then
Cache = GetJson(CacheContent)
If Not Cache.ContainsKey("version") OrElse Cache("version").ToObject(Of Integer) <> LocalModCacheVersion Then
Log($"[Mod] 本地 Mod 信息缓存版本已过期,将弃用这些缓存信息", LogLevel.Debug)
@@ -861,6 +863,7 @@ Finished:
End If
Catch ex As Exception
Log(ex, "读取本地 Mod 信息缓存失败,已重置")
Cache = New JObject
End Try
Cache("version") = LocalModCacheVersion
@@ -886,7 +889,7 @@ Finished:
End If
ModList.Add(ModEntry)
'读取 Comp 缓存
If ModEntry.State = McMod.McModState.Unavaliable Then Continue For
If ModEntry.State = McMod.McModState.Unavailable Then Continue For
Dim CacheKey = ModEntry.ModrinthHash & PageVersionLeft.Version.Version.McName & GetTargetModLoaders().Join("")
If Cache.ContainsKey(CacheKey) Then
ModEntry.FromJson(Cache(CacheKey))
@@ -901,8 +904,8 @@ Finished:
'排序
ModList = Sort(ModList,
Function(Left As McMod, Right As McMod) As Boolean
If (Left.State = McMod.McModState.Unavaliable) <> (Right.State = McMod.McModState.Unavaliable) Then
Return Left.State = McMod.McModState.Unavaliable
If (Left.State = McMod.McModState.Unavailable) <> (Right.State = McMod.McModState.Unavailable) Then
Return Left.State = McMod.McModState.Unavailable
Else
Return Not Right.FileName.CompareTo(Left.FileName)
End If
@@ -924,7 +927,6 @@ Finished:
End Try
End Sub
'联网加载 Mod 详情
Private Const LocalModCacheVersion As Integer = 5
Public McModDetailLoader As New LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer)("Mod List Detail Loader", AddressOf McModDetailLoad)
Private Sub McModDetailLoad(Loader As LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer))
Dim Mods As List(Of McMod) = Loader.Input.Key
@@ -944,7 +946,7 @@ Finished:
'McVersions = McVersions.Distinct().ToList()
'开始网络获取
Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersion}")
Dim EndedThreadCount As Integer = 0, SucceedThreadCount As Integer = 0
Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False
Dim MainThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息
RunInNewThread(
@@ -952,7 +954,7 @@ Finished:
Try
'步骤 1:获取 Hash 与对应的工程 ID
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
Dim ModrinthVersion = CType(GetJson(NetRequestRetry("https://api.modrinth.com/v2/version_files", "POST",
Dim ModrinthVersion = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files", "POST",
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject)
Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 Mod 的对应关系
@@ -973,19 +975,18 @@ Finished:
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息
If Not ModrinthMapping.Any() Then Exit Sub
Dim ModrinthProject = CType(GetJson(NetRequestRetry(
Dim ModrinthProject = CType(GetJson(DlModRequest(
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]",
"GET", "", "application/json")), JArray)
For Each ProjectJson In ModrinthProject
Dim Project As New CompProject(ProjectJson)
For Each Entry In ModrinthMapping(Project.Id)
If Entry.Comp IsNot Nothing AndAlso Entry.Comp.FromCurseForge Then Project.LogoUrl = Entry.Comp.LogoUrl 'Modrinth 的部分 Logo 不是图片,如果可能,使用 CurseForge 的 Logo
Entry.Comp = Project
Next
Next
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息,继续获取更新信息")
'步骤 4:获取更新信息
Dim ModrinthUpdate = CType(GetJson(NetRequestRetry("https://api.modrinth.com/v2/version_files/update", "POST",
Dim ModrinthUpdate = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files/update", "POST",
$"{{""hashes"": [""{ModrinthMapping.SelectMany(Function(l) l.Value.Select(Function(m) m.ModrinthHash)).Join(""",""")}""], ""algorithm"": ""sha1"",
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")), JObject)
For Each Entry In Mods
@@ -1005,9 +1006,9 @@ Finished:
End If
Next
Log($"[Mod] 从 Modrinth 获取本地 Mod 信息结束")
SucceedThreadCount += 1
Catch ex As Exception
Log(ex, "从 Modrinth 获取本地 Mod 信息失败")
IsFailed = True
Finally
EndedThreadCount += 1
End Try
@@ -1022,8 +1023,8 @@ Finished:
CurseForgeHashes.Add(Entry.CurseForgeHash)
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Next
Dim CurseForgeRaw = CType(CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/fingerprints/432/", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 Mod 的对应关系
If Not CurseForgeRaw.Any() Then Exit Sub
@@ -1045,17 +1046,16 @@ Finished:
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息
If Not CurseForgeMapping.Any() Then Exit Sub
Dim CurseForgeProject = CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods", "POST",
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST",
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject
If Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
If ProjectJson("isAvailable") IsNot Nothing AndAlso Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
'设置 Entry 中的工程信息
Dim Project As New CompProject(ProjectJson)
For Each Entry In CurseForgeMapping(Project.Id) '倒查防止 CurseForge 返回的内容有漏
If Entry.Comp IsNot Nothing AndAlso Not Entry.Comp.FromCurseForge Then
Entry.Comp.LogoUrl = Project.LogoUrl 'Modrinth 部分 Logo 加载不出来
Entry.Comp = Entry.Comp '再次触发修改事件
Continue For
End If
@@ -1066,9 +1066,9 @@ Finished:
Dim NewestVersion As String = Nothing
Dim NewestFileIds As New List(Of Integer)
For Each IndexEntry In ProjectJson("latestFilesIndexes")
If ModLoaders.Single <> IndexEntry("modLoader")?.ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
If IndexEntry("modLoader") Is Nothing OrElse ModLoaders.Single <> IndexEntry("modLoader").ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
Dim IndexVersion As String = IndexEntry("gameVersion")
If McVersion <> IndexVersion Then Continue For 'MC 版本匹配
If IndexVersion <> McVersion Then Continue For 'MC 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的,所以只需取第一个;如果需要检查多个 releaseType 下的文件,将 > -1 改为 = 1,但这应当并不会获取到更新的文件
If NewestVersion IsNot Nothing AndAlso VersionSortInteger(NewestVersion, IndexVersion) > -1 Then Continue For '只保留最新 MC 版本
If NewestVersion <> IndexVersion Then
@@ -1087,7 +1087,7 @@ Finished:
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息,需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
'步骤 4:获取更新文件信息
If Not UpdateFileIds.Any() Then Exit Sub
Dim CurseForgeFiles = CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST",
Dim CurseForgeFiles = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST",
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data")
Dim UpdateFiles As New Dictionary(Of McMod, CompFile)
For Each FileJson In CurseForgeFiles
@@ -1113,9 +1113,9 @@ Finished:
End If
Next
Log($"[Mod] 从 CurseForge 获取 Mod 更新信息结束")
SucceedThreadCount += 1
Catch ex As Exception
Log(ex, "从 CurseForge 获取本地 Mod 信息失败")
IsFailed = True
Finally
EndedThreadCount += 1
End Try
@@ -1129,11 +1129,13 @@ Finished:
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
Log($"[Mod] 联网获取本地 Mod 信息完成,为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Exit Sub
For Each Entry In Mods 'TODO: Bookshelf 的 Logo 会在两个网站间横跳
Entry.CompLoaded = SucceedThreadCount = 2
For Each Entry In Mods
Entry.CompLoaded = Not IsFailed
Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
Next
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
'刷新边栏
RunInUi(Sub() FrmVersionMod?.RefreshBars())
End Sub
Public Function GetTargetModLoaders() As List(Of CompModLoaderType)
Dim ModLoaders As New List(Of CompModLoaderType)
@@ -1275,4 +1277,4 @@ Finished:
End Function
#End If
End Module
End Module
@@ -1,4 +1,5 @@
Imports System.IO.Compression
Imports System.Linq.Expressions
Public Module ModModpack
@@ -10,12 +11,22 @@ Public Module ModModpack
Public Sub ModpackInstall()
Dim File As String = SelectFile("整合包文件(*.rar;*.zip;*.mrpack)|*.rar;*.zip;*.mrpack", "选择整合包压缩文件") '选择整合包文件
If String.IsNullOrEmpty(File) Then Exit Sub
RunInThread(Sub() ModpackInstall(File))
RunInThread(
Sub()
Try
ModpackInstall(File)
Catch ex As CancelledException
Catch ex As Exception
Log(ex, "手动安装整合包失败", LogLevel.Msgbox)
End Try
End Sub)
End Sub
''' <summary>
''' 安装一个给定的整合包文件,返回是否安装成功。必须在工作线程执行。
''' 构建并启动安装给定的整合包文件的加载器,并返回该加载器。若失败则抛出异常。
''' 必须在工作线程执行。
''' </summary>
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True, Optional Logo As String = Nothing) As Boolean
''' <exception cref="CancelledException" />
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
Log("[ModPack] 整合包安装请求:" & If(File, "null"))
Dim Archive As ZipArchive = Nothing
Dim ArchiveBaseFolder As String = ""
@@ -23,9 +34,10 @@ Public Module ModModpack
'获取整合包种类与关键 Json
Dim PackType As Integer = -1
Try
Archive = New ZipArchive(New FileStream(File, FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
Archive = New ZipArchive(New FileStream(File, FileMode.Open, FileAccess.Read, FileShare.Read))
'从根目录判断整合包类型
If Archive.GetEntry("mcbbs.packmeta") IsNot Nothing Then PackType = 3 : Exit Try 'MCBBS 整合包(优先于 manifest.json 判断)
If Archive.GetEntry("mmc-pack.json") IsNot Nothing Then PackType = 2 : Exit Try 'MMC 整合包(优先于 manifest.json 判断,#4194)
If Archive.GetEntry("modrinth.index.json") IsNot Nothing Then PackType = 4 : Exit Try 'Modrinth 整合包
If Archive.GetEntry("manifest.json") IsNot Nothing Then
Dim Json As JObject = GetJson(ReadFile(Archive.GetEntry("manifest.json").Open, Encoding.UTF8))
@@ -36,16 +48,16 @@ Public Module ModModpack
End If
End If
If Archive.GetEntry("modpack.json") IsNot Nothing Then PackType = 1 : Exit Try 'HMCL 整合包
If Archive.GetEntry("mmc-pack.json") IsNot Nothing Then PackType = 2 : Exit Try 'MMC 整合包
If Archive.GetEntry("modpack.zip") IsNot Nothing OrElse Archive.GetEntry("modpack.mrpack") IsNot Nothing Then PackType = 9 : Exit Try '带启动器的压缩包
'从一级目录判断整合包类型
For Each Entry In Archive.Entries
Dim FullNames As String() = Entry.FullName.Split("/")
ArchiveBaseFolder = FullNames(0) & "/"
If Entry.FullName.EndsWithF("/versions/") AndAlso FullNames.Count = 3 Then PackType = 9 : Exit Try '压缩包
'确定为一级目录下
If FullNames.Count <> 2 Then Continue For
'判断是否为关键文件
If FullNames(1) = "mcbbs.packmeta" Then PackType = 3 : Exit Try 'MCBBS 整合包(优先于 manifest.json 判断)
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包(优先于 manifest.json 判断,#4194)
If FullNames(1) = "modrinth.index.json" Then PackType = 4 : Exit Try 'Modrinth 整合包
If FullNames(1) = "manifest.json" Then
Dim Json As JObject = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
@@ -56,54 +68,41 @@ Public Module ModModpack
End If
End If
If FullNames(1) = "modpack.json" Then PackType = 1 : Exit Try 'HMCL 整合包
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包
If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包
Next
Catch ex As Exception
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
Log(ex, "打开整合包文件失败", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Throw New Exception("打开整合包文件失败", ex)
ElseIf File.EndsWithF(".rar", True) Then
Log(ex, "PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Throw New Exception("PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试", ex)
Else
Log(ex, "打开整合包文件失败,文件可能损坏或为不支持的压缩包格式", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Throw New Exception("打开整合包文件失败,文件可能损坏或为不支持的压缩包格式", ex)
End If
End Try
'执行对应的安装方法
Select Case PackType
Case 0
Log("[ModPack] 整合包种类:CurseForge")
InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Return InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Case 1
Log("[ModPack] 整合包种类:HMCL")
InstallPackHMCL(File, Archive, ArchiveBaseFolder)
Return InstallPackHMCL(File, Archive, ArchiveBaseFolder)
Case 2
Log("[ModPack] 整合包种类:MMC")
InstallPackMMC(File, Archive, ArchiveBaseFolder)
Return InstallPackMMC(File, Archive, ArchiveBaseFolder)
Case 3
Log("[ModPack] 整合包种类:MCBBS")
InstallPackMCBBS(File, Archive, ArchiveBaseFolder)
Return InstallPackMCBBS(File, Archive, ArchiveBaseFolder, VersionName)
Case 4
Log("[ModPack] 整合包种类:Modrinth")
InstallPackModrinth(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Return InstallPackModrinth(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Case 9
Log("[ModPack] 整合包种类:压缩包")
Archive.Dispose()
Archive = Nothing
InstallPackCompress(File, ArchiveBaseFolder)
Log("[ModPack] 整合包种类:带启动器的压缩包")
Return InstallPackLauncherPack(File, Archive, ArchiveBaseFolder)
Case Else
If ShowHint Then
Hint("未能识别该整合包的种类,无法安装!", HintType.Critical)
Else
Log("[ModPack] 未能识别该整合包的种类,无法安装!")
End If
Return False
Log("[ModPack] 整合包种类:未能识别,假定为压缩包")
Return InstallPackCompress(File, Archive)
End Select
Return True
Catch ex As Exception
Log(ex, "准备安装整合包失败", LogLevel.Feedback)
Return False
Finally
If Archive IsNot Nothing Then Archive.Dispose()
End Try
@@ -112,7 +111,7 @@ Public Module ModModpack
'整合包缓存清理
Private IsInstallCacheCleared As Boolean = False
Private IsInstallCacheClearing As Boolean = False
Private Sub UnpackFiles(InstallTemp As String, FileAddress As String, Loader As LoaderBase)
Private Sub ExtractModpackFiles(InstallTemp As String, FileAddress As String, Loader As LoaderBase, LoaderProgressDelta As Double)
'清理缓存文件夹
If Not IsInstallCacheCleared Then
IsInstallCacheCleared = True
@@ -139,7 +138,7 @@ Public Module ModModpack
Retry:
'完全不知道为啥会出现文件正在被另一进程使用的问题,总之多试试
DeleteDirectory(InstallTemp)
ExtractFile(FileAddress, InstallTemp, Encode)
ExtractFile(FileAddress, InstallTemp, Encode, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * LoaderProgressDelta)
Catch ex As Exception
Log(ex, "第 " & RetryCount & " 次解压尝试失败")
If TypeOf ex Is ArgumentException Then
@@ -152,7 +151,7 @@ Retry:
RetryCount += 1
GoTo Retry
Else
Throw
Throw New Exception("解压整合包文件失败", ex)
End If
End Try
End Sub
@@ -160,26 +159,25 @@ Retry:
#Region "不同类型整合包的安装方法"
'CurseForge
Private Sub InstallPackCurseForge(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing)
Private Function InstallPackCurseForge(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String,
Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open))
If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Throw New Exception("CurseForge 整合包安装信息存在问题", ex)
End Try
If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("CurseForge 整合包未提供 Minecraft 版本信息")
'获取版本名
Dim ShowRibble As Boolean = VersionName Is Nothing
If VersionName Is Nothing Then
Dim PackName As String = If(Json("name"), "")
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
VersionName = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
End If
'获取 Mod API 版本信息
@@ -190,35 +188,19 @@ Retry:
Dim Id As String = If(Entry("id"), "").ToString.ToLower
If Id.StartsWithF("forge-") Then
'Forge 指定
If Id.Contains("recommended") Then
Log("[ModPack] 该整合包版本过老,已不支持进行安装!", LogLevel.Hint)
Exit Sub
End If
Try
Log("[ModPack] 整合包 Forge 版本:" & Id)
ForgeVersion = Id.Split("-")(1)
Exit For
Catch ex As Exception
Log(ex, "读取整合包 Forge 版本失败:" & Id)
End Try
If Id.Contains("recommended") Then Throw New Exception("该整合包版本过老,已不支持进行安装!")
Log("[ModPack] 整合包 Forge 版本:" & Id)
ForgeVersion = Id.Replace("forge-", "")
ElseIf Id.StartsWithF("neoforge-") Then
'NeoForge 指定
Try
Log("[ModPack] 整合包 NeoForge 版本:" & Id)
NeoForgeVersion = Id.Split("-")(1)
Exit For
Catch ex As Exception
Log(ex, "读取整合包 NeoForge 版本失败:" & Id)
End Try
Log("[ModPack] 整合包 NeoForge 版本:" & Id)
NeoForgeVersion = Id.Replace("neoforge-", "")
ElseIf Id.StartsWithF("fabric-") Then
'Fabric 指定
Try
Log("[ModPack] 整合包 Fabric 版本:" & Id)
FabricVersion = Id.Split("-")(1)
Exit For
Catch ex As Exception
Log(ex, "读取整合包 Fabric 版本失败:" & Id)
End Try
Log("[ModPack] 整合包 Fabric 版本:" & Id)
FabricVersion = Id.Replace("fabric-", "")
Else
Log("[ModPack] 未知 Mod 加载器:" & Id)
End If
Next
'解压与配置文件
@@ -228,17 +210,17 @@ Retry:
If OverrideHome <> "" Then
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
Task.Progress = 0.6
Dim OverridePath As String = InstallTemp & ArchiveBaseFolder & OverrideHome
'复制结果
If Directory.Exists(OverridePath) Then
CopyDirectory(OverridePath, PathMcFolder & "versions\" & VersionName)
CopyDirectory(OverridePath, PathMcFolder & "versions\" & VersionName, Sub(Delta) Task.Progress += Delta * 0.35)
Log($"[ModPack] 整合包 override 复制:{OverridePath} -> {PathMcFolder & "versions\" & VersionName}")
Else
Log($"[ModPack] 整合包中未找到 override 文件夹:{OverridePath}")
End If
Task.Progress = 0.9
Task.Progress = 0.95
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {
@@ -260,9 +242,11 @@ Retry:
'获取 Mod 下载信息
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
Sub(Task As LoaderTask(Of Integer, JArray))
'由于 MCIM 缺少下载信息,只使用官方源获取列表
'TODO: 在 MCIM 源稳定后回调回 DlModRequest
Task.Output = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data")
'如果文件已被删除,则 API 会跳过那一项
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包所需要的部分 Mod 版本已被 Mod 作者删除,因此无法完成整合包安装,请联系整合包作者更新整合包中的 Mod 版本")
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除,所以没法继续安装了,请向整合包作者反馈该问题")
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
'构造 NetFile
ModDownloadLoaders.Add(New LoaderTask(Of JArray, List(Of NetFile))("构造 Mod 下载信息",
@@ -320,7 +304,6 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件(副加载器)", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -342,8 +325,8 @@ Retry:
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
If File.Exists(Target) Then
Log("[ModPack] 删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
@@ -351,36 +334,31 @@ Retry:
'重复任务检查
Dim LoaderName As String = "CurseForge 整合包安装:" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中!", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中!", HintType.Critical)
Throw New CancelledException
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
End Sub
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager))
Return Loader
End Function
'Modrinth
Private Sub InstallPackModrinth(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing)
Private Function InstallPackModrinth(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modrinth.index.json").Open))
If Json("dependencies") Is Nothing OrElse Json("dependencies")("minecraft") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Throw New Exception("Modrinth 整合包安装信息存在问题", ex)
End Try
If Json("dependencies") Is Nothing OrElse Json("dependencies")("minecraft") Is Nothing Then Throw New Exception("Modrinth 整合包未提供 Minecraft 版本信息")
'获取 Mod API 版本信息
Dim MinecraftVersion As String = Nothing
Dim ForgeVersion As String = Nothing
@@ -401,42 +379,43 @@ Retry:
Log("[ModPack] 整合包 Fabric 版本:" & FabricVersion)
Case "quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包!", HintType.Critical)
Exit Sub
Throw New CancelledException
Case Else
Hint($"无法安装整合包,其中出现了未知的 Mod 加载器 {Entry.Value}!", HintType.Critical)
Exit Sub
Throw New CancelledException
End Select
Next
'获取版本名
Dim ShowRibble As Boolean = VersionName Is Nothing
If VersionName Is Nothing Then
Dim PackName As String = If(Json("name"), "")
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
VersionName = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
End If
'解压和配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
'复制 overrides 文件夹和 client-overrides 文件夹
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName)
Else
Log("[ModPack] 整合包中未找到 override 目录,已跳过")
End If
Task.Progress = 0.8
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "client-overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "client-overrides", PathMcFolder & "versions\" & VersionName)
End If
Task.Progress = 0.9
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
Sub(Task As LoaderTask(Of String, Integer))
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
Task.Progress = 0.6
'复制 overrides 文件夹和 client-overrides 文件夹
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName,
Sub(Delta) Task.Progress += Delta * 0.25)
Else
Log("[ModPack] 整合包中未找到 override 目录,已跳过")
End If
Task.Progress = 0.85
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "client-overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "client-overrides", PathMcFolder & "versions\" & VersionName,
Sub(Delta) Task.Progress += Delta * 0.1)
End If
Task.Progress = 0.95
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'获取下载文件列表
Dim FileList As New List(Of NetFile)
For Each File In If(Json("files"), {})
@@ -453,8 +432,10 @@ Retry:
End Select
End If
'添加下载文件
FileList.Add(New NetFile(File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToArray, '修复 #2390
PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
Dim Urls = File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToList
Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
Urls = Urls.Distinct.ToList()
FileList.Add(New NetFile(Urls, PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString), True))
Next
If FileList.Any Then
@@ -471,7 +452,6 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件(副加载器)", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -493,8 +473,8 @@ Retry:
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
If File.Exists(Target) Then
Log("[ModPack] 删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
@@ -502,69 +482,60 @@ Retry:
'重复任务检查
Dim LoaderName As String = "Modrinth 整合包安装:" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中!", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中!", HintType.Critical)
Throw New CancelledException
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
End Sub
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager))
Return Loader
End Function
'HMCL
Private Sub InstallPackHMCL(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackHMCL(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modpack.json").Open, Encoding.UTF8))
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Throw New Exception("HMCL 整合包安装信息存在问题", ex)
End Try
'获取版本名
Dim PackName As String = If(Json("name"), "")
Dim VersionName As String = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
Task.Progress = 0.6
'复制结果
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "minecraft") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "minecraft", PathMcFolder & "versions\" & VersionName)
CopyDirectory(InstallTemp & ArchiveBaseFolder & "minecraft", PathMcFolder & "versions\" & VersionName, Sub(Delta) Task.Progress += Delta * 0.35)
Else
Log("[ModPack] 整合包中未找到 minecraft override 目录,已跳过")
End If
Task.Progress = 0.9
Task.Progress = 0.95
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造加载器
If Json("gameVersion") Is Nothing Then
Hint("该整合包未提供游戏版本信息,无法安装!", HintType.Critical)
Exit Sub
End If
If Json("gameVersion") Is Nothing Then Throw New Exception("该 HMCL 整合包未提供游戏版本信息,无法安装!")
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
.TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\",
.MinecraftName = Json("gameVersion").ToString
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json(副加载器)",
@@ -592,14 +563,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "HMCL 整合包安装:" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中!", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中!", HintType.Critical)
Throw New CancelledException
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -607,41 +574,41 @@ Retry:
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager))
Return Loader
End Function
'MMC
Private Sub InstallPackMMC(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackMMC(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'读取 Json 文件
Dim PackJson As JObject, PackInstance As String
Try
PackJson = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "mmc-pack.json").Open, Encoding.UTF8))
PackInstance = ReadFile(Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open, Encoding.UTF8)
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Throw New Exception("MMC 整合包安装信息存在问题", ex)
End Try
'获取版本名
Dim PackName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
Dim VersionName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
'解压、配置设置文件
Dim InstallTemp As String = $"{PathTemp}PackInstall\{RandomInteger(0, 100000)}\"
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
Task.Progress = 0.6
'复制结果
If Directory.Exists(InstallTemp & ArchiveBaseFolder & ".minecraft") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & ".minecraft", PathMcFolder & "versions\" & VersionName)
CopyDirectory(InstallTemp & ArchiveBaseFolder & ".minecraft", PathMcFolder & "versions\" & VersionName, Sub(Delta) Task.Progress += Delta * 0.35)
Else
Log("[ModPack] 整合包中未找到 override .minecraft 目录,已跳过")
End If
Task.Progress = 0.9
Task.Progress = 0.95
'开启版本隔离
WriteIni(SetupFile, "VersionArgumentIndie", 1)
'读取 MMC 设置文件(#2655)
@@ -684,10 +651,7 @@ Retry:
End Try
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造版本安装请求
If PackJson("components") Is Nothing Then
Hint("该整合包未提供游戏版本信息,无法安装!", HintType.Critical)
Exit Sub
End If
If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息,无法安装!")
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"}
For Each Component In PackJson("components")
Select Case If(Component("uid"), "").ToString
@@ -703,12 +667,11 @@ Retry:
Request.FabricVersion = Component("version")
Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包!", HintType.Critical)
Exit Sub
Throw New CancelledException
End Select
Next
'构造加载器
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件(副加载器)", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -721,73 +684,67 @@ Retry:
'重复任务检查
Dim LoaderName As String = "MMC 整合包安装:" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中!", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中!", HintType.Critical)
Throw New CancelledException
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager))
Return Loader
End Function
'MCBBS
Private Sub InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String,
Optional VersionName As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
Dim Entry = If(Archive.GetEntry(ArchiveBaseFolder & "mcbbs.packmeta"), Archive.GetEntry(ArchiveBaseFolder & "manifest.json"))
Json = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Throw New Exception("MCBBS 整合包安装信息存在问题", ex)
End Try
'获取版本名
Dim PackName As String = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
If VersionName Is Nothing Then
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
End If
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
Task.Progress = 0.6
'复制结果
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName)
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName,
Sub(Delta) Task.Progress += 0.35 * Delta)
Else
Log("[ModPack] 整合包中未找到 overrides 目录,已跳过")
End If
Task.Progress = 0.9
Task.Progress = 0.95
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造加载器
If Json("addons") Is Nothing Then
Hint("该整合包未提供游戏版本附加信息,无法安装!", HintType.Critical)
Exit Sub
End If
If Json("addons") Is Nothing Then Throw New Exception("该 MCBBS 整合包未提供游戏版本附加信息,无法安装!")
Dim Addons As New Dictionary(Of String, String)
For Each Entry In Json("addons")
Addons.Add(Entry("id"), Entry("version"))
Next
If Not Addons.ContainsKey("game") Then
Hint("该整合包未提供游戏版本信息,无法安装!", HintType.Critical)
Exit Sub
End If
If Not Addons.ContainsKey("game") Then Throw New Exception("该 MCBBS 整合包未提供游戏版本信息,无法安装!")
If Addons.ContainsKey("quilt") Then
Hint("PCL 暂不支持安装需要 Quilt 的整合包!", HintType.Critical)
Exit Sub
Throw New CancelledException
End If
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
@@ -799,7 +756,6 @@ Retry:
.FabricVersion = If(Addons.ContainsKey("fabric"), Addons("fabric"), Nothing)
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件(副加载器)", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -812,14 +768,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "MCBBS 整合包安装:" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中!", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中!", HintType.Critical)
Throw New CancelledException
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -827,28 +779,106 @@ Retry:
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager))
Return Loader
End Function
'带启动器的压缩包
Private Function InstallPackLauncherPack(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'获取解压路径
MyMsgBox("接下来请选择一个空文件夹,它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True)
Dim TargetFolder As String = SelectFolder("选择安装目标(必须是一个空文件夹)")
If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号!", HintType.Critical) : Throw New CancelledException
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标!", HintType.Critical) : Throw New CancelledException
'解压
Dim Loader As New LoaderCombo(Of String)("解压压缩包", {
New LoaderTask(Of String, Integer)("解压压缩包",
Sub(Task As LoaderTask(Of String, Integer))
ExtractModpackFiles(TargetFolder, FileAddress, Task, 0.9)
Thread.Sleep(400) '避免文件争用
'查找解压后的 exe 文件
Dim Launcher As String = Nothing
For Each ExeFile In Directory.GetFiles(TargetFolder, "*.exe", SearchOption.AllDirectories)
Dim Info = FileVersionInfo.GetVersionInfo(ExeFile)
Log($"[Modpack] 文件 {ExeFile} 的产品名标识为 {Info.ProductName}")
If Info.ProductName = "Plain Craft Launcher" Then
Launcher = ExeFile
ElseIf (Info.ProductName.ContainsF("Launcher", True) OrElse Info.ProductName.ContainsF("启动器", True)) AndAlso
Not Info.ProductName = "Plain Craft Launcher Admin Manager" Then
If Launcher Is Nothing Then Launcher = ExeFile
End If
Next
Task.Progress = 0.95
'尝试使用附带的启动器打开
If Launcher IsNot Nothing Then
Log("[Modpack] 找到压缩包中附带的启动器:" & Launcher)
If MyMsgBox($"整合包中似乎自带了启动器,是否换用它继续安装?{vbCrLf}通常推荐这样做,以获得最佳体验。{vbCrLf}即将打开:{Launcher}", "换用整合包启动器?", "继续", "取消") = 1 Then
ShellOnly(Launcher, "--wait")
Log("[Modpack] 为换用整合包中的启动器启动,强制结束程序")
FrmMain.EndProgram(False)
Return
End If
Else
Log("[Modpack] 未找到压缩包中附带的启动器")
End If
'加入文件夹列表
Dim VersionName As String = GetFolderNameFromPath(TargetFolder)
PageSelectLeft.AddFolder(
TargetFolder & ArchiveBaseFolder.Replace("/", "\").TrimStart("\"), '格式例如:包裹文件夹\.minecraft\(最短为空字符串)
VersionName, False)
'调用 modpack 文件进行安装
Dim ModpackFile = Directory.GetFiles(TargetFolder, "modpack.*", SearchOption.AllDirectories).First
Log("[Modpack] 调用 modpack 文件继续安装:" & ModpackFile)
ModpackInstall(ModpackFile, VersionName)
End Sub)
})
Loader.Start(TargetFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
Return Loader
End Function
'普通压缩包
Private Sub InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String)
MyMsgBox("请在接下来打开的窗口中选择安装目标文件夹,它必须是一个空文件夹。", "安装提示", "继续", ForceWait:=True)
Private Function InstallPackCompress(FileAddress As String, Archive As Compression.ZipArchive) As LoaderCombo(Of String)
'尝试定位 .minecraft 文件夹:寻找形如 “/versions/XXX/XXX.json” 的路径
Dim Match As RegularExpressions.Match = Nothing
Dim Regex As New RegularExpressions.Regex("^.*\/(?=versions\/(?<ver>[^\/]+)\/(\k<ver>)\.json$)", RegularExpressions.RegexOptions.IgnoreCase)
For Each Entry In Archive.Entries
Dim EntryMatch = Regex.Match("/" & Entry.FullName)
If EntryMatch.Success Then
Match = EntryMatch
Exit For
End If
Next
If Match Is Nothing Then Throw New Exception("未能找到适合的文件结构,这可能不是一个 MC 压缩包") '没有匹配
Dim ArchiveBaseFolder As String = Match.Value.Replace("/", "\").TrimStart("\") '格式例如:包裹文件夹\.minecraft\(最短为空字符串)
Dim VersionName As String = Match.Groups(1).Value
Log("[ModPack] 检测到压缩包的 .minecraft 根目录:" & ArchiveBaseFolder & ",命中的版本名:" & VersionName)
'获取解压路径
MyMsgBox("接下来请选择一个空文件夹,它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True)
Dim TargetFolder As String = SelectFolder("选择安装目标(必须是一个空文件夹)")
If String.IsNullOrEmpty(TargetFolder) Then Exit Sub
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号!", HintType.Critical) : Exit Sub
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标!", HintType.Critical) : Exit Sub
'要求显示名称
Dim NewName As String = MyMsgBoxInput("输入显示名称", "输入该文件夹在左边栏列表中显示的名称。", GetFolderNameFromPath(TargetFolder),
New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})})
If String.IsNullOrWhiteSpace(NewName) Then Exit Sub
If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号!", HintType.Critical) : Throw New CancelledException
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标!", HintType.Critical) : Throw New CancelledException
'解压
Hint("正在解压压缩包……")
UnpackFiles(TargetFolder, FileAddress, Nothing)
'加入文件夹列表
PageSelectLeft.AddFolder(TargetFolder, NewName, False)
Hint("已加入游戏文件夹列表:" & NewName, HintType.Finish)
End Sub
Dim Loader As New LoaderCombo(Of String)("解压压缩包", {
New LoaderTask(Of String, Integer)("解压压缩包",
Sub(Task As LoaderTask(Of String, Integer))
ExtractModpackFiles(TargetFolder, FileAddress, Task, 0.95)
'加入文件夹列表
PageSelectLeft.AddFolder(TargetFolder & ArchiveBaseFolder, GetFolderNameFromPath(TargetFolder), False)
Thread.Sleep(400) '避免文件争用
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.VersionSelect))
End Sub)
}) With {.OnStateChanged = AddressOf McInstallState}
Loader.Start(TargetFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Function
#End Region
#End Region
@@ -88,26 +88,27 @@
AddHandler GameProcess.ErrorDataReceived, AddressOf LogReceived
'初始化时钟
RunInNewThread(Sub()
Try
Do Until State = MinecraftState.Ended OrElse State = MinecraftState.Crashed OrElse State = MinecraftState.Canceled OrElse Loader.State = LoadState.Aborted
TimerWindow()
TimerLog()
'设置窗口标题
For i = 1 To 3
If IsWindowFinished AndAlso IsWindowAppeared AndAlso WindowTitle <> "" AndAlso State = MinecraftState.Running AndAlso Not GameProcess.HasExited Then
Dim RealTitle As String = WindowTitle.Replace("{date}", Date.Now.ToString("yyyy/M/d")).Replace("{time}", Date.Now.ToString("HH:mm:ss"))
SetWindowText(WindowHandle, RealTitle.ToCharArray)
End If
Thread.Sleep(64)
Next
Loop
WatcherLog("Minecraft 日志监控已退出")
Catch ex As Exception
Log(ex, "Minecraft 日志监控主循环出错", LogLevel.Feedback)
State = MinecraftState.Ended
End Try
End Sub, "Minecraft Watcher PID " & PID)
RunInNewThread(
Sub()
Try
Do Until State = MinecraftState.Ended OrElse State = MinecraftState.Crashed OrElse State = MinecraftState.Canceled OrElse Loader.State = LoadState.Aborted
TimerWindow()
TimerLog()
'设置窗口标题
For i = 1 To 3
If IsWindowFinished AndAlso IsWindowAppeared AndAlso WindowTitle <> "" AndAlso State = MinecraftState.Running AndAlso Not GameProcess.HasExited Then
Dim RealTitle As String = WindowTitle.Replace("{date}", Date.Now.ToString("yyyy/M/d")).Replace("{time}", Date.Now.ToString("HH:mm:ss"))
SetWindowText(WindowHandle, RealTitle.ToCharArray)
End If
Thread.Sleep(64)
Next
Loop
WatcherLog("Minecraft 日志监控已退出")
Catch ex As Exception
Log(ex, "Minecraft 日志监控主循环出错", LogLevel.Feedback)
State = MinecraftState.Ended
End Try
End Sub, "Minecraft Watcher PID " & PID)
End Sub
'状态
@@ -349,22 +350,21 @@
WatcherLog("Minecraft 已崩溃,将在 2 秒后开始崩溃分析")
Hint("检测到 Minecraft 出现错误,错误分析已开始……")
FeedbackInfo()
RunInNewThread(Sub()
Try
Thread.Sleep(2000)
WatcherLog("崩溃分析开始")
Dim Analyzer As New CrashAnalyzer(PID)
Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
Analyzer.Prepare()
Analyzer.Analyze(Version)
Analyzer.Output(False, New List(Of String) From
{Version.Path & Version.Name & ".json",
Path & "PCL\Log1.txt",
Path & "PCL\LatestLaunch.bat"})
Catch ex As Exception
Log(ex, "崩溃分析失败", LogLevel.Feedback)
End Try
End Sub, "Crash Analyzer")
RunInNewThread(
Sub()
Try
Thread.Sleep(2000)
WatcherLog("崩溃分析开始")
Dim Analyzer As New CrashAnalyzer(PID)
Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
Analyzer.Prepare()
Analyzer.Analyze(Version)
Analyzer.Output(False, New List(Of String) From
{Version.Path & Version.Name & ".json", Path & "PCL\Log1.txt", Path & "PCL\LatestLaunch.bat"})
Catch ex As Exception
Log(ex, "崩溃分析失败", LogLevel.Feedback)
End Try
End Sub, "Crash Analyzer")
End Sub
'强制关闭
@@ -1,6 +1,7 @@
<Grid x:Class="MyCompItem"
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:local="clr-namespace:PCL"
x:Name="PanBack" Height="64"
RenderTransformOrigin="0.5,0.5" Background="{StaticResource ColorBrushSemiTransparent}" SnapsToDevicePixels="True">
<Grid.ColumnDefinitions>
@@ -23,7 +24,7 @@
<Border.Clip>
<RectangleGeometry Rect="0,0,50,50" RadiusX="6" RadiusY="6" />
</Border.Clip>
<Image x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" />
<local:MyImage x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" FallbackSource="pack://application:,,,/images/Icons/NoIcon.png" />
</Border>
<!-- 标题 -->
<StackPanel Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" Orientation="Horizontal"
@@ -4,90 +4,14 @@
Public Uuid As Integer = GetUuid()
'Logo
Private _Logo As String = ""
Public Property Logo As String
Get
Return _Logo
Return PathLogo.Source
End Get
Set(value As String)
If _Logo = value OrElse value Is Nothing Then Exit Property
_Logo = value
Dim FileAddress = PathTemp & "CompLogo\" & GetHash(_Logo) & ".png"
Try
If _Logo.StartsWithF("http", True) Then
'网络图片
If File.Exists(FileAddress) Then
PathLogo.Source = New MyBitmap(FileAddress)
ElseIf _Logo.EndsWithF(".webp", True) Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
Log($"[Comp] 发现不支持的 WebP 格式图标,已更改为默认图标:{_Logo}")
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
Else
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
RunInNewThread(Sub() LogoLoader(FileAddress), "Comp Logo Loader " & Uuid & "#", ThreadPriority.BelowNormal)
End If
Else
'位图
PathLogo.Source = New MyBitmap(_Logo)
End If
Catch ex As IOException
Log(ex, "加载资源工程图标时读取失败(" & FileAddress & ")")
Catch ex As ArgumentException
'考虑缓存的图片本身可能有误
Log(ex, "可视化资源工程图标失败(" & FileAddress & ")")
Try
File.Delete(FileAddress)
Log("[Comp] 已清理损坏的资源工程图标:" & FileAddress)
Catch exx As Exception
Log(exx, "清理损坏的资源工程图标缓存失败(" & FileAddress & ")", LogLevel.Hint)
End Try
Catch ex As Exception
Log(ex, "加载资源工程图标失败(" & value & ")")
End Try
PathLogo.Source = value
End Set
End Property
'后台加载 Logo
Private Sub LogoLoader(LocalFileAddress As String)
Dim Retried As Boolean = False
Dim DownloadEnd As String = GetUuid()
RetryStart:
Try
'CurseForge 图片使用缩略图
Dim Url As String = _Logo
If Url.Contains("/256/256/") AndAlso GetPixelSize(1) <= 1.25 AndAlso Not Retried Then
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
Try
'在地址更换时取消加载
If LocalFileAddress <> $"{PathTemp}CompLogo\{GetHash(_Logo)}.png" Then Exit Sub
'在完成正常加载后才保存缓存图片
PathLogo.Source = New MyBitmap(LocalFileAddress & DownloadEnd)
Catch ex As Exception
Log(ex, $"读取资源工程图标失败({LocalFileAddress})")
File.Delete(LocalFileAddress & DownloadEnd)
LoadError = ex
End Try
End Sub)
If LoadError IsNot Nothing Then Throw LoadError
If File.Exists(LocalFileAddress) Then
File.Delete(LocalFileAddress & DownloadEnd)
Else
FileIO.FileSystem.MoveFile(LocalFileAddress & DownloadEnd, LocalFileAddress)
End If
Catch ex As Exception
If Not Retried Then
Retried = True
GoTo RetryStart
Else
Log(ex, $"下载资源工程图标失败({_Logo})")
RunInUi(Sub() PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png"))
End If
End Try
End Sub
'标题
Public Property Title As String
@@ -172,7 +96,7 @@ RetryStart:
'记录当前展开的卡片标题(#2712)
Dim Titles As New List(Of String)
If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then
For Each Card As MyCard In FrmDownloadCompDetail.PanMain.Children
For Each Card As MyCard In FrmDownloadCompDetail.PanResults.Children
If Card.Title <> "" AndAlso Not Card.IsSwaped Then Titles.Add(Card.Title)
Next
Log("[Comp] 记录当前已展开的卡片:" & String.Join("、", Titles))
@@ -24,30 +24,27 @@
<Border.Clip>
<RectangleGeometry Rect="0,0,34,34" RadiusX="6" RadiusY="6" />
</Border.Clip>
<Image x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" />
<local:MyImage x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" FallbackSource="pack://application:,,,/images/Icons/NoIcon.png" />
</Border>
<!-- 标题 -->
<StackPanel Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" Orientation="Horizontal"
SnapsToDevicePixels="False" UseLayoutRounding="False">
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" IsHitTestVisible="False" />
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" IsHitTestVisible="False"
<Grid Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0"
SnapsToDevicePixels="False" UseLayoutRounding="False" x:Name="PanTitle">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" x:Name="ColumnTitle" />
<ColumnDefinition Width="Auto" x:Name="ColumnSubtitle" />
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" x:Name="ColumnExtend" />
</Grid.ColumnDefinitions>
<TextBlock x:Name="LabTitle" TextTrimming="CharacterEllipsis" FontSize="14" IsHitTestVisible="False" />
<TextBlock x:Name="LabSubtitle" Grid.Column="1" HorizontalAlignment="Left"
TextTrimming="CharacterEllipsis" FontSize="12" IsHitTestVisible="False"
Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
<!-- 更新按钮 -->
<local:MyIconButton Width="21" Height="21" Margin="-2,-1.6,0,0" x:Name="BtnUpdate" Theme="Black" Opacity="0.4" Visibility="Collapsed"
<local:MyIconButton Grid.Column="2"
Width="21" Height="21" Margin="-2,-1.6,0,0" x:Name="BtnUpdate" Theme="Black" Opacity="0.4" Visibility="Collapsed"
ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="100" ToolTipService.VerticalOffset="-9"
Logo="M640 768H384l-32-32V509H213L190 454l298-298h45l298 298L810 509h-138v226z m-224-64h192V477l32-32h93L512 223 290 445H384l32 32zM352 831h320v64h-320z" />
</StackPanel>
<!--<Grid Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" />
<ColumnDefinition Width="Auto" />
</Grid.ColumnDefinitions>
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" Grid.Column="0" />
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" Grid.Column="1"
Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
<local:MyIconTextButton Grid.Column="2" Text="更新" />
</Grid>-->
</Grid>
<!-- Tag 与 详情 -->
<StackPanel x:Name="PanTags" Grid.Row="2" Grid.Column="3" Orientation="Horizontal" VerticalAlignment="Bottom" Margin="-1,0,1,0" Visibility="Collapsed" IsHitTestVisible="False">
<!--<Border Background="{DynamicResource ColorBrush6}" Padding="3,1" CornerRadius="3" Margin="0,0,4,0" SnapsToDevicePixels="True" UseLayoutRounding="False">
@@ -55,6 +52,6 @@
</Border>-->
</StackPanel>
<TextBlock x:Name="LabInfo" Grid.Row="2" Grid.Column="4" VerticalAlignment="Bottom" Margin="0,0,3,1"
TextTrimming="CharacterEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray3}"
TextTrimming="CharacterEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray4}"
IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False" />
</Grid>
@@ -6,90 +6,14 @@ Public Class MyLocalModItem
Public Uuid As Integer = GetUuid()
'Logo
Private _Logo As String = ""
Public Property Logo As String
Get
Return _Logo
Return PathLogo.Source
End Get
Set(value As String)
If _Logo = value OrElse value Is Nothing Then Exit Property
_Logo = value
Dim FileAddress = PathTemp & "CompLogo\" & GetHash(_Logo) & ".png"
Try
If _Logo.StartsWithF("http", True) Then
'网络图片
If File.Exists(FileAddress) Then
PathLogo.Source = New MyBitmap(FileAddress)
ElseIf _Logo.EndsWithF(".webp", True) Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
Log($"[LocalModItem] 发现不支持的 WebP 格式图标,已更改为默认图标:{_Logo}")
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
Else
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
RunInNewThread(Sub() LogoLoader(FileAddress), "Comp Logo Loader " & Uuid & "#", ThreadPriority.BelowNormal)
End If
Else
'位图
PathLogo.Source = New MyBitmap(_Logo)
End If
Catch ex As IOException
Log(ex, "加载本地 Mod 图标时读取失败(" & FileAddress & ")")
Catch ex As ArgumentException
'考虑缓存的图片本身可能有误
Log(ex, "可视化本地 Mod 图标失败(" & FileAddress & ")")
Try
File.Delete(FileAddress)
Log("[LocalModItem] 已清理损坏的本地 Mod 图标:" & FileAddress)
Catch exx As Exception
Log(exx, "清理损坏的本地 Mod 图标缓存失败(" & FileAddress & ")", LogLevel.Hint)
End Try
Catch ex As Exception
Log(ex, "加载本地 Mod 图标失败(" & value & ")")
End Try
PathLogo.Source = value
End Set
End Property
'后台加载 Logo
Private Sub LogoLoader(LocalFileAddress As String)
Dim Retried As Boolean = False
Dim DownloadEnd As String = GetUuid()
RetryStart:
Try
'CurseForge 图片使用缩略图
Dim Url As String = _Logo
If Url.Contains("/256/256/") AndAlso GetPixelSize(1) <= 1.25 AndAlso Not Retried Then
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
Try
'在地址更换时取消加载
If LocalFileAddress <> $"{PathTemp}CompLogo\{GetHash(_Logo)}.png" Then Exit Sub
'在完成正常加载后才保存缓存图片
PathLogo.Source = New MyBitmap(LocalFileAddress & DownloadEnd)
Catch ex As Exception
Log(ex, "读取本地 Mod 图标失败(" & LocalFileAddress & ")")
File.Delete(LocalFileAddress & DownloadEnd)
LoadError = ex
End Try
End Sub)
If LoadError IsNot Nothing Then Throw LoadError
If File.Exists(LocalFileAddress) Then
File.Delete(LocalFileAddress & DownloadEnd)
Else
FileIO.FileSystem.MoveFile(LocalFileAddress & DownloadEnd, LocalFileAddress)
End If
Catch ex As Exception
If Not Retried Then
Retried = True
GoTo RetryStart
Else
Log(ex, $"下载本地 Mod 图标失败({_Logo})")
RunInUi(Sub() PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png"))
End If
End Try
End Sub
'标题
Private _Title As String
@@ -104,7 +28,7 @@ RetryStart:
LabTitle.TextDecorations = Nothing
Case McMod.McModState.Disabled
LabTitle.TextDecorations = TextDecorations.Strikethrough
Case McMod.McModState.Unavaliable
Case McMod.McModState.Unavailable
LabTitle.TextDecorations = TextDecorations.Strikethrough
value &= " [错误]"
End Select
@@ -117,12 +41,12 @@ RetryStart:
'副标题
Public Property SubTitle As String
Get
Return If(LabTitleRaw?.Text, "")
Return If(LabSubtitle?.Text, "")
End Get
Set(value As String)
If LabTitleRaw.Text = value Then Exit Property
LabTitleRaw.Text = value
LabTitleRaw.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible)
If LabSubtitle.Text = value Then Exit Property
LabSubtitle.Text = value
LabSubtitle.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible)
End Set
End Property
@@ -145,9 +69,9 @@ RetryStart:
For Each TagText In value
Dim NewTag = GetObjectFromXML(
"<Border xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation""
Background=""#11000000"" Padding=""3,1"" CornerRadius=""3"" Margin=""0,0,3,0""
Background=""#0C000000"" Padding=""3,1"" CornerRadius=""3"" Margin=""0,0,3,0""
SnapsToDevicePixels=""True"" UseLayoutRounding=""False"">
<TextBlock Text=""" & TagText & """ Foreground=""#868686"" FontSize=""11"" />
<TextBlock Text=""" & TagText & """ Foreground=""#88000000"" FontSize=""11"" />
</Border>")
PanTags.Children.Add(NewTag)
Next
@@ -379,57 +303,75 @@ RetryStart:
#End Region
Public Sub Refresh()
Private Function GetUpdateCompareDescription() As String
Dim CurrentName = Entry.CompFile.FileName.Replace(".jar", "")
Dim NewestName = Entry.UpdateFile.FileName.Replace(".jar", "")
'简化名称对比
Dim CurrentSegs = CurrentName.Split("-"c).ToList()
Dim NewestSegs = NewestName.Split("-"c).ToList()
Dim Shortened As Boolean = False
For Each Seg In CurrentSegs.ToList()
If Not NewestSegs.Contains(Seg) Then Continue For
CurrentSegs.Remove(Seg)
NewestSegs.Remove(Seg)
Shortened = True
Next
If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then
CurrentName = Join(CurrentSegs, "-")
NewestName = Join(NewestSegs, "-")
Entry._Version = CurrentName '使用网络信息作为显示的版本号
End If
Return $"当前版本:{CurrentName}({GetTimeSpanString(Entry.CompFile.ReleaseDate - Date.Now, False)}){vbCrLf}最新版本:{NewestName}({GetTimeSpanString(Entry.UpdateFile.ReleaseDate - Date.Now, False)})"
End Function
Public Sub Refresh() Handles Me.Loaded
RunInUi(
Sub()
'更新
If Entry.CanUpdate Then
BtnUpdate.Visibility = Visibility.Visible
Dim CurrentName = Entry.CompFile.FileName.Replace(".jar", "")
Dim NewestName = Entry.UpdateFile.FileName.Replace(".jar", "")
'简化名称对比
Dim CurrentSegs = CurrentName.Split("-"c).ToList()
Dim NewestSegs = NewestName.Split("-"c).ToList()
Dim Shortened As Boolean = False
For Each Seg In CurrentSegs.ToList()
If Not NewestSegs.Contains(Seg) Then Continue For
CurrentSegs.Remove(Seg)
NewestSegs.Remove(Seg)
Shortened = True
Next
If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then
CurrentName = Join(CurrentSegs, "-")
NewestName = Join(NewestSegs, "-")
Entry._Version = CurrentName '使用网络信息作为显示的版本号
End If
BtnUpdate.ToolTip = $"当前版本:{CurrentName} ({Entry.CompFile.ReleaseDate:yyyy/MM/dd HH:mm:ss}){vbCrLf}最新版本:{NewestName} ({Entry.UpdateFile.ReleaseDate:yyyy/MM/dd HH:mm:ss}){vbCrLf}点击以更新,右键查看更新日志。"
BtnUpdate.ToolTip = $"{GetUpdateCompareDescription()}{vbCrLf}点击以更新,右键查看更新日志。"
Else
BtnUpdate.Visibility = Visibility.Collapsed
End If
'标题
If Entry.Comp Is Nothing Then
Title = Entry.Name
SubTitle = If(Entry.Version Is Nothing, "", " | " & Entry.Version)
Else
Dim Titles = Entry.Comp.GetControlTitle(False)
Title = Titles.Key
SubTitle = Titles.Value & If(Entry.Version Is Nothing, "", " | " & Entry.Version)
End If
If Checked Then
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5"))
Else
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4"))
End If
'描述
Dim NewDescription As String
'标题与描述
Dim DescFileName As String
Select Case Entry.State
Case McMod.McModState.Fine
NewDescription = GetFileNameWithoutExtentionFromPath(Entry.Path)
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path)
Case McMod.McModState.Disabled
NewDescription = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", ""))
Case Else 'McMod.McModState.Unavaliable
NewDescription = GetFileNameFromPath(Entry.Path)
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", ""))
Case Else 'McMod.McModState.Unavailable
DescFileName = GetFileNameFromPath(Entry.Path)
End Select
Dim NewDescription As String
If Setup.Get("ToolModLocalNameStyle") = 1 Then
'标题显示文件名,详情显示译名
'标题
Title = DescFileName
SubTitle = ""
'描述
If Entry.Comp Is Nothing Then
NewDescription = Entry.Name
Else
Dim Titles = Entry.Comp.GetControlTitle(False)
NewDescription = Titles.Key & Titles.Value
End If
NewDescription = NewDescription.Replace(" | ", " / ")
If Entry.Version IsNot Nothing Then NewDescription &= $" ({Entry.Version})"
Else
'标题显示译名,详情显示文件名
'标题
If Entry.Comp Is Nothing Then
Title = Entry.Name
SubTitle = If(Entry.Version Is Nothing, "", " | " & Entry.Version)
Else
Dim Titles = Entry.Comp.GetControlTitle(False)
Title = Titles.Key
SubTitle = Titles.Value & If(Entry.Version Is Nothing, "", " | " & Entry.Version)
End If
'描述
NewDescription = DescFileName
End If
If Entry.Comp IsNot Nothing Then
NewDescription += ": " & Entry.Comp.Description.Replace(vbCr, "").Replace(vbLf, "")
ElseIf Entry.Description IsNot Nothing Then
@@ -438,6 +380,11 @@ RetryStart:
NewDescription += ": " & "存在错误,无法获取信息"
End If
Description = NewDescription
If Checked Then
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5"))
Else
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4"))
End If
'主 Logo
Logo = If(Entry.Comp Is Nothing, PathImage & "Icons/NoIcon.png", Entry.Comp.GetControlLogo())
'图标右下角的 Logo
@@ -458,7 +405,7 @@ RetryStart:
'<Image x:Name="ImgState" RenderOptions.BitmapScalingMode="HighQuality" Width="16" Height="16" Margin="0,0,-3,-1"
' Grid.Column="1" Grid.Row="1" Grid.RowSpan="2" IsHitTestVisible="False"
' HorizontalAlignment="Right" VerticalAlignment="Bottom"
' Source="/Images/Icons/Unavaliable.png" />
' Source="/Images/Icons/Unavailable.png" />
End If
ImgState.Source = New MyBitmap(PathImage & $"Icons/{Entry.State}.png")
End If
@@ -532,7 +479,57 @@ RetryStart:
'触发更新
Private Sub BtnUpdate_Click(sender As Object, e As EventArgs) Handles BtnUpdate.Click
If MyMsgBox($"是否要更新 {Entry.Name}?{vbCrLf}{vbCrLf}{GetUpdateCompareDescription()}", "Mod 更新确认", "更新", "取消") = 2 Then Return
FrmVersionMod.UpdateMods({Entry})
End Sub
'自适应(#4465)
Private Sub PanTitle_SizeChanged() Handles PanTitle.SizeChanged
'0:全部舒展:Auto - Auto - (Auto) - 1*
'1:压缩 Subtitle:Auto - 1* - (Auto) - 0
'2:继续压缩 Title:1* - 0 - (Auto) - 0
Dim CurrentCompressLevel As Integer =
If(ColumnExtend.Width.IsStar, 0, If(ColumnTitle.Width.IsStar, 2, 1)) 'Subtitle 可能是 Collapsed
Dim NewCompressLevel As Integer
Select Case CurrentCompressLevel
Case 0
If ColumnExtend.ActualWidth < 0.5 Then
NewCompressLevel = If(LabSubtitle.Visibility = Visibility.Collapsed, 2, 1)
Else
Return
End If
Case 1
If ColumnSubtitle.ActualWidth < 0.5 Then
NewCompressLevel = 2
ElseIf Not LabSubtitle.IsTextTrimmed Then
NewCompressLevel = 0
Else
Return
End If
Case 2
If Not LabTitle.IsTextTrimmed Then
NewCompressLevel = If(LabSubtitle.Visibility = Visibility.Collapsed, 0, 1)
Else
Return
End If
End Select
Select Case NewCompressLevel
Case 0
'全部舒展:Auto - Auto - (Auto) - 1*
ColumnTitle.Width = GridLength.Auto
ColumnSubtitle.Width = GridLength.Auto
ColumnExtend.Width = New GridLength(1, GridUnitType.Star)
Case 1
'压缩 Subtitle:Auto - 1* - (Auto) - 0
ColumnTitle.Width = GridLength.Auto
ColumnSubtitle.Width = New GridLength(1, GridUnitType.Star)
ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
Case 2
'继续压缩 Title:1* - 0 - (Auto) - 0
ColumnTitle.Width = New GridLength(1, GridUnitType.Star)
ColumnSubtitle.Width = New GridLength(0, GridUnitType.Pixel)
ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
End Select
End Sub
End Class
+34 -22
View File
@@ -21,26 +21,28 @@
OpenWebsite(Data(0))
Case "打开文件", "打开帮助"
RunInThread(Sub()
Try
'确认实际路径
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), Type)
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
'执行
If Type = "打开文件" Then
Dim Info As New ProcessStartInfo With {
.Arguments = If(Data.Length >= 2, Data(1), ""),
.FileName = Location,
.WorkingDirectory = WorkingDir
}
Process.Start(Info)
Else '打开帮助
PageOtherHelp.EnterHelpPage(Location)
End If
Catch ex As Exception
Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox)
End Try
End Sub)
RunInThread(
Sub()
Try
'确认实际路径
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), Type)
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
Log($"[Control] 打开类自定义事件实际路径:{Location},工作目录:{WorkingDir}")
'执行
If Type = "打开文件" Then
Dim Info As New ProcessStartInfo With {
.Arguments = If(Data.Length >= 2, Data(1), ""),
.FileName = Location,
.WorkingDirectory = WorkingDir
}
Process.Start(Info)
Else '打开帮助
PageOtherHelp.EnterHelpPage(Location)
End If
Catch ex As Exception
Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox)
End Try
End Sub)
Case "启动游戏"
If Data(0) = "\current" Then
@@ -90,7 +92,18 @@
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败")
Exit Sub
End If
PageOtherTest.StartCustomDownload(Data(0), GetFileNameFromPath(Data(0)))
Try
Select Case Data.Length
Case 1
PageOtherTest.StartCustomDownload(Data(0), GetFileNameFromPath(Data(0)))
Case 2
PageOtherTest.StartCustomDownload(Data(0), Data(1))
Case Else
PageOtherTest.StartCustomDownload(Data(0), Data(1), Data(2))
End Select
Catch
PageOtherTest.StartCustomDownload(Data(0), "未知")
End Try
Case Else
MyMsgBox("未知的事件类型:" & Type & vbCrLf & "请检查事件类型填写是否正确,或者 PCL 是否为最新版本。", "事件执行失败")
@@ -126,7 +139,6 @@
Dim LocalTemp1 As String = PathTemp & "CustomEvent\" & RawFileName
Dim LocalTemp2 As String = PathTemp & "CustomEvent\" & RawFileName.Replace(".json", ".xaml")
Log("[Event] 转换网络资源:" & RelativeUrl & " -> " & LocalTemp1)
Hint("正在获取资源,请稍候……")
Try
NetDownload(RelativeUrl, LocalTemp1)
NetDownload(RelativeUrl.Replace(".json", ".xaml"), LocalTemp1.Replace(".json", ".xaml"))
+23 -11
View File
@@ -69,14 +69,14 @@ Public Module ModMain
Dim Percent As Double = 0.3
Select Case CurrentHint.Type
Case HintType.Info
TargetColor0 = New MyColor(37, 155, 252)
TargetColor1 = New MyColor(10, 142, 252)
TargetColor0 = New MyColor(215, 37, 155, 252)
TargetColor1 = New MyColor(215, 10, 142, 252)
Case HintType.Finish
TargetColor0 = New MyColor(33, 177, 33)
TargetColor1 = New MyColor(29, 160, 29)
TargetColor0 = New MyColor(215, 33, 177, 33)
TargetColor1 = New MyColor(215, 29, 160, 29)
Case Else 'HintType.Critical
TargetColor0 = New MyColor(255, 53, 11)
TargetColor1 = New MyColor(255, 43, 0)
TargetColor0 = New MyColor(215, 255, 53, 11)
TargetColor1 = New MyColor(215, 255, 43, 0)
End Select
If Not IsNothing(DoubleStack) Then
'有重复提示,且该提示的进入动画已播放
@@ -176,15 +176,17 @@ EndHint:
Public Title As String
Public Text As String
''' <summary>
''' 输入框模式:文本框的文本;选择模式:需要放进去的 List(Of MyListItem)。
''' 输入模式:文本框的文本。
''' 选择模式:需要放进去的 List(Of MyListItem)。
''' 登录模式:登录步骤 1 中返回的 JSON。
''' </summary>
Public Content As Object
''' <summary>
''' 仅输入框模式:输入验证规则。
''' 输入模式:输入验证规则。
''' </summary>
Public ValidateRules As ObjectModel.Collection(Of Validate)
''' <summary>
''' 仅输入框模式:提示文本。
''' 输入模式:提示文本。
''' </summary>
Public HintText As String = ""
''' <summary>
@@ -214,7 +216,9 @@ EndHint:
''' </summary>
Public IsExited As Boolean = False
''' <summary>
''' 点击的按钮编号或输入的文本。若输入弹窗点击了非第一个按钮,则为 Nothing。
''' 输入模式:输入的文本。若点击了 非 第一个按钮,则为 Nothing。
''' 选择模式:点击的按钮编号,从 1 开始。
''' 登录模式:字符串数组 {AccessToken, RefreshToken} 或一个 Exception。
''' </summary>
Public Result As Object
End Class
@@ -222,6 +226,7 @@ EndHint:
Text
[Select]
Input
Login
End Enum
''' <summary>
@@ -352,6 +357,8 @@ EndHint:
FrmMain.PanMsg.Children.Add(New MyMsgSelect(WaitingMyMsgBox(0)))
Case MyMsgBoxType.Text
FrmMain.PanMsg.Children.Add(New MyMsgText(WaitingMyMsgBox(0)))
Case MyMsgBoxType.Login
FrmMain.PanMsg.Children.Add(New MyMsgLogin(WaitingMyMsgBox(0)))
End Select
WaitingMyMsgBox.RemoveAt(0)
Else
@@ -437,6 +444,10 @@ EndHint:
#Region "帮助"
Public Class HelpEntry
''' <summary>
''' 原始信息路径。用于刷新。
''' </summary>
Public RawPath As String
'基础
@@ -495,6 +506,7 @@ EndHint:
''' 从文件初始化 HelpEntry 对象,失败会抛出异常。
''' </summary>
Public Sub New(FilePath As String)
RawPath = FilePath
Dim JsonData As JObject = GetJson(HelpArgumentReplace(ReadFile(FilePath)))
If JsonData Is Nothing Then Throw New FileNotFoundException("未找到帮助文件:" & FilePath, FilePath)
'加载常规信息
@@ -592,7 +604,7 @@ EndHint:
'加载忽略列表
Log("[Help] 发现 .helpignore 文件:" & File.FullName)
For Each Line In ReadFile(File.FullName).Split(vbCrLf.ToCharArray)
Dim RealString As String = Line.Before("#").Trim
Dim RealString As String = Line.BeforeFirst("#").Trim
If String.IsNullOrWhiteSpace(RealString) Then Continue For
IgnoreList.Add(RealString)
If ModeDebug Then Log("[Help] > " & RealString)
+72 -51
View File
@@ -14,8 +14,8 @@
''' 初始化音乐播放列表。
''' </summary>
''' <param name="ForceReload">强制全部重新载入列表。</param>
''' <param name="IgnoreFirst">在重载列表时避免让某项成为第一项。</param>
Private Sub MusicListInit(ForceReload As Boolean, Optional IgnoreFirst As String = "")
''' <param name="PreventFirst">在重载列表时避免让某项成为第一项。</param>
Private Sub MusicListInit(ForceReload As Boolean, Optional PreventFirst As String = Nothing)
If ForceReload Then MusicAllList = Nothing
Try
'初始化全部可用音乐列表
@@ -31,10 +31,10 @@
End If
'打乱顺序播放
MusicWaitingList = If(Setup.Get("UiMusicRandom"), Shuffle(New List(Of String)(MusicAllList)), New List(Of String)(MusicAllList))
If Not IgnoreFirst = "" AndAlso Not Not MusicWaitingList.Any() AndAlso MusicWaitingList(0) = IgnoreFirst Then
If PreventFirst IsNot Nothing AndAlso MusicWaitingList.FirstOrDefault = PreventFirst Then
'若需要避免成为第一项的为第一项,则将它放在最后
MusicWaitingList.RemoveAt(0)
MusicWaitingList.Add(IgnoreFirst)
MusicWaitingList.Add(PreventFirst)
End If
Catch ex As Exception
Log(ex, "初始化音乐列表失败", LogLevel.Feedback)
@@ -42,13 +42,18 @@
End Sub
''' <summary>
''' 获取下一首播放的音乐路径并将其从列表中移除。
''' 如果没有,可能会返回 Nothing。
''' </summary>
Private Function DequeueNextMusicAddress() As String
'初始化,确保存在音乐
If MusicAllList Is Nothing OrElse Not MusicAllList.Any() OrElse Not MusicWaitingList.Any() Then MusicListInit(False)
'出列下一个音乐,如果出列结束则生成新列表
DequeueNextMusicAddress = MusicWaitingList(0)
MusicWaitingList.RemoveAt(0)
If MusicWaitingList.Any() Then
DequeueNextMusicAddress = MusicWaitingList(0)
MusicWaitingList.RemoveAt(0)
Else
DequeueNextMusicAddress = Nothing
End If
If Not MusicWaitingList.Any() Then MusicListInit(False, DequeueNextMusicAddress)
End Function
@@ -60,44 +65,45 @@
''' 刷新背景音乐按钮 UI 与设置页 UI。
''' </summary>
Private Sub MusicRefreshUI()
RunInUi(Sub()
Try
RunInUi(
Sub()
Try
If Not MusicAllList.Any() Then
'无背景音乐
FrmMain.BtnExtraMusic.Show = False
If Not MusicAllList.Any() Then
'无背景音乐
FrmMain.BtnExtraMusic.Show = False
Else
'有背景音乐
FrmMain.BtnExtraMusic.Show = True
Dim ToolTipText As String
If MusicState = MusicStates.Pause Then
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
FrmMain.BtnExtraMusic.LogoScale = 0.8
ToolTipText = "已暂停:" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键恢复播放,右键播放下一曲。"
Else
'有背景音乐
FrmMain.BtnExtraMusic.Show = True
Dim ToolTipText As String
If MusicState = MusicStates.Pause Then
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
FrmMain.BtnExtraMusic.LogoScale = 0.8
ToolTipText = "已暂停:" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键恢复播放,右键播放下一曲。"
Else
ToolTipText += vbCrLf & "左键恢复播放,右键重新从头播放。"
End If
Else
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
FrmMain.BtnExtraMusic.LogoScale = 1
ToolTipText = "正在播放:" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键暂停,右键播放下一曲。"
Else
ToolTipText += vbCrLf & "左键暂停,右键重新从头播放。"
End If
End If
FrmMain.BtnExtraMusic.ToolTip = ToolTipText
ToolTipService.SetVerticalOffset(FrmMain.BtnExtraMusic, If(ToolTipText.Contains(vbLf), 10, 16))
ToolTipText += vbCrLf & "左键恢复播放,右键重新从头播放。"
End If
If FrmSetupUI IsNot Nothing Then FrmSetupUI.MusicRefreshUI()
Else
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
FrmMain.BtnExtraMusic.LogoScale = 1
ToolTipText = "正在播放:" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键暂停,右键播放下一曲。"
Else
ToolTipText += vbCrLf & "左键暂停,右键重新从头播放。"
End If
End If
FrmMain.BtnExtraMusic.ToolTip = ToolTipText
ToolTipService.SetVerticalOffset(FrmMain.BtnExtraMusic, If(ToolTipText.Contains(vbLf), 10, 16))
End If
If FrmSetupUI IsNot Nothing Then FrmSetupUI.MusicRefreshUI()
Catch ex As Exception
Log(ex, "刷新背景音乐 UI 失败", LogLevel.Feedback)
End Try
End Sub)
Catch ex As Exception
Log(ex, "刷新背景音乐 UI 失败", LogLevel.Feedback)
End Try
End Sub)
End Sub
''' <summary>
@@ -128,8 +134,12 @@
Hint("重新播放:" & GetFileNameFromPath(MusicCurrent), HintType.Finish)
Else
Dim Address As String = DequeueNextMusicAddress()
MusicStartPlay(Address)
Hint("正在播放:" & GetFileNameFromPath(Address), HintType.Finish)
If Address Is Nothing Then
Hint("没有可以播放的音乐!", HintType.Critical)
Else
MusicStartPlay(Address)
Hint("正在播放:" & GetFileNameFromPath(Address), HintType.Finish)
End If
End If
MusicRefreshUI()
End Sub
@@ -179,11 +189,15 @@
End If
Else
Dim Address As String = DequeueNextMusicAddress()
Try
MusicStartPlay(Address, IsFirstLoad)
If ShowHint Then Hint("背景音乐已刷新:" & GetFileNameFromPath(Address), HintType.Finish, False)
Catch
End Try
If Address Is Nothing Then
If ShowHint Then Hint("没有可以播放的音乐!", HintType.Critical)
Else
Try
MusicStartPlay(Address, IsFirstLoad)
If ShowHint Then Hint("背景音乐已刷新:" & GetFileNameFromPath(Address), HintType.Finish, False)
Catch
End Try
End If
End If
MusicRefreshUI()
@@ -195,6 +209,7 @@
''' 开始播放音乐。
''' </summary>
Private Sub MusicStartPlay(Address As String, Optional IsFirstLoad As Boolean = False)
If Address Is Nothing Then Return
Log("[Music] 播放开始:" & Address)
MusicCurrent = Address
RunInNewThread(Sub() MusicLoop(IsFirstLoad), "Music", ThreadPriority.BelowNormal)
@@ -280,22 +295,28 @@
'当前音乐已播放结束,继续下一曲
If CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped AndAlso MusicAllList.Any Then MusicStartPlay(DequeueNextMusicAddress)
Catch ex As Exception
Log("[Music] 播放音乐失败的文件完整路径:" & MusicCurrent)
Log(ex, "播放音乐出现内部错误(" & MusicCurrent & ")", LogLevel.Developer)
If TypeOf ex Is NAudio.MmException AndAlso (ex.Message.Contains("NoDriver") OrElse ex.Message.Contains("BadDeviceId")) Then
Hint("由于音频设备变更,音乐播放功能在重启 PCL 后才能恢复!", HintType.Critical)
Thread.Sleep(1000000000)
End If
If ex.Message.Contains("Got a frame at sample rate") OrElse ex.Message.Contains("does not support changes to") Then
Hint("播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & "):PCL 不支持播放音频属性在中途发生变化的音乐", HintType.Critical)
ElseIf Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) Then
ElseIf Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) OrElse
ex.Message.Contains("0xC00D36C4") Then '#5096:不支持给定的 URL 的字节流类型。 (异常来自 HRESULT:0xC00D36C4)
Hint("播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & "):PCL 可能不支持此音乐格式,请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Critical)
Else
Log(ex, "播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & ")", LogLevel.Hint)
End If
Thread.Sleep(1000)
'将播放错误的音乐从列表中移除
MusicAllList.Remove(MusicCurrent)
MusicWaitingList.Remove(MusicCurrent)
MusicRefreshUI()
'等待 2 秒后继续播放
Thread.Sleep(2000)
If TypeOf ex Is FileNotFoundException Then
MusicRefreshPlay(True, IsFirstLoad)
ElseIf MusicAllList.Count > 1 Then
Else
MusicStartPlay(DequeueNextMusicAddress(), IsFirstLoad)
End If
Finally
+19 -13
View File
@@ -8,8 +8,12 @@ Friend Module ModSecret
#Region "杂项"
'在开源内容的注册表键与普通内容的注册表键隔离
'在开源版的注册表与常规版的注册表隔离,以防数据冲突
Public Const RegFolder As String = "PCLDebug"
'用于微软登录的 ClientId
Public Const OAuthClientId As String = ""
'CurseForge API Key
Public Const CurseForgeAPIKey As String = ""
Friend Sub SecretOnApplicationStart()
'提升 UI 线程优先级
@@ -41,8 +45,9 @@ Friend Module ModSecret
Environment.[Exit](Result.Cancel)
End If
'开源版本提示
MyMsgBox($"该版本中不包含以下特性:
- CurseForge 查询:需要 API Key(你可以申请一个,然后添加到 SecretHeadersSign 方法中)
MyMsgBox($"该版本中无法使用以下特性:
- CurseForge API 调用:需要你自行申请 API Key,然后添加到 ModSecret.vb 的开头
- 正版登录:需要你自行申请 Client ID,然后添加到 ModSecret.vb 的开头
- 更新与联网通知:避免滥用隐患
- 主题切换:这是需要赞助解锁的纪念性质的功能,别让赞助者太伤心啦……
- 百宝箱:开发早期往里面塞了些开发工具,整理起来太麻烦了", "开源版本说明")
@@ -89,35 +94,36 @@ Friend Module ModSecret
#Region "网络鉴权"
Friend Function SecretCdnSign(UrlWithMark As String)
'只处理以 {CDN} 结尾的链接
If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark
Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20")
End Function
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Client As CookieWebClient, Optional UseBrowserUserAgent As Boolean = False)
If ApplicationStartTick < 1 Then Return '禁止在没有运行程序的情况下通过反射调用
If UseBrowserUserAgent Then
Friend Sub SecretHeadersSign(Url As String, ByRef Client As WebClient, Optional UseBrowserUserAgent As Boolean = False)
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Client.Headers("User-Agent") = "LogStatistic" '#4951
ElseIf UseBrowserUserAgent Then
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode
End If
Client.Headers("Referer") = "http://" & VersionCode & ".pcl2.server/"
'如果你有 CurseForge API Key,请添加到 Headers 中,以恢复对 CurseForge 的访问
Client.Headers("Referer") = "http://" & VersionCode & ".pcl2.open.server/"
If Url.Contains("api.curseforge.com") Then Client.Headers("x-api-key") = CurseForgeAPIKey
End Sub
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Request As HttpWebRequest, Optional UseBrowserUserAgent As Boolean = False)
If ApplicationStartTick < 1 Then Return '禁止在没有运行程序的情况下通过反射调用
If UseBrowserUserAgent Then
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Request.UserAgent = "LogStatistic" '#4951
ElseIf UseBrowserUserAgent Then
Request.UserAgent = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Request.UserAgent = "PCL2/" & VersionStandardCode
End If
Request.Referer = "http://" & VersionCode & ".pcl2.server/"
'如果你有 CurseForge API Key,请添加到 Headers 中,以恢复对 CurseForge 的访问
Request.Referer = "http://" & VersionCode & ".pcl2.open.server/"
If Url.Contains("api.curseforge.com") Then Request.Headers("x-api-key") = CurseForgeAPIKey
End Sub
#End Region