InfStarMC/PCL-ISE
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Merge branch 'main' into datapacks

Browse Source
This commit is contained in:
Pigeon0v0
2024-09-22 10:16:53 +08:00
committed by GitHub
parent 9d3be21090 49fe40662f
commit d1eac50d15
57 changed files with 3234 additions and 1768 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Base/ModBase.vb
+60 -74
View File
@@ -11,12 +11,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.8.3" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.3." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.8.6" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.6." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 332 'Release
Public Const VersionCode As Integer = 336 'Release
#Else
Public Const VersionCode As Integer = 331 'Snapshot
Public Const VersionCode As Integer = 335 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -80,10 +80,6 @@ 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().Where(Function(p) Directory.Exists(p)).First.ToUpper.First & ":\" '#3799
@@ -700,7 +696,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
@@ -774,10 +770,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
@@ -787,17 +783,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
@@ -822,50 +826,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>
@@ -895,21 +888,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 类型
@@ -1108,8 +1091,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()
@@ -1587,14 +1568,14 @@ RetryDir:
''' 获取处于两个子字符串之间的部分。
''' 会裁切尽可能多的内容：匹配开始使用 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
@@ -1655,10 +1636,15 @@ RetryDir:
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
'转义
@@ -2682,7 +2668,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 &
Plain Craft Launcher 2/Modules/Base/ModLoader.vb
+18 -30
View File
@@ -566,38 +566,33 @@ Restart:
End Class
'任务栏进度条
Public LoaderTaskbarLock As New Object
Public LoaderTaskbar As New List(Of LoaderBase)
Public LoaderTaskbar As New Concurrent.ConcurrentBag(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
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.TryTake(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
Next
'更新平滑后的进度
If NewProgress <= 0 OrElse NewProgress >= 1 OrElse LoaderTaskbarProgress > NewProgress Then
LoaderTaskbarProgress = NewProgress
@@ -625,15 +620,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
Plain Craft Launcher 2/Modules/Base/ModNet.vb
+53 -59
View File
@@ -1,5 +1,4 @@
Imports System.Net
Imports PCL.ModNet
Public Module ModNet
Public Const NetDownloadEnd As String = ".PCLDownloading"
@@ -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 & "）")
@@ -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,7 +701,7 @@ RequestFinished:
''' <summary>
''' 所属的文件列表任务。
''' </summary>
Public Tasks As New List(Of LoaderDownload)
Public Tasks As New Concurrent.ConcurrentBag(Of LoaderDownload)
''' <summary>
''' 所有下载源。
@@ -881,7 +894,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
@@ -964,7 +976,7 @@ 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("gitcode.net") OrElse TargetUrl.Contains("github.com") OrElse TargetUrl.Contains("modrinth") Then Return Nothing
'寻找最大碎片
'FUTURE: 下载引擎重做，计算下载源平均链接时间和线程下载速度，按最高时间节省来开启多线程
Dim FilePieceMax As NetThread = Threads
@@ -980,10 +992,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
@@ -1140,11 +1150,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
@@ -1198,11 +1206,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
@@ -1307,7 +1313,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)
@@ -1344,7 +1350,7 @@ Retry:
'检查文件
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 +1403,8 @@ Retry:
''' </summary>
Public Sub Abort(CausedByTask As LoaderDownload)
'从特定任务中移除，如果它还属于其他任务，则继续下载
SyncLock LockTasks
Tasks.Remove(CausedByTask)
If Tasks.Any Then Exit Sub
End SyncLock
Tasks.TryTake(CausedByTask)
If Tasks.Any Then Exit Sub
'确认中断
SyncLock LockState
If State >= NetState.Finish Then Exit Sub
@@ -1430,11 +1434,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
@@ -1961,9 +1963,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 +1974,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
@@ -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
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
Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb
+22 -21
View File
@@ -288,7 +288,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("世界元素")
@@ -408,7 +409,7 @@
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("轻量")
'数据包
Case "adventure" : Tags.Add("冒险")
@@ -989,7 +990,7 @@ Retry:
Try
'获取工程列表
Log("[Comp] 开始从 CurseForge 获取工程列表：" & CurseForgeUrl)
Dim RequestResult As JObject = NetGetCodeByRequestRetry(CurseForgeUrl, IsJson:=True, Encode:=Encoding.UTF8)
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")
@@ -1004,7 +1005,7 @@ Retry:
Log($"[Comp] 从 CurseForge 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.CurseForgeOffset} 个，共 {Storage.CurseForgeTotal} 个）")
Catch ex As Exception
Log(ex, "从 CurseForge 获取工程列表失败")
Storage.CurseForgeTotal = Storage.CurseForgeOffset
Storage.CurseForgeTotal = -1 'Storage.CurseForgeOffset
[Error] = ex
CurseForgeFailed = True
End Try
@@ -1019,7 +1020,7 @@ Retry:
Sub()
Try
Log("[Comp] 开始从 Modrinth 获取工程列表：" & ModrinthUrl)
Dim RequestResult As JObject = NetGetCodeByRequestRetry(ModrinthUrl, IsJson:=True, Encode:=Encoding.UTF8)
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")
@@ -1037,7 +1038,7 @@ Retry:
Log($"[Comp] 从 Modrinth 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.ModrinthOffset} 个，共 {Storage.ModrinthTotal} 个）")
Catch ex As Exception
Log(ex, "从 Modrinth 获取工程列表失败")
Storage.ModrinthTotal = Storage.ModrinthOffset
Storage.ModrinthTotal = -1 'Storage.ModrinthOffset
[Error] = ex
ModrinthFailed = True
End Try
@@ -1063,7 +1064,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
@@ -1118,7 +1119,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
'如果有搜索文本，按关联度将结果排序
@@ -1126,7 +1127,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)}})
@@ -1295,7 +1296,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").
@@ -1329,11 +1332,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
@@ -1469,9 +1471,9 @@ Retry:
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)
@@ -1479,13 +1481,13 @@ Retry:
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")
ResultJsonArray = GetJson(DlModRequest("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")
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data")
End If
Else
'Modrinth
ResultJsonArray = NetGetCodeByRequestRetry($"https://api.modrinth.com/v2/project/{ProjectId}/version", Accept:="application/json", IsJson:=True)
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True)
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）
@@ -1499,11 +1501,10 @@ Retry:
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 的时候就添加了缓存
Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb
+10 -6
View File
@@ -844,8 +844,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 +856,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
'获取文件路径
@@ -881,7 +882,10 @@ NextStack:
FileName = "游戏崩溃前的输出.txt"
End Select
If File.Exists(OutputFile) Then
WriteFile(TempFolder & "Report\" & FileName, SecretFilter(ReadFile(OutputFile), If(FileName = "启动脚本.bat", "F", "*")))
Dim FileEncoding As Encoding = GetEncoding(ReadFileBytes(OutputFile))
WriteFile(TempFolder & "Report\" & FileName,
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
Encoding:=FileEncoding)
End If
Next
'导出报告
Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb
+105 -14
View File
@@ -836,8 +836,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)
@@ -1083,29 +1083,120 @@
#End Region
#Region "DlMod | Mod 镜像源请求"
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。
''' 调用 NetGetCodeByRequestOnce。
''' </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")
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Case 1
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 35))
Case Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 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 镜像源的请求进行处理。
''' 调用 NetRequestOnce。
''' </summary>
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String, Optional Headers As Dictionary(Of String, String) = Nothing) 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")
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
Case 1
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 35))
Case Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 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, Headers:=Headers)
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
Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb
+6 -4
View File
@@ -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
@@ -550,7 +552,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 不含特殊引用")
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+208 -119
View File
@@ -225,7 +225,7 @@ NextInner:
"如果觉得 PCL 还算好用的话，也可以考虑赞助一下作者……一点心意也行……" & vbCrLf &
"毕竟一个人开发也不容易（悲）……",
"求赞助啦……", "这就赞助！", "但是我拒绝") = 1 Then
OpenWebsite("https://afdian.net/a/LTCat")
OpenWebsite("https://afdian.com/a/LTCat")
End If
End Select
End Sub, "Donate")
@@ -506,18 +506,21 @@ NextInner:
End If
'尝试登录
Dim OAuthTokens As String()
Dim ClientId As String = ""
If Input.OAuthRefreshToken = "" Then
'无 RefreshToken
Relogin:
Dim OAuthCode As String = MsLoginStep1(Data)
If OAuthCode = "Cancel" Then Exit Sub
If Data.IsAborted Then Throw New ThreadInterruptedException
Data.Progress = 0.2
OAuthTokens = MsLoginStep2(OAuthCode, False)
OAuthTokens = MsLoginStep2(OAuthCode, False, ClientId)
Else
'有 RefreshToken
OAuthTokens = MsLoginStep2(Input.OAuthRefreshToken, True)
OAuthTokens = MsLoginStep2(Input.OAuthRefreshToken, True, ClientId)
End If
'要求重新打开登录网页认证
If OAuthTokens(0) = "Cancel" Then Exit Sub
If OAuthTokens(0) = "Relogin" Then GoTo Relogin
Data.Progress = 0.35
If Data.IsAborted Then Throw New ThreadInterruptedException
@@ -668,6 +671,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 +695,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 +726,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 +786,16 @@ 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 Throw New Exception("$登录失败：" & ErrorMessage)
End If
'通用关键字检测
If AllMessage.Contains("403") Then
Select Case Data.Input.Type
Case McLoginType.Auth
@@ -808,111 +824,180 @@ LoginFinish:
'微软登录步骤 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("$$")
Else
Return RegexSeek(Result, "(?<=code\=)[^&]+")
End If
Hint("网页登录成功，你可以关闭浏览器啦！", HintType.Finish)
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("$$")
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 RegexSeek(Result, "(?<=code\=)[^&]+")
End If
End Function
'微软登录步骤 2：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
Private Function MsLoginStep2(Code As String, IsRefresh As Boolean) As String()
Private Function MsLoginStep2(Code As String, IsRefresh As Boolean, ClientId As String, Optional ExpiresIn As String = "900") As String()
McLaunchLog("开始微软登录步骤 2（" & If(IsRefresh, "", "非") & "刷新登录）")
Dim Request As String
If IsRefresh Then
Request = "client_id=00000000402b5328" & "&" &
Request = "grant_type=refresh_token" & "&" &
"client_id=" & ClientId & "&" &
"device_code=" & Code & "&" &
"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")
"scope=XboxLive.signin%20offline_access"
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")
Request = "grant_type=urn:ietf:params:oauth:grant-type:device_code" & "&" &
"client_id=" & ClientId & "&" &
"device_code=" & Code & "&" &
"scope=XboxLive.signin%20offline_access"
End If
Dim Result As String
Try
Result = NetRequestMulty("https://login.live.com/oauth20_token.srf", "POST", Request, "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
Return {"Relogin", ""}
Else
Throw
Dim stopwatch As Stopwatch = Stopwatch.StartNew()
While stopwatch.Elapsed < TimeSpan.FromSeconds(ExpiresIn)
Try
Result = NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/token", "POST", Request, "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
Return {"Relogin", ""}
ElseIf ex.Message.Contains("authorization_declined") Then
Hint("你拒绝了 PCL2 的访问权限申请，验证过程被中断！")
Return {"Cancel", ""}
ElseIf ex.Message.Contains("expired_token") Then
Hint("Token 已过期，请尝试重新验证！")
Exit While
ElseIf ex.Message.Contains("AADSTS70016") Then
Continue While
Else
Throw
End If
End Try
If Result IsNot Nothing Then
Dim ResultJson As JObject = GetJson(Result)
Dim AccessToken As String = ResultJson("access_token").ToString
Dim RefreshToken As String = ResultJson("refresh_token").ToString
Return {AccessToken, RefreshToken}
End If
End Try
Thread.Sleep(1000)
End While
Hint("验证超时，请尝试重新验证！")
Return {"Cancel", ""}
Dim ResultJson As JObject = GetJson(Result)
Dim AccessToken As String = ResultJson("access_token").ToString
Dim RefreshToken As String = ResultJson("refresh_token").ToString
Return {AccessToken, RefreshToken}
End Function
''微软登录步骤 1：获取 DeviceCode 并显示验证提示
''https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code
'Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
' McLaunchLog("开始微软登录步骤 1：获取验证信息")
' Dim PrepareJson As JObject = GetJson(NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
' $"client_id={OAuthClientId}&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded", 2))
' '从这里开始直到步骤 2 结束都没有 Review
' '参考：https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code
' If MyMsgBox("请在打开的网页里输入 PCL2 提供的设备代码（会自动复制到剪贴板）。" & vbCrLf &
' "设备代码有时效性，若操作时间过长需要重新进行登录流程。", "正版验证确认", "继续", "取消") <> 1 Then
' Return "Cancel"
' End If
' Dim DeviceCode As String = PrepareJson("device_code")
' Dim UserCode As String = PrepareJson("user_code")
' Dim VerifyUri As String = PrepareJson("verification_uri")
' 'ResultJson("expires_in")
' ClipboardSet(UserCode)
' OpenWebsite(VerifyUri)
' Dim MsgBoxValue As String = ""
' While MsgBoxValue IsNot "1"
' MsgBoxValue = MyMsgBox("本次验证的设备代码为：" & UserCode & vbCrLf & vbCrLf & "你也可以在任意设备上打开下列网址进行验证：" & vbCrLf & VerifyUri & vbCrLf & vbCrLf & "在验证完成后，你可以直接关闭这个弹窗，PCL2 会自动完成接下来的流程。", "正版验证", "关闭", "复制网址", "复制设备代码").ToString
' If MsgBoxValue = "2" Then
' ClipboardSet(VerifyUri)
' Continue While
' ElseIf MsgBoxValue = "3" Then
' ClipboardSet(UserCode)
' Continue While
' ElseIf MsgBoxValue = "1" Then
' Exit While
' End If
' End While
' Return DeviceCode
'End Function
''微软登录步骤 2：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
'Private Function MsLoginStep2(Code As String, IsRefresh As Boolean, Optional ExpiresIn As String = "900") As String()
' McLaunchLog("开始微软登录步骤 2（" & If(IsRefresh, "", "非") & "刷新登录）")
' Dim Request As String
' If IsRefresh Then
' Request = "grant_type=refresh_token" & "&" &
' "client_id=" & OAuthClientId & "&" &
' "device_code=" & Code & "&" &
' "refresh_token=" & Uri.EscapeDataString(Code) & "&" &
' "scope=XboxLive.signin%20offline_access"
' Else
' Request = "grant_type=urn:ietf:params:oauth:grant-type:device_code" & "&" &
' "client_id=" & OAuthClientId & "&" &
' "device_code=" & Code & "&" &
' "scope=XboxLive.signin%20offline_access"
' End If
' Dim Result As String
' Dim stopwatch As Stopwatch = Stopwatch.StartNew()
' While stopwatch.Elapsed < TimeSpan.FromSeconds(ExpiresIn)
' Try
' Result = NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/token", "POST", Request, "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
' Return {"Relogin", ""}
' ElseIf ex.Message.Contains("authorization_declined") Then
' Hint("你拒绝了 PCL2 的访问权限申请，验证过程被中断！")
' Return {"Cancel", ""}
' ElseIf ex.Message.Contains("expired_token") Then
' Hint("Token 已过期，请尝试重新验证！")
' Exit While
' ElseIf ex.Message.Contains("AADSTS70016") Then
' Continue While
' Else
' Throw
' End If
' End Try
' If Result IsNot Nothing Then
' Dim ResultJson As JObject = GetJson(Result)
' Dim AccessToken As String = ResultJson("access_token").ToString
' Dim RefreshToken As String = ResultJson("refresh_token").ToString
' Return {AccessToken, RefreshToken}
' End If
' Thread.Sleep(1000)
' End While
' Hint("验证超时，请尝试重新验证！")
' Return {"Cancel", ""}
'End Function
'微软登录步骤 3：从 OAuth AccessToken 获取 XBLToken
Private Function MsLoginStep3(AccessToken As String) As String
McLaunchLog("开始微软登录步骤 3")
Dim Request As String = "{
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}"
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}" 'TODO: 新版登录改为 ""RpsTicket"": ""d=" & AccessToken & """
Dim Result As String = NetRequestMulty("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
Dim ResultJson As JObject = GetJson(Result)
@@ -1069,7 +1154,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 +1284,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 +1311,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("$$")
@@ -1280,20 +1365,28 @@ SystemBrowser:
Dim WrapperPath As String = BaseDir & "\JavaWrapper.jar"
Log("[Java] 选定的 Java Wrapper 路径：" & WrapperPath)
SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突
Dim IsWrapperWritten As Boolean = WriteFile(WrapperPath, GetResources("JavaWrapper"))
If Not IsWrapperWritten AndAlso File.Exists(WrapperPath) Then
'以下为 #4243 的修复，因为未知原因 Java Wrapper 可能变为只读文件
Log("[Java] Java Wrapper 文件释放失败，但文件已存在，将在删除后尝试重新生成", LogLevel.Debug)
Try
File.Delete(WrapperPath)
IsWrapperWritten = WriteFile(WrapperPath, GetResources("JavaWrapper"))
Catch ex As Exception
Log(ex, "Java Wrapper 文件重新释放失败，将尝试更换文件名重新生成")
WrapperPath = BaseDir & "\JavaWrapper2.jar"
IsWrapperWritten = WriteFile(WrapperPath, GetResources("JavaWrapper"))
End Try
End If
If Not IsWrapperWritten Then Throw New FileNotFoundException("释放 Java Wrapper 失败，请查看 PCL 日志查找详细信息")
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 = BaseDir & "\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
Return WrapperPath
End Function
@@ -1785,7 +1878,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1816,7 +1908,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1892,16 +1983,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
@@ -2143,6 +2230,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
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+6 -4
View File
@@ -565,6 +565,7 @@ Recheck:
Log(ex, "合并版本依赖项 json 失败（" & If(InheritVersion, "null").ToString & "）")
End Try
Catch ex As Exception
Log($"[Minecraft] 传入的版本 json 文件内容（共 {Text.Length} 字符，最多输出前 5000 字符）：{vbCrLf}{Text.Substring(0, 5000)}")
Throw New Exception("版本 json 不规范（" & If(Name, "null") & "）", ex)
End Try
Try
@@ -665,7 +666,7 @@ Recheck:
Try
Dim JsonObjCheck = JsonObject
Catch ex As Exception
Log(ex, "版本 json 可用性检查失败（" & Path & "）")
Log(ex, "版本 JSON 可用性检查失败（" & Path & "）")
JsonText = ""
JsonObject = Nothing
Info = ex.Message
@@ -2026,8 +2027,9 @@ OnLoaded:
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 +2051,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)
Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb
+15 -12
View File
@@ -707,7 +707,7 @@ Finished:
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
@@ -924,7 +924,7 @@ Finished:
End Try
End Sub
'联网加载 Mod 详情
Private Const LocalModCacheVersion As Integer = 5
Private Const LocalModCacheVersion As Integer = 6
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
@@ -952,7 +952,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,7 +973,7 @@ 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
@@ -985,7 +985,7 @@ Finished:
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
@@ -1022,7 +1022,7 @@ 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",
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 的对应关系
@@ -1045,12 +1045,12 @@ 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",
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 返回的内容有漏
@@ -1066,7 +1066,8 @@ 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 Not IndexEntry("modLoader").HasValues OrElse '镜像源会返回一个值为 null 的键
ModLoaders.Single <> IndexEntry("modLoader").ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
Dim IndexVersion As String = IndexEntry("gameVersion")
If McVersion <> IndexVersion Then Continue For 'MC 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的，所以只需取第一个；如果需要检查多个 releaseType 下的文件，将 > -1 改为 = 1，但这应当并不会获取到更新的文件
@@ -1087,7 +1088,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
@@ -1129,11 +1130,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 会在两个网站间横跳
For Each Entry In Mods
Entry.CompLoaded = SucceedThreadCount = 2
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
Private Function GetTargetModLoaders() As List(Of CompModLoaderType)
Dim ModLoaders As New List(Of CompModLoaderType)
@@ -1275,4 +1278,4 @@ Finished:
End Function
#End If
End Module
End Module
Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb
+137 -139
View File
@@ -12,9 +12,10 @@ Public Module ModModpack
RunInThread(Sub() ModpackInstall(File))
End Sub
''' <summary>
''' 安装一个给定的整合包文件，返回是否安装成功。必须在工作线程执行。
''' 安装一个给定的整合包文件，返回启动的安装加载器，如果未成功启动则返回 Nothing。
''' 必须在工作线程执行。
''' </summary>
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True, Optional Logo As String = Nothing) As Boolean
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True, Optional Logo As String = Nothing) As LoaderCombo(Of String)
Log("[ModPack] 整合包安装请求：" & If(File, "null"))
Dim Archive As ZipArchive = Nothing
Dim ArchiveBaseFolder As String = ""
@@ -45,6 +46,7 @@ Public Module ModModpack
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))
@@ -55,54 +57,52 @@ 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 整合包
Next
Catch ex As Exception
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
Log(ex, "打开整合包文件失败", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
ElseIf File.EndsWithF(".rar", True) Then
Log(ex, "PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
Else
Log(ex, "打开整合包文件失败，文件可能损坏或为不支持的压缩包格式", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
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)
Return InstallPackCompress(File, ArchiveBaseFolder)
Case Else
If ShowHint Then
Hint("未能识别该整合包的种类，无法安装！", HintType.Critical)
Else
Log("[ModPack] 未能识别该整合包的种类，无法安装！")
End If
Return False
Return Nothing
End Select
Return True
Catch ex As Exception
Log(ex, "准备安装整合包失败", LogLevel.Feedback)
Return False
Return Nothing
Finally
If Archive IsNot Nothing Then Archive.Dispose()
End Try
@@ -159,7 +159,8 @@ 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
@@ -167,18 +168,18 @@ Retry:
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
Log(ex, "CurseForge 整合包安装信息存在问题", LogLevel.Hint)
Return Nothing
End Try
'获取版本名
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 Return Nothing
End If
'获取 Mod API 版本信息
@@ -191,7 +192,7 @@ Retry:
'Forge 指定
If Id.Contains("recommended") Then
Log("[ModPack] 该整合包版本过老，已不支持进行安装！", LogLevel.Hint)
Exit Sub
Return Nothing
End If
Try
Log("[ModPack] 整合包 Forge 版本：" & Id)
@@ -259,7 +260,7 @@ Retry:
'获取 Mod 下载信息
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
Sub(Task As LoaderTask(Of Integer, JArray))
Task.Output = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data")
Task.Output = GetJson(DlModRequest("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 版本")
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
@@ -319,7 +320,7 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 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})
@@ -350,14 +351,10 @@ 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)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -365,11 +362,11 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
End Sub
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
@@ -378,7 +375,7 @@ Retry:
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
Return Nothing
End Try
'获取 Mod API 版本信息
Dim MinecraftVersion As String = Nothing
@@ -400,42 +397,42 @@ Retry:
Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion)
Case "quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
Case Else
Hint($"无法安装整合包，其中出现了未知的 Mod 加载器 {Entry.Value}！", HintType.Critical)
Exit Sub
Return Nothing
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 Return Nothing
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))
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
'获取下载文件列表
Dim FileList As New List(Of NetFile)
For Each File In If(Json("files"), {})
@@ -452,8 +449,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
@@ -470,7 +469,7 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 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})
@@ -501,14 +500,10 @@ 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)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -516,25 +511,26 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Sub
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
Return Nothing
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 Return Nothing
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
@@ -555,7 +551,7 @@ Retry:
'构造加载器
If Json("gameVersion") Is Nothing Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
@@ -563,7 +559,7 @@ Retry:
.MinecraftName = Json("gameVersion").ToString
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json（副加载器）",
@@ -591,14 +587,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)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -607,10 +599,11 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
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
@@ -618,14 +611,14 @@ Retry:
PackInstance = ReadFile(Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open, Encoding.UTF8)
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
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 Return Nothing
'解压、配置设置文件
Dim InstallTemp As String = $"{PathTemp}PackInstall\{RandomInteger(0, 100000)}\"
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
@@ -685,7 +678,7 @@ Retry:
'构造版本安装请求
If PackJson("components") Is Nothing Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"}
For Each Component In PackJson("components")
@@ -702,12 +695,12 @@ Retry:
Request.FabricVersion = Component("version")
Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
End Select
Next
'构造加载器
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 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})
@@ -720,14 +713,10 @@ 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)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -735,10 +724,12 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
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
@@ -746,14 +737,17 @@ Retry:
Json = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
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
Dim ShowRibble As Boolean = VersionName Is Nothing
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 Return Nothing
End If
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
@@ -774,7 +768,7 @@ Retry:
'构造加载器
If Json("addons") Is Nothing Then
Hint("该整合包未提供游戏版本附加信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Addons As New Dictionary(Of String, String)
For Each Entry In Json("addons")
@@ -782,11 +776,11 @@ Retry:
Next
If Not Addons.ContainsKey("game") Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
If Addons.ContainsKey("quilt") Then
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
@@ -798,7 +792,7 @@ 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
If MergeLoaders Is Nothing Then Return Nothing
'构造 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})
@@ -811,14 +805,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)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -826,28 +816,36 @@ Retry:
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Function
'普通压缩包
Private Sub InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String)
Private Function InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String) As LoaderCombo(Of String)
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
If String.IsNullOrEmpty(TargetFolder) Then Return Nothing
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Return Nothing
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Return Nothing
'要求显示名称
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.IsNullOrWhiteSpace(NewName) Then Return Nothing
'解压
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()
UnpackFiles(TargetFolder, FileAddress, Nothing)
PageSelectLeft.AddFolder(TargetFolder, NewName, False) '加入文件夹列表
End Sub)
})
Loader.Start()
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Function
#End Region
Plain Craft Launcher 2/Modules/Minecraft/MyCompItem.xaml.vb
+6 -3
View File
@@ -18,9 +18,6 @@
'网络图片
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)
@@ -58,6 +55,12 @@ RetryStart:
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
If Url.EndsWithF("webp") Then
Log($"[Comp] Webp 格式转换：{LocalFileAddress}")
Dim dec = New Imazen.WebP.SimpleDecoder()
Dim picFile = File.ReadAllBytes(LocalFileAddress & DownloadEnd)
dec.DecodeFromBytes(picFile, picFile.Length).Save(LocalFileAddress & DownloadEnd)
End If
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
Plain Craft Launcher 2/Modules/Minecraft/MyLocalModItem.xaml.vb
+6 -3
View File
@@ -20,9 +20,6 @@ Public Class MyLocalModItem
'网络图片
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)
@@ -60,6 +57,12 @@ RetryStart:
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
If Url.EndsWithF("webp") Then
Log($"[Comp] Webp 格式转换：{LocalFileAddress}")
Dim dec = New Imazen.WebP.SimpleDecoder()
Dim picFile = File.ReadAllBytes(LocalFileAddress & DownloadEnd)
dec.DecodeFromBytes(picFile, picFile.Length).Save(LocalFileAddress & DownloadEnd)
End If
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
Plain Craft Launcher 2/Modules/ModMain.vb
+2
View File
@@ -799,6 +799,8 @@ NextFile:
Public Declare Function SetForegroundWindow Lib "user32" (hWnd As IntPtr) As Integer
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (hWnd As IntPtr, msg As UInteger, wParam As Long, lParam As Long) As Boolean
Public Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean
#End Region
Public DragControl = Nothing
Plain Craft Launcher 2/Modules/ModSecret.vb
+14 -10
View File
@@ -10,6 +10,8 @@ Friend Module ModSecret
'在开源内容的注册表键与普通内容的注册表键隔离
Public Const RegFolder As String = "PCLDebug"
'用于微软登录的 ClientId
Public Const OAuthClientId As String = ""
Friend Sub SecretOnApplicationStart()
'提升 UI 线程优先级
@@ -41,8 +43,9 @@ Friend Module ModSecret
Environment.[Exit](Result.Cancel)
End If
'开源版本提示
MyMsgBox($"该版本中不包含以下特性：
- CurseForge 查询：需要 API Key（你可以申请一个，然后添加到 SecretHeadersSign 方法中）
MyMsgBox($"该版本中无法使用以下特性：
- CurseForge API 调用：需要你自行申请 API Key，然后添加到 SecretHeadersSign 方法中
- 正版登录：需要你自行申请 Client ID，然后添加到 ModSecret.vb 的开头
- 更新与联网通知：避免滥用隐患
- 主题切换：这是需要赞助解锁的纪念性质的功能，别让赞助者太伤心啦……
- 百宝箱：开发早期往里面塞了些开发工具，整理起来太麻烦了", "开源版本说明")
@@ -89,34 +92,35 @@ 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("modrinth.com") Then '根据 #4334，不添加 PCL 的 UA 反而能正常访问
Client.Headers("User-Agent") = "Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
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/"
Client.Headers("Referer") = "http://" & VersionCode & ".pcl2.open.server/"
'如果你有 CurseForge API Key，请添加到 Headers 中，以恢复对 CurseForge 的访问
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("modrinth.com") Then '根据 #4334，不添加 PCL 的 UA 反而能正常访问
Request.UserAgent = "Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
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/"
Request.Referer = "http://" & VersionCode & ".pcl2.open.server/"
'如果你有 CurseForge API Key，请添加到 Headers 中，以恢复对 CurseForge 的访问
End Sub