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

2.8.7

Browse Source
This commit is contained in:
龙腾猫跃
2024-09-24 17:04:14 +08:00
parent 30bc43bdb5
commit b5c9736918
39 changed files with 932 additions and 747 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb
+64 -57
View File
@@ -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
@@ -417,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
@@ -536,7 +542,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
@@ -944,30 +950,30 @@ Retry:
Dim CurseForgeFailed As Boolean = False
If CurseForgeUrl IsNot Nothing Then
CurseForgeThread = RunInNewThread(
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")
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 线程
@@ -975,32 +981,32 @@ Retry:
Dim ModrinthFailed As Boolean = False
If ModrinthUrl IsNot Nothing Then
ModrinthThread = RunInNewThread(
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))
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 = -1 '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
'等待线程结束
@@ -1470,7 +1476,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)
@@ -1490,10 +1496,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 列表
Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb
+55 -25
View File
@@ -21,12 +21,7 @@
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)
@@ -56,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 "下载支持库文件"
@@ -69,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))("分析资源文件索引地址",
@@ -121,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})
@@ -1087,29 +1082,46 @@
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。
''' 调用 NetGetCodeByRequestOnce。
''' 调用 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")
'UNDONE: 受 #4811 影响
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
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)(McimUrl, 35))
Case Else
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)
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
@@ -1119,28 +1131,46 @@
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理。
''' 调用 NetRequestOnce。
''' 调用 NetRequest。
''' </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
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")
'UNDONE: 受 #4811 影响
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
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)(McimUrl, 35))
Case Else
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, Headers:=Headers)
Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000)
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+141 -243
View File
@@ -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
'正式加载
@@ -104,7 +107,7 @@ 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},
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.com/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 还算好用的话，也可以考虑赞助一下作者……一点心意也行……" & vbCrLf &
"毕竟一个人开发也不容易（悲）……",
"求赞助啦……", "这就赞助！", "但是我拒绝") = 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 2, 5, 10, 15, 20, 40, 60, 80, 100, 125, 150, 175, 200, 250, 300, 350, 400, 500, 600, 700, 800, 900, 1000, 1200, 1400, 1600, 1800, 2000
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
@@ -487,58 +501,56 @@ 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)
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
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, ClientId)
OAuthTokens = MsLoginStep1New(Data)
Else
'有 RefreshToken
OAuthTokens = MsLoginStep2(Input.OAuthRefreshToken, True, ClientId)
OAuthTokens = MsLoginStep1Refresh(Input.OAuthRefreshToken) '要求重新打开登录网页认证
If OAuthTokens(0) = "Relogin" Then GoTo Relogin
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
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)
@@ -550,11 +562,11 @@ Relogin:
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))
@@ -821,179 +833,61 @@ LoginFinish:
End Try
End Function
'微软登录步骤 1：打开网页认证，获取 OAuth Code
Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
McLaunchLog("开始微软登录步骤 1")
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
End Function
'微软登录步骤 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
'微软登录步骤 2：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
Private Function MsLoginStep2(Code As String, IsRefresh As Boolean, ClientId As String, Optional ExpiresIn As String = "900") As String()
McLaunchLog("开始微软登录步骤 2（" & If(IsRefresh, "", "非") & "刷新登录）")
'初始请求
McLaunchLog("开始微软登录步骤 1/6（原始登录）")
Dim PrepareJson As JObject = GetJson(NetRequestMulty("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", 2))
McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString)
Dim Request As String
If IsRefresh Then
Request = "grant_type=refresh_token" & "&" &
"client_id=" & ClientId & "&" &
"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=" & ClientId & "&" &
"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)
'弹窗
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
Hint("验证超时，请尝试重新验证！")
Return {"Cancel", ""}
If TypeOf Converter.Result Is Exception Then
Throw CType(Converter.Result, Exception)
Else
Return Converter.Result
End If
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))
'微软登录步骤 1，刷新登录：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
Private Function MsLoginStep1Refresh(Code As String) As String()
McLaunchLog("开始微软登录步骤 1/6（刷新登录）")
' '从这里开始直到步骤 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 Result As String
Try
Result = NetRequestMulty("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
Return {"Relogin", ""}
Else
Throw
End If
End Try
' 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 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
' 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")
'微软登录步骤 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 & """
""RpsTicket"": """ & If(AccessToken.StartsWithF("d="), "", "d=") & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
@@ -1004,9 +898,9 @@ LoginFinish:
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"": {
@@ -1056,9 +950,9 @@ LoginFinish:
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
@@ -1081,9 +975,9 @@ LoginFinish:
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}})
Try
@@ -1100,9 +994,9 @@ LoginFinish:
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
@@ -1447,8 +1341,12 @@ LoginFinish:
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
@@ -2148,18 +2046,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
'执行自定义命令
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+100 -114
View File
@@ -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,11 +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
Log($"[Minecraft] 传入的版本 json 文件内容（共 {Text.Length} 字符，最多输出前 5000 字符）：{vbCrLf}{Text.Substring(0, 5000)}")
Throw New Exception("版本 json 不规范（" & If(Name, "null") & "）", ex)
Throw New Exception("初始化版本 JSON 时失败（" & If(Name, "null") & "）", ex)
End Try
Try
'处理 JumpLoader
@@ -1030,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
@@ -1946,17 +1950,13 @@ OnLoaded:
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
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取统一通行证下载信息")
@@ -1966,14 +1966,13 @@ OnLoaded:
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
'校验文件
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
@@ -1982,45 +1981,59 @@ OnLoaded:
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
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)
@@ -2159,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
@@ -2238,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
Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb
+17 -19
View File
@@ -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
@@ -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)
@@ -852,7 +853,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 +862,7 @@ Finished:
End If
Catch ex As Exception
Log(ex, "读取本地 Mod 信息缓存失败，已重置")
Cache = New JObject
End Try
Cache("version") = LocalModCacheVersion
@@ -886,7 +888,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 +903,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 +926,6 @@ Finished:
End Try
End Sub
'联网加载 Mod 详情
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
@@ -944,7 +945,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(
@@ -979,7 +980,6 @@ Finished:
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
@@ -1005,9 +1005,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
@@ -1023,7 +1023,7 @@ Finished:
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Next
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
If Not CurseForgeRaw.Any() Then Exit Sub
@@ -1046,7 +1046,7 @@ Finished:
'步骤 3：获取工程信息
If Not CurseForgeMapping.Any() Then Exit Sub
Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST",
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
$"{{""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
@@ -1055,7 +1055,6 @@ Finished:
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,10 +1065,9 @@ Finished:
Dim NewestVersion As String = Nothing
Dim NewestFileIds As New List(Of Integer)
For Each IndexEntry In ProjectJson("latestFilesIndexes")
If IndexEntry("modLoader") Is Nothing OrElse Not IndexEntry("modLoader").HasValues OrElse '镜像源会返回一个值为 null 的键
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
@@ -1114,9 +1112,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
@@ -1131,7 +1129,7 @@ Finished:
Log($"[Mod] 联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Exit Sub
For Each Entry In Mods
Entry.CompLoaded = SucceedThreadCount = 2
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)))
Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb
+36 -36
View File
@@ -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
'强制关闭
Plain Craft Launcher 2/Modules/Minecraft/MyCompItem.xaml.vb
-6
View File
@@ -55,12 +55,6 @@ 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
+14 -17
View File
@@ -27,27 +27,24 @@
<Image x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" />
</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"
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"
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 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" />
<ColumnDefinition Width="1*" />
<ColumnDefinition Width="Auto" x:Name="ColumnSubtitle" />
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" x:Name="ColumnExtend" />
</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>-->
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" 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 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" />
</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">
Plain Craft Launcher 2/Modules/Minecraft/MyLocalModItem.xaml.vb
+23 -15
View File
@@ -14,6 +14,7 @@ Public Class MyLocalModItem
Set(value As String)
If _Logo = value OrElse value Is Nothing Then Exit Property
_Logo = value
If ModeDebug AndAlso Not _Logo = PathImage & "Icons/NoIcon.png" Then Log($"[LocalModItem] Mod {Title} 的图标：{value}")
Dim FileAddress = PathTemp & "CompLogo\" & GetHash(_Logo) & ".png"
Try
If _Logo.StartsWithF("http", True) Then
@@ -52,17 +53,11 @@ 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 图标，所以重试时不再缩小
If Url.Contains("/256/256/") AndAlso GetPixelSize(1) <= 1.25 AndAlso Not Retried Then '#3075：部分 Mod 不存在 64x64 图标，所以重试时不再缩小
Url = Url.Replace("/256/256/", "/64/64/")
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()
@@ -107,7 +102,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
@@ -120,12 +115,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
@@ -430,7 +425,7 @@ RetryStart:
NewDescription = GetFileNameWithoutExtentionFromPath(Entry.Path)
Case McMod.McModState.Disabled
NewDescription = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", ""))
Case Else 'McMod.McModState.Unavaliable
Case Else 'McMod.McModState.Unavailable
NewDescription = GetFileNameFromPath(Entry.Path)
End Select
If Entry.Comp IsNot Nothing Then
@@ -461,7 +456,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
@@ -538,4 +533,17 @@ RetryStart:
FrmVersionMod.UpdateMods({Entry})
End Sub
'自适应（#4465）
Private Sub PanTitle_SizeChanged(sender As Object, e As SizeChangedEventArgs) Handles PanTitle.SizeChanged
If ColumnExtend.Width.IsStar AndAlso ColumnExtend.ActualWidth < 0.5 Then
'压缩 Subtitle
ColumnSubtitle.Width = New GridLength(1, GridUnitType.Star)
ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
ElseIf Not ColumnExtend.Width.IsStar AndAlso ColumnSubtitle.ActualWidth > LabSubtitle.ActualWidth + 10 Then
'向右展开 Subtitle
ColumnSubtitle.Width = GridLength.Auto
ColumnExtend.Width = New GridLength(1, GridUnitType.Star)
End If
End Sub
End Class