diff --git a/.github/FUNDING.yml b/.github/FUNDING.yml index f4820c8..1a92a45 100644 --- a/.github/FUNDING.yml +++ b/.github/FUNDING.yml @@ -1,3 +1,3 @@ # These are supported funding model platforms -custom: ['https://afdian.com/a/LTCat'] +custom: ['https://meloong.com/afd/a/LTCat'] diff --git a/.github/ISSUE_TEMPLATE/bug1.yml b/.github/ISSUE_TEMPLATE/bug1.yml index 68cd2ba..af235f1 100644 --- a/.github/ISSUE_TEMPLATE/bug1.yml +++ b/.github/ISSUE_TEMPLATE/bug1.yml @@ -12,7 +12,7 @@ body: required: false - label: "**我已尝试使用 HMCL 启动，HMCL 没有出现问题。** 如果 HMCL 也无法启动就不是 PCL 导致的问题，请 **不要** 提交反馈。[下载 HMCL](https://hmcl.huangyuhui.net/download)" required: true - - label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" + - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" required: true - type: textarea id: "yml-2" diff --git a/.github/ISSUE_TEMPLATE/bug2.yml b/.github/ISSUE_TEMPLATE/bug2.yml index de636f0..0490f61 100644 --- a/.github/ISSUE_TEMPLATE/bug2.yml +++ b/.github/ISSUE_TEMPLATE/bug2.yml @@ -12,7 +12,7 @@ body: required: false - label: "我知晓大多数此类问题都是网络环境不佳导致的，但我确实认为我的问题可能是 PCL 导致的，和网络环境无关。" required: true - - label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" + - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" required: true - type: textarea id: "yml-2" diff --git a/.github/ISSUE_TEMPLATE/bug9.yml b/.github/ISSUE_TEMPLATE/bug9.yml index be20097..73980a7 100644 --- a/.github/ISSUE_TEMPLATE/bug9.yml +++ b/.github/ISSUE_TEMPLATE/bug9.yml @@ -8,7 +8,7 @@ body: label: "检查项" description: "请逐个检查下列项目，并勾选确认。" options: - - label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" + - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索，确认了这一 Bug 未被提交过。" required: true - type: textarea id: "yml-2" diff --git a/.github/ISSUE_TEMPLATE/ch.yml b/.github/ISSUE_TEMPLATE/ch.yml index 0ddd693..fc3ee5d 100644 --- a/.github/ISSUE_TEMPLATE/ch.yml +++ b/.github/ISSUE_TEMPLATE/ch.yml @@ -8,9 +8,9 @@ body: label: "检查项" description: "请逐个检查下列项目，并勾选确认。" options: - - label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索，确认了这一建议未被提交过。" + - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索，确认了这一建议未被提交过。" required: true - - label: "我已查看 [功能投票页面](https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/)，确认了这一建议未在投票列表中。" + - label: "我已查看 [功能投票页面](https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/)，确认了这一建议未在投票列表中。" required: true - type: textarea id: "yml-2" diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml index 082755e..3a6eed8 100644 --- a/.github/ISSUE_TEMPLATE/config.yml +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -1,14 +1,14 @@ blank_issues_enabled: false contact_links: - name: 主页预设反馈 - url: https://github.com/Hex-Dragon/PCL2/discussions/categories/自定义主页 + url: https://github.com/Meloong-Git/PCL/discussions/categories/自定义主页 about: 提交与预设的主页（设置 → 个性化 → 主页预设）中的具体内容相关的反馈 - name: 帮助文档反馈 url: https://github.com/LTCatt/PCL2Help/issues about: 提交与 PCL 帮助文档（更多 → 帮助）中的具体内容相关的反馈 - name: 提问 - url: https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E6%8F%90%E9%97%AE + url: https://github.com/Meloong-Git/PCL/discussions/new?category=%E6%8F%90%E9%97%AE about: 我想问一些 PCL 相关的问题…… - name: 讨论 - url: https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E8%AE%A8%E8%AE%BA + url: https://github.com/Meloong-Git/PCL/discussions/new?category=%E8%AE%A8%E8%AE%BA about: 我想讨论一些 PCL 相关的事情…… diff --git a/.github/ISSUE_TEMPLATE/feature.yml b/.github/ISSUE_TEMPLATE/feature.yml index e27452b..f434a0a 100644 --- a/.github/ISSUE_TEMPLATE/feature.yml +++ b/.github/ISSUE_TEMPLATE/feature.yml @@ -8,9 +8,9 @@ body: label: "检查项" description: "请逐个检查下列项目，并勾选确认。" options: - - label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索，确认了这一提案未被提交过。" + - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索，确认了这一提案未被提交过。" required: true - - label: "我已查看 [功能投票页面](https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/)，确认了这一提案未在投票列表中。" + - label: "我已查看 [功能投票页面](https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/)，确认了这一提案未在投票列表中。" required: true - label: "我知晓还没做的新功能真的太多了，忙不过来，所以新功能提案几乎不会被处理，也不建议再提交新功能提案 qwq……" required: true diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 5165cdb..b6de4af 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -51,8 +51,8 @@ jobs: - name: Replace run: | - (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public Const OAuthClientId As String = ""', 'Public Const OAuthClientId As String = "${{ secrets.CLIENT_ID }}"' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" - (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public Const CurseForgeAPIKey As String = ""', 'Public Const CurseForgeAPIKey As String = "${{ secrets.CURSEFORGE_API_KEY }}"' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" + (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")', 'Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "${{ secrets.CLIENT_ID }}")' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" + (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "")', 'Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "${{ secrets.CURSEFORGE_API_KEY }}")' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" (gc "Plain Craft Launcher 2\Modules\Base\ModBase.vb") -replace 'Public Const CommitHash As String = ""', 'Public Const CommitHash As String = "${{ github.sha }}"' | Out-File "Plain Craft Launcher 2\Modules\Base\ModBase.vb" - name: Build diff --git a/LICENCE b/LICENCE index f9e821b..ca7989e 100644 --- a/LICENCE +++ b/LICENCE @@ -31,8 +31,8 @@ 2、您的内容的名称必须以 Plain Craft Launcher (PCL) 开头，并在其后添加足以表现其由第三方修改的后缀。 　允许的示例：PCL 某服务器魔改版、PCL PR Collection、PCL (XX Bug Fix)、PCL XXX修改版。 　禁止的示例：PCL 某服务器特供版（暗示由官方提供）、PCL 3、PCL 手机版、PCL++、PCL Pro（这像是官方的后续作品）。 -3、在关于页面的首位给出龙腾猫跃的署名及对应的赞助链接，公开源代码，且继续使用本文件作为指南（可参考 CC BY-SC 协议）。 -4、软件若有 Minecraft 启动功能，则应实现与 McLaunchPrecheck 函数一致的 Minecraft 正版购买弹窗与赞助弹窗。 +3、在关于页面的首位给出龙腾猫跃的署名及对应的赞助链接，公开源代码，且继续使用本文件作为指南（可参考 CC BY-SA 协议）。 +4、软件若有 Minecraft 启动功能，则应实现与 McLaunchPrecheck 函数一致（或更激进）的 Minecraft 正版购买劝导与赞助劝导。 5、软件在 Windows 系统上运行时，不应有与 PCL 的赞助解锁功能类似的功能或表现。 　例如：界面的主要色相必须为蓝色（即使没有修改功能，改为其他色相也和需要赞助解锁的主题功能类似）。 @@ -44,6 +44,6 @@ 这些规则主要是为了阻止恶意的使用和 “山寨版” 的出现，常规、善意的使用都没啥问题的，放心吧！ 如果你只是参考了一小段代码，署个名就行啦，不用担心。 -如果对具体细节有疑问，欢迎在 https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E6%8F%90%E9%97%AE 发帖询问！ +如果对具体细节有疑问，欢迎在 https://github.com/Meloong-Git/PCL/discussions/new?category=%E6%8F%90%E9%97%AE 发帖询问！ 多谢大家啦！ diff --git a/Plain Craft Launcher 2/App.config b/Plain Craft Launcher 2/App.config index d464350..0e1a473 100644 --- a/Plain Craft Launcher 2/App.config +++ b/Plain Craft Launcher 2/App.config @@ -30,6 +30,10 @@ + + + + - \ No newline at end of file + diff --git a/Plain Craft Launcher 2/Application.xaml b/Plain Craft Launcher 2/Application.xaml index a24bad7..26d0ed6 100644 --- a/Plain Craft Launcher 2/Application.xaml +++ b/Plain Craft Launcher 2/Application.xaml @@ -1,6 +1,7 @@  + @@ -362,7 +365,7 @@ - + diff --git a/Plain Craft Launcher 2/Application.xaml.vb b/Plain Craft Launcher 2/Application.xaml.vb index 5997359..8f3548b 100644 --- a/Plain Craft Launcher 2/Application.xaml.vb +++ b/Plain Craft Launcher 2/Application.xaml.vb @@ -19,6 +19,9 @@ Public Class Application '开始 Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup Try + '动态 DLL 调用（必须尽量在前面，否则模块加载 CacheCow 等 DLL 就可能导致崩溃） + AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve + '开始 SecretOnApplicationStart() '检查参数调用 If e.Args.Length > 0 Then @@ -48,15 +51,6 @@ Public Class Application Else Environment.Exit((My.Computer.Info.AvailablePhysicalMemory - Ram) / 1024) '返回清理的内存量（K） End If -#If DEBUG Then - '制作更新包 - ElseIf e.Args(0) = "--edit1" Then - ExeEdit(e.Args(1), True) - Environment.Exit(ProcessReturnValues.TaskDone) - ElseIf e.Args(0) = "--edit2" Then - ExeEdit(e.Args(1), False) - Environment.Exit(ProcessReturnValues.TaskDone) -#End If End If End If '初始化文件结构 @@ -67,15 +61,14 @@ Public Class Application If Not CheckPermission(PathTemp) Then Throw New Exception("PCL 没有对 " & PathTemp & " 的访问权限") Catch ex As Exception If PathTemp = IO.Path.GetTempPath() & "PCL\" Then - MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & "错误原因：" & GetExceptionDetail(ex), "缓存文件夹不可用") + MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用") Else - MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & "错误原因：" & GetExceptionDetail(ex), "缓存文件夹不可用") - Setup.Set("SystemSystemCache", "") + MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用") + Settings.Set("SystemSystemCache", "") PathTemp = IO.Path.GetTempPath() & "PCL\" End If End Try Directory.CreateDirectory(PathTemp & "Cache") - Directory.CreateDirectory(PathTemp & "Download") Directory.CreateDirectory(PathAppdata) '检测单例 #If Not DEBUG Then @@ -104,45 +97,41 @@ WaitRetry: ToolTipService.PlacementProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(Primitives.PlacementMode.Bottom)) ToolTipService.HorizontalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(8.0)) ToolTipService.VerticalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(4.0)) + '设置网络配置默认值 + ServicePointManager.Expect100Continue = False + ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12 + ServicePointManager.DefaultConnectionLimit = 10000 + ServicePointManager.UseNagleAlgorithm = False + ServicePointManager.EnableDnsRoundRobin = True + ServicePointManager.ReusePort = True '设置初始窗口 - If Setup.Get("UiLauncherLogo") Then + If Settings.Get("UiLauncherLogo") Then FrmStart = New SplashScreen("Images\icon.ico") FrmStart.Show(False, True) End If - '动态 DLL 调用 - AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve '日志初始化 LogStart() '添加日志 Log($"[Start] 程序版本：{VersionDisplayName} ({VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})") #If RELEASE Then - Log($"[Start] 识别码：{UniqueAddress}{If(ThemeCheckOne(9), "，正式版", "")}") + Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，正式版", "")}") #Else - Log($"[Start] 识别码：{UniqueAddress}{If(ThemeCheckOne(9), "，已解锁反馈主题", "")}") + Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，已解锁反馈主题", "")}") #End If Log($"[Start] 程序路径：{PathWithName}") Log($"[Start] 系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})") Log($"[Start] 管理员权限：{IsAdmin()}") '检测异常环境 If Path.Contains(IO.Path.GetTempPath()) OrElse Path.Contains("AppData\Local\Temp\") Then - MyMsgBox("请将 PCL 从压缩包中解压之后再使用！" & vbCrLf & "在当前环境下运行可能会导致丢失游戏存档或设置，部分功能也可能无法使用！", "环境警告", "我知道了", IsWarn:=True) + MyMsgBox("请将 PCL 从压缩包中解压后再使用！" & vbCrLf & "如果不会解压，可以在网上寻找教程。", "需要解压！", "我知道了", IsWarn:=True, ForceWait:=True) + FormMain.EndProgramForce(ProcessReturnValues.Cancel) End If If Is32BitSystem Then MyMsgBox("PCL 和新版 Minecraft 均不再支持 32 位系统，部分功能将无法使用。" & vbCrLf & "非常建议重装为 64 位系统后再进行游戏！", "环境警告", "我知道了", IsWarn:=True) End If - '设置初始化 - Setup.Load("SystemDebugMode") - Setup.Load("SystemDebugAnim") - Setup.Load("ToolDownloadThread") - Setup.Load("ToolDownloadCert") - Setup.Load("ToolDownloadSpeed") - '网络配置初始化 - ServicePointManager.Expect100Continue = True - ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12 - ServicePointManager.DefaultConnectionLimit = 1024 '计时 - Log("[Start] 第一阶段加载用时：" & GetTimeTick() - ApplicationStartTick & " ms") - ApplicationStartTick = GetTimeTick() + Log("[Start] 第一阶段加载用时：" & GetTimeMs() - ApplicationStartTick & " ms") + ApplicationStartTick = GetTimeMs() '执行测试 #If DEBUG Then Test() @@ -154,23 +143,33 @@ WaitRetry: FilePath = PathWithName Catch End Try - MsgBox(GetExceptionDetail(ex, True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误") + MsgBox(ex.GetDetail(True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误") FormMain.EndProgramForce(ProcessReturnValues.Exception) End Try End Sub '结束 Private Sub Application_SessionEnding(sender As Object, e As SessionEndingCancelEventArgs) Handles Me.SessionEnding - FrmMain.EndProgram(False) + FrmMain?.EndProgram(False) End Sub '异常 Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException On Error Resume Next + '触发页面的 Dispatcher + If FrmMain?.PageLeft IsNot Nothing AndAlso TypeOf FrmMain.PageLeft Is IDispatcherUnhandledException Then + CType(FrmMain.PageLeft, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e) + If e.Handled Then Return + End If + If FrmMain?.PageRight IsNot Nothing AndAlso TypeOf FrmMain.PageRight Is IDispatcherUnhandledException Then + CType(FrmMain.PageRight, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e) + If e.Handled Then Return + End If + '正常处理 e.Handled = True If IsProgramEnded Then Return FeedbackInfo() - Dim Detail As String = GetExceptionDetail(e.Exception, True) + Dim Detail As String = e.Exception.GetDetail(True) If Detail.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse Detail.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse Detail.Contains("未能加载文件或程序集") OrElse Detail.Contains(".NET Framework") Then ' “自动错误判断” 的结果分析 OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net462-offline-installer") @@ -181,89 +180,69 @@ WaitRetry: End Sub '动态 DLL 调用 - Private Shared AssemblyNAudio As Assembly - Private Shared AssemblyJson As Assembly - Private Shared AssemblyDialog As Assembly - Private Shared AssemblyImazenWebp As Assembly - Private Shared ReadOnly AssemblyNAudioLock As New Object - Private Shared ReadOnly AssemblyJsonLock As New Object - Private Shared ReadOnly AssemblyDialogLock As New Object - Private Shared ReadOnly AssemblyImazenWebpLock As New Object Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean - Public Shared Function AssemblyResolve(sender As Object, args As ResolveEventArgs) As Assembly - If args.Name.StartsWithF("NAudio") Then - SyncLock AssemblyNAudioLock - If AssemblyNAudio Is Nothing Then - Log("[Start] 加载 DLL：NAudio") - AssemblyNAudio = Assembly.Load(GetResources("NAudio")) + Public Shared Function AssemblyResolve(sender As Object, Args As ResolveEventArgs) As Assembly + '缓存 + Static Prefixes As String() = {"NAudio", "Newtonsoft.Json", "Ookii.Dialogs.Wpf", "Imazen.WebP", "CacheCow.Common", "CacheCow.Client.FileStore", "CacheCow.Client", "System.Net.Http.Formatting", "System.ValueTuple"} + Static Locks As New Dictionary(Of String, Object)(StringComparer.Ordinal) + Static LoadedAssembly As New Dictionary(Of String, Assembly)(StringComparer.Ordinal) + '查找对应的 DLL + Dim Prefix As String = Prefixes.FirstOrDefault(Function(p) Args.Name.StartsWithF(p)) + If Prefix Is Nothing Then Return Nothing + '加载 DLL + If Not Locks.ContainsKey(Prefix) Then Locks(Prefix) = New Object() + SyncLock Locks(Prefix) + If Not LoadedAssembly.ContainsKey(Prefix) Then + Log($"[Start] 加载 DLL：{Prefix}") + LoadedAssembly(Prefix) = Assembly.Load(GetResources(Prefix)) + 'WebP 特判 + If Prefix = "Imazen.WebP" Then + SetDllDirectory(PathPure.TrimEnd("\"c)) + Try + WriteFile(PathPure & "libwebp.dll", GetResources("libwebp64")) + Catch ex As Exception + Log(ex, "写入 libwebp.dll 失败") '防止同时加载多个图片时，同时写入文件导致文件占用，进而导致崩溃 + End Try End If - Return AssemblyNAudio - End SyncLock - ElseIf args.Name.StartsWithF("Newtonsoft.Json") Then - SyncLock AssemblyJsonLock - If AssemblyJson Is Nothing Then - Log("[Start] 加载 DLL：Json") - AssemblyJson = Assembly.Load(GetResources("Json")) - End If - Return AssemblyJson - End SyncLock - ElseIf args.Name.StartsWithF("Ookii.Dialogs.Wpf") Then - SyncLock AssemblyDialogLock - If AssemblyDialog Is Nothing Then - Log("[Start] 加载 DLL：Dialogs") - AssemblyDialog = Assembly.Load(GetResources("Dialogs")) - End If - Return AssemblyDialog - End SyncLock - ElseIf args.Name.StartsWithF("Imazen.WebP") Then - SyncLock AssemblyImazenWebpLock - If AssemblyImazenWebp Is Nothing Then - Log("[Start] 加载 DLL：Imazen.WebP") - AssemblyImazenWebp = Assembly.Load(GetResources("Imazen_WebP")) - SetDllDirectory(PathPure.TrimEnd("\")) - WriteFile(PathPure & "libwebp.dll", GetResources("libwebp64")) - End If - Return AssemblyImazenWebp - End SyncLock - Else - Return Nothing - End If + End If + Return LoadedAssembly(Prefix) + End SyncLock End Function '切换窗口 '控件模板事件 Private Sub MyIconButton_Click(sender As Object, e As EventArgs) - Select Case Setup.Get("LoginType") + Select Case Settings.Get("LoginType") Case McLoginType.Ms '微软 - Dim MsJson As JObject = GetJson(Setup.Get("LoginMsJson")) + Dim MsJson As JObject = GetJson(Settings.Get("LoginMsJson")) MsJson.Remove(sender.Tag) - Setup.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None)) + Settings.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None)) If FrmLoginMs.ComboAccounts.SelectedItem Is sender.Parent Then FrmLoginMs.ComboAccounts.SelectedIndex = 0 FrmLoginMs.ComboAccounts.Items.Remove(sender.Parent) Case McLoginType.Legacy '离线 Dim Names As New List(Of String) - Names.AddRange(Setup.Get("LoginLegacyName").ToString.Split("¨")) + Names.AddRange(Settings.Get("LoginLegacyName").ToString.Split("¨")) Names.Remove(sender.Tag) - Setup.Set("LoginLegacyName", Join(Names, "¨")) + Settings.Set("LoginLegacyName", Names.Join("¨"c)) FrmLoginLegacy.ComboName.ItemsSource = Names FrmLoginLegacy.ComboName.Text = If(Names.Any, Names(0), "") Case Else '第三方 - Dim Token As String = GetStringFromEnum(Setup.Get("LoginType")) + Dim Token As String = GetStringFromEnum(Settings.Get("LoginType")) Dim Dict As New Dictionary(Of String, String) Dim Names As New List(Of String) Dim Passs As New List(Of String) - If Not Setup.Get("Login" & Token & "Email") = "" Then Names.AddRange(Setup.Get("Login" & Token & "Email").ToString.Split("¨")) - If Not Setup.Get("Login" & Token & "Pass") = "" Then Passs.AddRange(Setup.Get("Login" & Token & "Pass").ToString.Split("¨")) + If Not Settings.Get("Login" & Token & "Email") = "" Then Names.AddRange(Settings.Get("Login" & Token & "Email").ToString.Split("¨")) + If Not Settings.Get("Login" & Token & "Pass") = "" Then Passs.AddRange(Settings.Get("Login" & Token & "Pass").ToString.Split("¨")) For i = 0 To Names.Count - 1 Dict.Add(Names(i), Passs(i)) Next Dict.Remove(sender.Tag) - Setup.Set("Login" & Token & "Email", Join(Dict.Keys, "¨")) - Setup.Set("Login" & Token & "Pass", Join(Dict.Values, "¨")) + Settings.Set("Login" & Token & "Email", Dict.Keys.Join("¨"c)) + Settings.Set("Login" & Token & "Pass", Dict.Values.Join("¨"c)) Select Case Token Case "Nide" FrmLoginNide.ComboName.ItemsSource = Dict.Keys diff --git a/Plain Craft Launcher 2/Controls/Behaviors/ClipboardInterceptor.vb b/Plain Craft Launcher 2/Controls/Behaviors/ClipboardInterceptor.vb new file mode 100644 index 0000000..1daef36 --- /dev/null +++ b/Plain Craft Launcher 2/Controls/Behaviors/ClipboardInterceptor.vb @@ -0,0 +1,192 @@ +' Author: uye (owner of the MaaAssistantArknights team) +' Original Source: MaaAssistantArknights project - https://github.com/MaaAssistantArknights/MaaAssistantArknights +' License: Apache License 2.0 (this file only) +' +' This file is originally developed for MaaAssistantArknights and licensed under AGPL v3.0. +' As the original author and copyright holder, +' I hereby re-license this file under the Apache License 2.0 for use in the Plain Craft Launcher project. +' +' This file is contributed under the spirit of good faith and open cooperation. +' It does not implement any core launcher functions of PCL. +' +' Description: +' Provides a WPF clipboard handling fix to avoid OpenClipboard exceptions +' in TextBox, RichTextBox, and DataGrid under Windows focus issues or clipboard hooks. +' +' Date: 2025-07-03 + +Imports System.Windows +Imports System.Windows.Controls +Imports System.Windows.Input +Imports System.Windows.Documents +Imports System.Linq + +Namespace Controls.Behaviors + Public NotInheritable Class ClipboardInterceptor + Private Sub New() + End Sub + + Public Shared ReadOnly EnableSafeClipboardProperty As DependencyProperty = + DependencyProperty.RegisterAttached("EnableSafeClipboard", GetType(Boolean), GetType(ClipboardInterceptor), + New PropertyMetadata(False, AddressOf OnEnableSafeClipboardChanged)) + + Public Shared Sub SetEnableSafeClipboard(element As DependencyObject, value As Boolean) + element.SetValue(EnableSafeClipboardProperty, value) + End Sub + + Public Shared Function GetEnableSafeClipboard(element As DependencyObject) As Boolean + Return element.GetValue(EnableSafeClipboardProperty) + End Function + + Private Shared Sub OnEnableSafeClipboardChanged(d As DependencyObject, e As DependencyPropertyChangedEventArgs) + If TypeOf d Is TextBox AndAlso CBool(e.NewValue) Then + AddCommandBindingsToTextBox(DirectCast(d, TextBox)) + ElseIf TypeOf d Is RichTextBox AndAlso CBool(e.NewValue) Then + AddCommandBindingsToRichTextBox(DirectCast(d, RichTextBox)) + ElseIf TypeOf d Is DataGrid AndAlso CBool(e.NewValue) Then + AddCommandBindingsToDataGrid(DirectCast(d, DataGrid)) + End If + End Sub + + Private Shared Sub AddCommandBindingsToTextBox(tb As TextBox) + tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyTextBox)) + tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Cut, AddressOf OnCutTextBox)) + tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Paste, AddressOf OnPasteTextBox)) + End Sub + + Private Shared Sub AddCommandBindingsToRichTextBox(rtb As RichTextBox) + rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyRichTextBox)) + rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Cut, AddressOf OnCutRichTextBox)) + rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Paste, AddressOf OnPasteRichTextBox)) + End Sub + + Private Shared Sub AddCommandBindingsToDataGrid(dg As DataGrid) + dg.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyDataGrid)) + End Sub + + Private Shared Sub OnCopyTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim tb = TryCast(sender, TextBox) + If tb Is Nothing OrElse tb.SelectionLength <= 0 Then Return + + Try + Forms.Clipboard.Clear() + Forms.Clipboard.SetDataObject(tb.SelectedText, True) + Catch + End Try + + e.Handled = True + End Sub + + Private Shared Sub OnCutTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim tb = TryCast(sender, TextBox) + If tb Is Nothing OrElse tb.SelectionLength <= 0 Then Return + + Try + Forms.Clipboard.Clear() + Forms.Clipboard.SetDataObject(tb.SelectedText, True) + Catch + End Try + + tb.SelectedText = String.Empty + e.Handled = True + End Sub + + Private Shared Sub OnPasteTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim tb = TryCast(sender, TextBox) + If tb Is Nothing Then Return + + If Forms.Clipboard.ContainsText() Then + Dim pasteText = Forms.Clipboard.GetText() + + '将换行符替换为空格（#7825） + If Not tb.AcceptsReturn Then pasteText = pasteText.Replace(vbCrLf, " ").Replace(vbCr, " ").Replace(vbLf, " ") + + Dim start = tb.SelectionStart + + tb.SelectedText = pasteText + tb.CaretIndex = start + pasteText.Length + tb.SelectionLength = 0 + End If + + e.Handled = True + End Sub + + Private Shared Sub OnCopyRichTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim rtb = TryCast(sender, RichTextBox) + If rtb Is Nothing Then Return + + Dim textRange = New TextRange(rtb.Selection.Start, rtb.Selection.End) + If String.IsNullOrEmpty(textRange.Text) Then Return + + Try + Forms.Clipboard.Clear() + Forms.Clipboard.SetDataObject(textRange.Text, True) + Catch + End Try + + e.Handled = True + End Sub + + Private Shared Sub OnCutRichTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim rtb = TryCast(sender, RichTextBox) + If rtb Is Nothing Then Return + + Dim selection = New TextRange(rtb.Selection.Start, rtb.Selection.End) + If String.IsNullOrEmpty(selection.Text) Then Return + + Try + Forms.Clipboard.Clear() + Forms.Clipboard.SetDataObject(selection.Text, True) + Catch + End Try + + selection.Text = String.Empty + e.Handled = True + End Sub + + Private Shared Sub OnPasteRichTextBox(sender As Object, e As ExecutedRoutedEventArgs) + Dim rtb = TryCast(sender, RichTextBox) + If rtb Is Nothing Then Return + + If Not Forms.Clipboard.ContainsText() Then Return + + Dim pasteText = Forms.Clipboard.GetText() + Dim selection = rtb.Selection + + selection.Text = pasteText + + Dim caretPos = selection.End + rtb.CaretPosition = caretPos + rtb.Selection.Select(caretPos, caretPos) + + e.Handled = True + End Sub + + Private Shared Sub OnCopyDataGrid(sender As Object, e As ExecutedRoutedEventArgs) + Dim dg = TryCast(sender, DataGrid) + If dg Is Nothing OrElse dg.SelectedCells Is Nothing OrElse dg.SelectedCells.Count = 0 Then Return + + Dim sb = New StringBuilder + Dim rowGroups = dg.SelectedCells.GroupBy(Function(c) c.Item) + + For Each row In rowGroups + Dim rowText = String.Join(vbTab, row.Select( + Function(cell) + Dim tb = TryCast(cell.Column.GetCellContent(cell.Item), TextBlock) + Return If(tb IsNot Nothing, tb.Text, "") + End Function)) + sb.AppendLine(rowText) + Next + + Dim sbStr = sb.ToString().TrimEnd(ControlChars.Cr, ControlChars.Lf) + + Try + Forms.Clipboard.Clear() + Forms.Clipboard.SetDataObject(sbStr, True) + Catch + End Try + + e.Handled = True + End Sub + End Class +End Namespace diff --git a/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb b/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb new file mode 100644 index 0000000..c508b94 --- /dev/null +++ b/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb @@ -0,0 +1,23 @@ +Imports System.Windows.Threading + +''' +''' 指示页面可以通过按下 F5 或以其他方式刷新。 +''' +Public Interface IRefreshable + Sub Refresh() +End Interface + +''' +''' 指示页面可以处理未捕获的异常。 +''' +Public Interface IDispatcherUnhandledException + Sub DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) +End Interface + +''' +''' 指示该控件是可勾选的。 +''' +Public Interface IMyRadio + Event Check(sender As Object, e As RouteEventArgs) + Event Changed(sender As Object, e As RouteEventArgs) +End Interface diff --git a/Plain Craft Launcher 2/Controls/Behaviors/LazyLoadBehavior.vb b/Plain Craft Launcher 2/Controls/Behaviors/LazyLoadBehavior.vb new file mode 100644 index 0000000..100bf59 --- /dev/null +++ b/Plain Craft Launcher 2/Controls/Behaviors/LazyLoadBehavior.vb @@ -0,0 +1,46 @@ +Public Class LazyLoadBehavior + + ''' + ''' 指定首次进入 ScrollViewer 的可视范围时执行的操作。 + ''' + Public Shared Sub OnFirstEnterScrollViewerViewport(obj As DependencyObject, value As Action) + obj.SetValue(IsInViewportProperty, value) + End Sub + + Private Shared ReadOnly IsInViewportProperty As DependencyProperty = + DependencyProperty.RegisterAttached("IsInViewport", GetType(Action), GetType(LazyLoadBehavior), + New PropertyMetadata(Nothing, AddressOf OnIsInViewportChanged)) + + Private Shared Sub OnIsInViewportChanged(d As DependencyObject, e As DependencyPropertyChangedEventArgs) + Dim Element = TryCast(d, FrameworkElement) + If Element Is Nothing OrElse e.NewValue Is Nothing Then Return + + Dim Handled As Boolean = False + Dim Handler As EventHandler = + Sub() + If Handled Then Return + '判断元素是否可见 + If Element.RenderSize.Width < Double.Epsilon Then Return + If Not Element.IsVisible Then Return + '判断是否在 ScrollViewer 的可视区域内 + Dim Scroll = FindParentScrollViewer(Element) + If Scroll Is Nothing Then Return + If Not New Rect(0, 0, Scroll.ViewportWidth, Scroll.ViewportHeight).IntersectsWith( + Element.TransformToAncestor(Scroll).TransformBounds(New Rect(New Point(0, 0), Element.RenderSize))) Then Return + '执行 + Handled = True + CType(e.NewValue, Action).Invoke() + RemoveHandler Element.LayoutUpdated, Handler + End Sub + AddHandler Element.LayoutUpdated, Handler + End Sub + + Private Shared Function FindParentScrollViewer(d As DependencyObject) As ScrollViewer + While d IsNot Nothing + If TypeOf d Is ScrollViewer Then Return CType(d, ScrollViewer) + d = VisualTreeHelper.GetParent(d) + End While + Return Nothing + End Function + +End Class diff --git a/Plain Craft Launcher 2/Controls/IMyRadio.vb b/Plain Craft Launcher 2/Controls/IMyRadio.vb deleted file mode 100644 index 8649305..0000000 --- a/Plain Craft Launcher 2/Controls/IMyRadio.vb +++ /dev/null @@ -1,4 +0,0 @@ -Public Interface IMyRadio - Event Check(sender As Object, e As RouteEventArgs) - Event Changed(sender As Object, e As RouteEventArgs) -End Interface diff --git a/Plain Craft Launcher 2/Controls/MyButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyButton.xaml.vb index 94a0677..992673e 100644 --- a/Plain Craft Launcher 2/Controls/MyButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyButton.xaml.vb @@ -140,39 +140,14 @@ Public Class MyButton End Try End Sub - '实现自定义事件 + '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） + Private IsMouseDown As Boolean = False Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp If Not IsMouseDown Then Return Log("[Control] 按下按钮：" & Text) RaiseEvent Click(sender, e) - If Not String.IsNullOrEmpty(Tag) Then - If Tag.ToString.StartsWithF("链接-") OrElse Tag.ToString.StartsWithF("启动-") Then - Hint("主页自定义按钮语法已更新，且不再兼容老版本语法，请查看新的自定义示例！") - End If - End If - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyButton), New PropertyMetadata(Nothing)) - - '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） - Private IsMouseDown As Boolean = False Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True Focus() diff --git a/Plain Craft Launcher 2/Controls/MyCard.vb b/Plain Craft Launcher 2/Controls/MyCard.vb index decffd4..0eb46a6 100644 --- a/Plain Craft Launcher 2/Controls/MyCard.vb +++ b/Plain Craft Launcher 2/Controls/MyCard.vb @@ -90,8 +90,9 @@ MainGrid.Children.Add(MainSwap) End If '改变默认的折叠 - If IsSwaped AndAlso SwapControl IsNot Nothing Then + If IsSwapped AndAlso SwapControl IsNot Nothing Then MainSwap.RenderTransform = New RotateTransform(If(SwapLogoRight, 270, 0)) + SwapControl.Visibility = Visibility.Collapsed '取消由于高度变化被迫触发的高度动画 Dim RawUseAnimation As Boolean = UseAnimation UseAnimation = False @@ -109,28 +110,24 @@ '这一部分的代码是好几年前留下的究极屎坑，当时还不知道该咋正确调用这种方法，就写了这么一坨屎 '但是现在……反正勉强能用……懒得改了就这样吧.jpg '别骂了别骂了.jpg - If IsNothing(Stack.Tag) Then Return + If Stack.Tag Is Nothing Then Return '排序 + Dim HasDuplicates As Boolean = False Select Case Type Case 3 - Stack.Tag = CType(Stack.Tag, List(Of DlOptiFineListEntry)).Sort(Function(a, b) VersionSortBoolean(a.NameDisplay, b.NameDisplay)) + Stack.Tag = CType(Stack.Tag, List(Of DlOptiFineListEntry)).SortByComparison(Function(a, b) CompareVersionGE(a.DisplayName, b.DisplayName)) Case 4, 10 - Stack.Tag = CType(Stack.Tag, List(Of DlLiteLoaderListEntry)).Sort(Function(a, b) VersionSortBoolean(a.Inherit, b.Inherit)) + Stack.Tag = CType(Stack.Tag, List(Of DlLiteLoaderListEntry)).SortByComparison(Function(a, b) CompareVersionGE(a.Inherit, b.Inherit)) Case 6 - Stack.Tag = CType(Stack.Tag, List(Of DlForgeVersionEntry)).Sort(Function(a, b) a.Version > b.Version) + Stack.Tag = CType(Stack.Tag, List(Of DlForgeVersionEntry)).OrderByDescending(Function(a) a).ToList Case 8, 9 - Stack.Tag = CType(Stack.Tag, List(Of CompFile)).Sort(Function(a, b) a.ReleaseDate > b.ReleaseDate) + Stack.Tag = CType(Stack.Tag, List(Of CompFile)).SortByComparison(Function(a, b) a.ReleaseDate > b.ReleaseDate) + HasDuplicates = + CType(Stack.Tag, List(Of CompFile)).Distinct(Function(a, b) a.DisplayName = b.DisplayName).Count <> + CType(Stack.Tag, List(Of CompFile)).Count End Select '控件转换 Select Case Type - Case 5 - Dim LoadingPickaxe As New MyLoading With {.Text = "正在获取版本列表", .Margin = New Thickness(5)} - Dim Loader = New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Main", AddressOf DlForgeVersionMain) - LoadingPickaxe.State = Loader - Loader.Start(Stack.Tag) - AddHandler LoadingPickaxe.StateChanged, AddressOf FrmDownloadForge.Forge_StateChanged - AddHandler LoadingPickaxe.Click, AddressOf FrmDownloadForge.Forge_Click - Stack.Children.Add(LoadingPickaxe) Case 6 ForgeDownloadListItemPreload(Stack, Stack.Tag, AddressOf ForgeSave_Click, True) Case 8 @@ -140,37 +137,24 @@ For Each Data As Object In Stack.Tag Select Case Type Case 0 - Stack.Children.Add(PageSelectRight.McVersionListItem(Data)) + Stack.Children.Add(CType(Data, McInstance).ToListItem(AddressOf PageSelectRight.McInstanceListContent)) Case 2 Stack.Children.Add(McDownloadListItem(Data, AddressOf McDownloadMenuSave, True)) Case 3 Stack.Children.Add(OptiFineDownloadListItem(Data, AddressOf OptiFineSave_Click, True)) - Case 4 - Stack.Children.Add(LiteLoaderDownloadListItem(Data, AddressOf FrmDownloadLiteLoader.DownloadStart, False)) - Case 5 Case 6 Stack.Children.Add(ForgeDownloadListItem(Data, AddressOf ForgeSave_Click, True)) Case 7 '不能使用 AddressOf，这导致了 #535，原因完全不明，疑似是编译器 Bug Stack.Children.Add(McDownloadListItem(Data, Sub(sender, e) FrmDownloadInstall.MinecraftSelected(sender, e), False)) Case 8 - If CType(Stack.Tag, List(Of CompFile)).Distinct(Function(a, b) a.DisplayName = b.DisplayName).Count <> - CType(Stack.Tag, List(Of CompFile)).Count Then - '存在重复的名称（#1344） - Stack.Children.Add(CType(Data, CompFile).ToListItem(AddressOf FrmDownloadCompDetail.Save_Click, BadDisplayName:=True)) - Else - '不存在重复的名称，正常加载 - Stack.Children.Add(CType(Data, CompFile).ToListItem(AddressOf FrmDownloadCompDetail.Save_Click)) - End If + '若存在重复的版本名，则显示文件名而非版本名（#1344） + Stack.Children.Add(CType(Data, CompFile).ToListItem( + AddressOf FrmDownloadCompDetail.Save_Click, BadDisplayName:=HasDuplicates)) Case 9 - If CType(Stack.Tag, List(Of CompFile)).Distinct(Function(a, b) a.DisplayName = b.DisplayName).Count <> - CType(Stack.Tag, List(Of CompFile)).Count Then - '存在重复的名称（#1344） - Stack.Children.Add(CType(Data, CompFile).ToListItem(AddressOf FrmDownloadCompDetail.Install_Click, AddressOf FrmDownloadCompDetail.Save_Click, BadDisplayName:=True)) - Else - '不存在重复的名称，正常加载 - Stack.Children.Add(CType(Data, CompFile).ToListItem(AddressOf FrmDownloadCompDetail.Install_Click, AddressOf FrmDownloadCompDetail.Save_Click)) - End If + '若存在重复的版本名，则显示文件名而非版本名（#1344） + Stack.Children.Add(CType(Data, CompFile).ToListItem( + AddressOf FrmDownloadCompDetail.Install_Click, AddressOf FrmDownloadCompDetail.Save_Click, BadDisplayName:=HasDuplicates)) Case 10 Stack.Children.Add(LiteLoaderDownloadListItem(Data, AddressOf LiteLoaderSave_Click, True)) Case 11 @@ -224,7 +208,7 @@ Private ActualUsedHeight As Double '回滚实际高度（例如 NaN） Private Sub MySizeChanged(sender As Object, e As SizeChangedEventArgs) Handles Me.SizeChanged If Not UseAnimation Then Return - Dim DeltaHeight As Double = If(IsSwaped, SwapedHeight, e.NewSize.Height) - e.PreviousSize.Height + Dim DeltaHeight As Double = If(IsSwapped, SwapedHeight, e.NewSize.Height) - e.PreviousSize.Height '卡片的进入时动画已被页面通用切换动画替代 If e.PreviousSize.Height = 0 OrElse IsHeightAnimating OrElse Math.Abs(DeltaHeight) < 1 OrElse ActualHeight = 0 Then Return StartHeightAnimation(DeltaHeight, e.PreviousSize.Height, False) @@ -269,18 +253,18 @@ Sub() IsHeightAnimating = False Height = ActualUsedHeight - If IsSwaped AndAlso SwapControl IsNot Nothing Then SwapControl.Visibility = Visibility.Collapsed + If IsSwapped AndAlso SwapControl IsNot Nothing Then SwapControl.Visibility = Visibility.Collapsed End Sub,, True)) AniStart(AnimList, "MyCard Height " & Uuid) IsHeightAnimating = True - ActualUsedHeight = If(IsSwaped, SwapedHeight, Height) + ActualUsedHeight = If(IsSwapped, SwapedHeight, Height) Height = PreviousHeight End Sub ''' - ''' 通知 MyCard，控件内容已改变，需要中断动画并更新高度。 + ''' 通知 MyCard，控件内容已改变，需要中断动画并瞬间更新高度。 ''' Public Sub TriggerForceResize() - Height = If(IsSwaped, SwapedHeight, Double.NaN) + Height = If(IsSwapped, SwapedHeight, Double.NaN) AniStop("MyCard Height " & Uuid) IsHeightAnimating = False End Sub @@ -291,7 +275,7 @@ '若设置了 CanSwap，或 SwapControl 不为空，则判定为会进行折叠 '这是因为不能直接在 XAML 中设置 SwapControl - Public SwapControl As Object + Public SwapControl As FrameworkElement Public Property CanSwap As Boolean = False ''' ''' 被折叠的种类，用于控件虚拟化。 @@ -300,59 +284,78 @@ ''' ''' 是否已被折叠。 ''' - Public Property IsSwaped As Boolean + Public Property IsSwapped As Boolean Get - Return _IsSwaped + Return _IsSwapped End Get Set(value As Boolean) - If _IsSwaped = value Then Return - _IsSwaped = value + If _IsSwapped = value Then Return + _IsSwapped = value If SwapControl Is Nothing Then Return '展开 - If Not IsSwaped AndAlso TypeOf SwapControl Is StackPanel Then StackInstall(SwapControl, SwapType, Title) + If Not IsSwapped AndAlso TypeOf SwapControl Is StackPanel Then StackInstall(SwapControl, SwapType, Title) '若尚未加载，会在 Loaded 事件中触发无动画的折叠，不需要在这里进行 If Not IsLoaded Then Return '更新高度 SwapControl.Visibility = Visibility.Visible TriggerForceResize() '改变箭头 - AniStart(AaRotateTransform(MainSwap, If(_IsSwaped, If(SwapLogoRight, 270, 0), 180) - CType(MainSwap.RenderTransform, RotateTransform).Angle, 250,, New AniEaseOutFluent(AniEasePower.ExtraStrong)), "MyCard Swap " & Uuid, True) + AniStart(AaRotateTransform(MainSwap, If(_IsSwapped, If(SwapLogoRight, 270, 0), 180) - CType(MainSwap.RenderTransform, RotateTransform).Angle, 250,, New AniEaseOutFluent(AniEasePower.ExtraStrong)), "MyCard Swap " & Uuid, True) End Set End Property - Private _IsSwaped As Boolean = False + Private _IsSwapped As Boolean = False + + Public Property IsSwaped As Boolean + Get + Return GetValue(IsSwapedProperty) + End Get + Set(value As Boolean) + SetValue(IsSwapedProperty, value) + End Set + End Property + Public Shared ReadOnly IsSwapedProperty As DependencyProperty = DependencyProperty.Register("IsSwaped", GetType(Boolean), GetType(MyCard), New PropertyMetadata(False, + Sub(sender, e) If sender IsNot Nothing AndAlso TypeOf sender Is MyCard Then CType(sender, MyCard).IsSwapped = CType(e.NewValue, Boolean))) Public Property SwapLogoRight As Boolean = False - Private IsMouseDown As Boolean = False + Private IsSwapMouseDown As Boolean = False '用于触发卡片展开/折叠的 MouseDown + Private IsCustomMouseDown As Boolean = False '用于触发自定义事件的 MouseDown Public Event PreviewSwap(sender As Object, e As RouteEventArgs) Public Event Swap(sender As Object, e As RouteEventArgs) Public Const SwapedHeight As Integer = 40 Private Sub MyCard_MouseLeftButtonDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown Dim Pos As Double = Mouse.GetPosition(Me).Y - If Not IsSwaped AndAlso - (SwapControl Is Nothing OrElse Pos > If(IsSwaped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 - IsMouseDown = True + If Not IsSwapped AndAlso + (Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return + IsCustomMouseDown = True + If Not IsSwapped AndAlso + (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 + IsSwapMouseDown = True End Sub - Private Sub MyCard_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp - If Not IsMouseDown Then Return - IsMouseDown = False + Private Sub MyCard_MouseLeftButtonUp() Handles Me.MouseLeftButtonUp + If Not IsCustomMouseDown Then Return + IsCustomMouseDown = False + RaiseCustomEvent() '触发自定义事件 + + If Not IsSwapMouseDown Then Return + IsSwapMouseDown = False Dim Pos As Double = Mouse.GetPosition(Me).Y - If Not IsSwaped AndAlso - (SwapControl Is Nothing OrElse Pos > If(IsSwaped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 + If Not IsSwapped AndAlso + (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 - Dim ee = New RouteEventArgs(True) - RaiseEvent PreviewSwap(Me, ee) - If ee.Handled Then - IsMouseDown = False + Dim e = New RouteEventArgs(True) + RaiseEvent PreviewSwap(Me, e) + If e.Handled Then + IsSwapMouseDown = False Return End If - IsSwaped = Not IsSwaped - Log("[Control] " & If(IsSwaped, "折叠卡片", "展开卡片") & If(Title Is Nothing, "", "：" & Title)) - RaiseEvent Swap(Me, ee) + IsSwapped = Not IsSwapped + Log("[Control] " & If(IsSwapped, "折叠卡片", "展开卡片") & If(Title Is Nothing, "", "：" & Title)) + RaiseEvent Swap(Me, e) End Sub Private Sub MyCard_MouseLeave_Swap(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave - IsMouseDown = False + IsSwapMouseDown = False End Sub #End Region diff --git a/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb b/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb index a0e8c9c..bfcf1ea 100644 --- a/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb @@ -2,6 +2,7 @@ Public Class MyCheckBox + Implements ISettingControl '基础 @@ -12,9 +13,6 @@ Public Class MyCheckBox ''' 是否为用户手动改变的勾选状态。 Public Event Change(sender As Object, user As Boolean) Public Event PreviewChange(sender As Object, e As RouteEventArgs) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序引发本控件的 Change 事件 '自定义属性 Public Property Checked As Boolean @@ -59,6 +57,7 @@ Public Class MyCheckBox '更改动画 SyncUI() + RaiseCustomEvent() Catch ex As Exception Log(ex, "设置 Checked 失败") End Try @@ -74,7 +73,7 @@ Public Class MyCheckBox AaScale(ShapeBorder, 6, AnimationTimeOfCheck * 2, AnimationTimeOfCheck * 0.7, New AniEaseOutBack, , True) }, "MyCheckBox Scale " & Uuid) AniStart({ - AaColor(ShapeBorder, Border.BorderBrushProperty, If(IsEnabled, If(IsMouseOver, "ColorBrush3", "ColorBrush2"), "ColorBrushGray4"), AnimationTimeOfCheck) + AaColor(ShapeBorder, Border.BorderBrushProperty, If(IsEnabled, If(IsMouseOver, "ColorBrush3", "ColorBrush2"), "ColorBrushGray5"), AnimationTimeOfCheck) }, "MyCheckBox BorderColor " & Uuid) AniStart({ AaCode(Sub() AllowMouseDown = True, AnimationTimeOfCheck * 2) @@ -87,7 +86,7 @@ Public Class MyCheckBox AaScale(ShapeBorder, 6, AnimationTimeOfCheck * 2, AnimationTimeOfCheck * 0.7, New AniEaseOutBack, , True) }, "MyCheckBox Scale " & Uuid) AniStart({ - AaColor(ShapeBorder, Border.BorderBrushProperty, If(IsEnabled, If(IsMouseOver, "ColorBrush3", "ColorBrush1"), "ColorBrushGray4"), AnimationTimeOfCheck) + AaColor(ShapeBorder, Border.BorderBrushProperty, If(IsEnabled, If(IsMouseOver, "ColorBrush3", "ColorBrush1"), "ColorBrushGray5"), AnimationTimeOfCheck) }, "MyCheckBox BorderColor " & Uuid) AniStart({ AaCode(Sub() AllowMouseDown = True, AnimationTimeOfCheck * 2) @@ -101,11 +100,11 @@ Public Class MyCheckBox If Checked Then CType(ShapeCheck.RenderTransform, ScaleTransform).ScaleX = 1 CType(ShapeCheck.RenderTransform, ScaleTransform).ScaleY = 1 - ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(IsEnabled, "ColorBrush2", "ColorBrushGray4")) + ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(IsEnabled, "ColorBrush2", "ColorBrushGray5")) Else CType(ShapeCheck.RenderTransform, ScaleTransform).ScaleX = 0 CType(ShapeCheck.RenderTransform, ScaleTransform).ScaleY = 0 - ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4")) + ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray5")) End If End If End Sub @@ -180,18 +179,18 @@ Public Class MyCheckBox Else '不可用 AniStart({ - AaColor(ShapeBorder, Border.BorderBrushProperty, ColorGray4 - ShapeBorder.BorderBrush, AnimationTimeOfMouseOut) + AaColor(ShapeBorder, Border.BorderBrushProperty, ColorGray5 - ShapeBorder.BorderBrush, AnimationTimeOfMouseOut) }, "MyCheckBox BorderColor " & Uuid) AniStart({ - AaColor(LabText, TextBlock.ForegroundProperty, ColorGray4 - LabText.Foreground, AnimationTimeOfMouseOut) + AaColor(LabText, TextBlock.ForegroundProperty, ColorGray5 - LabText.Foreground, AnimationTimeOfMouseOut) }, "MyCheckBox TextColor " & Uuid) End If Else '无动画 AniStop("MyCheckBox TextColor " & Uuid) AniStop("MyCheckBox BorderColor " & Uuid) - LabText.SetResourceReference(TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray4")) - ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4")) + LabText.SetResourceReference(TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray5")) + ShapeBorder.SetResourceReference(Border.BorderBrushProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray5")) End If End Sub Private Sub Checkbox_MouseEnterAnimation() Handles Me.MouseEnter @@ -205,11 +204,27 @@ Public Class MyCheckBox Private Sub Checkbox_MouseLeaveAnimation() Handles Me.MouseLeave If Not IsEnabled Then Return 'MouseLeave 比 IsEnabledChanged 后执行，所以如果自定义事件修改了 IsEnabled，将导致显示错误 AniStart({ - AaColor(LabText, TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut) + AaColor(LabText, TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray5"), AnimationTimeOfMouseOut) }, "MyCheckBox TextColor " & Uuid) AniStart({ - AaColor(ShapeBorder, Border.BorderBrushProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4"), AnimationTimeOfMouseOut) + AaColor(ShapeBorder, Border.BorderBrushProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray5"), AnimationTimeOfMouseOut) }, "MyCheckBox BorderColor " & Uuid) End Sub +#Region "设置" + + Private Sub RefreshSetting(NewValue As String) Implements ISettingControl.RefreshSetting + Checked = Boolean.Parse(NewValue) + End Sub + + Private Function GetCurrentSetting() As String Implements ISettingControl.GetCurrentSetting + Return Checked.ToString + End Function + + Private Sub SaveSetting() Handles Me.Change + SettingService.SaveSetting(Me) + End Sub + +#End Region + End Class diff --git a/Plain Craft Launcher 2/Controls/MyComboBox.vb b/Plain Craft Launcher 2/Controls/MyComboBox.vb index 874b48a..db7ea71 100644 --- a/Plain Craft Launcher 2/Controls/MyComboBox.vb +++ b/Plain Craft Launcher 2/Controls/MyComboBox.vb @@ -1,5 +1,6 @@ Public Class MyComboBox Inherits ComboBox + Implements ISettingControl Public Event TextChanged(sender As Object, e As TextChangedEventArgs) '基础 @@ -117,15 +118,14 @@ Private IsTextChanging As Boolean = False Private Sub MyComboBox_TextChanged(sender As Object, e As TextChangedEventArgs) Handles Me.TextChanged If IsTextChanging OrElse Not IsEditable Then Return - If SelectedItem IsNot Nothing AndAlso Text <> SelectedItem.ToString Then - Dim RawText As String = Text - Dim RawSelectionStart As Integer = TextBox.SelectionStart - IsTextChanging = True - SelectedItem = Nothing - Text = RawText - TextBox.SelectionStart = RawSelectionStart - IsTextChanging = False - End If + If SelectedItem Is Nothing OrElse Text = SelectedItem.ToString Then Return + Dim RawText As String = Text + Dim RawSelectionStart As Integer = TextBox.SelectionStart + IsTextChanging = True + SelectedItem = Nothing + Text = RawText + TextBox.SelectionStart = RawSelectionStart + IsTextChanging = False End Sub Public ReadOnly Property ContentPresenter As ContentPresenter @@ -134,4 +134,48 @@ End Get End Property + Private Sub MyComboBox_SelectionChanged(sender As Object, e As SelectionChangedEventArgs) Handles Me.SelectionChanged + If IsLoaded AndAlso AniControlEnabled = 0 Then RaiseCustomEvent() + End Sub + +#Region "设置" + + Private Sub RefreshSetting(NewValue As String) Implements ISettingControl.RefreshSetting + Dim TargetItem = Items.OfType(Of DependencyObject)().FirstOrDefault(Function(i) Val(If(SettingService.GetValue(i), -1)) = NewValue) + If TargetItem IsNot Nothing Then + SelectedItem = TargetItem + ElseIf Items.Count > NewValue Then + SelectedIndex = NewValue + Else + Log($"[Setting] 尝试显示设置 {SettingService.GetKey(Me)}，但没有找到设置值 {NewValue} 的对应项", LogLevel.Debug) + SelectedIndex = -1 + SelectedItem = Nothing + 'Dim Key As String = SettingService.GetKey(Me) + 'Dim DefaultValue = Settings.GetDefault(Key) + 'If DefaultValue = NewValue Then + ' Log($"[Setting] 尝试显示设置 {Key}，但没有找到设置值 {NewValue} 的对应项，这可能是因为程序版本太老了", LogLevel.Hint) + 'Else + ' Log($"[Setting] 尝试显示设置 {Key}，但没有找到设置值 {NewValue} 的对应项，已重置该设置", LogLevel.Debug) + ' Settings.Reset(Key) + ' RefreshSetting(DefaultValue) + 'End If + End If + End Sub + + Private Function GetCurrentSetting() As String Implements ISettingControl.GetCurrentSetting + If SelectedItem Is Nothing Then Return Nothing + If TypeOf SelectedItem Is DependencyObject Then + Return Val(If(SettingService.GetValue(SelectedItem), SelectedIndex)) + Else + Return SelectedIndex + End If + End Function + + Private Sub SaveSetting() Handles Me.SelectionChanged + If SelectedItem Is Nothing Then Return + SettingService.SaveSetting(Me) + End Sub + +#End Region + End Class diff --git a/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb index 0bb1b3a..6f90827 100644 --- a/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb @@ -53,25 +53,26 @@ Set(value As Boolean) If _Show = value Then Return _Show = value - RunInUi(Sub() - If value Then - '有了 - Visibility = Visibility.Visible - AniStart({ - AaScaleTransform(Me, 0.3 - CType(RenderTransform, ScaleTransform).ScaleX, 500, 60, New AniEaseOutFluent(AniEasePower.Weak)), - AaScaleTransform(Me, 0.7, 500, 60, New AniEaseOutBack(AniEasePower.Weak)), - AaHeight(Me, 50 - Height, 200,, New AniEaseOutFluent(AniEasePower.Weak)) - }, "MyExtraButton MainScale " & Uuid) - Else - '没了 - AniStart({ - AaScaleTransform(Me, -CType(RenderTransform, ScaleTransform).ScaleX, 100,, New AniEaseInFluent(AniEasePower.Weak)), - AaHeight(Me, -Height, 400, 100, New AniEaseOutFluent()), - AaCode(Sub() Visibility = Visibility.Collapsed,, True) - }, "MyExtraButton MainScale " & Uuid) - End If - IsHitTestVisible = value '防止缩放动画中依然可以点进去 - End Sub) + RunInUi( + Sub() + If value Then + '有了 + Visibility = Visibility.Visible + AniStart({ + AaScaleTransform(Me, 0.3 - CType(RenderTransform, ScaleTransform).ScaleX, 500, 60, New AniEaseOutFluent(AniEasePower.Weak)), + AaScaleTransform(Me, 0.7, 500, 60, New AniEaseOutBack(AniEasePower.Weak)), + AaHeight(Me, 50 - Height, 200,, New AniEaseOutFluent(AniEasePower.Weak)) + }, "MyExtraButton MainScale " & Uuid) + Else + '没了 + AniStart({ + AaScaleTransform(Me, -CType(RenderTransform, ScaleTransform).ScaleX, 100,, New AniEaseInFluent(AniEasePower.Weak)), + AaHeight(Me, -Height, 400, 100, New AniEaseOutFluent()), + AaCode(Sub() Visibility = Visibility.Collapsed,, True) + }, "MyExtraButton MainScale " & Uuid) + End If + IsHitTestVisible = value '防止缩放动画中依然可以点进去 + End Sub) End Set End Property Public Delegate Function ShowCheckDelegate() As Boolean @@ -137,6 +138,7 @@ AaScaleTransform(PanScale, 1 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 300,, New AniEaseOutBack) }, "MyExtraButton Scale " & Uuid) End If + If IsLeftMouseHeld Then RaiseCustomEvent() IsLeftMouseHeld = False RefreshColor() '直接刷新颜色以判断是否已触发 MouseLeave End Sub @@ -199,16 +201,17 @@ ''' 发出一圈波浪效果提示。 ''' Public Sub Ribble() - RunInUi(Sub() - Dim Shape As New Border With {.CornerRadius = New CornerRadius(1000), .BorderThickness = New Thickness(0.001), .Opacity = 0.5, .RenderTransformOrigin = New Point(0.5, 0.5), .RenderTransform = New ScaleTransform()} - Shape.SetResourceReference(Border.BackgroundProperty, "ColorBrush5") - PanScale.Children.Insert(0, Shape) - AniStart({ - AaScaleTransform(Shape, 13, 1000, Ease:=New AniEaseInoutFluent(AniEasePower.Strong, 0.3)), - AaOpacity(Shape, -Shape.Opacity, 1000), - AaCode(Sub() PanScale.Children.Remove(Shape), After:=True) - }, "ExtraButton Ribble " & GetUuid()) - End Sub) + RunInUi( + Sub() + Dim Shape As New Border With {.CornerRadius = New CornerRadius(1000), .BorderThickness = New Thickness(0.001), .Opacity = 0.5, .RenderTransformOrigin = New Point(0.5, 0.5), .RenderTransform = New ScaleTransform()} + Shape.SetResourceReference(Border.BackgroundProperty, "ColorBrush5") + PanScale.Children.Insert(0, Shape) + AniStart({ + AaScaleTransform(Shape, 13, 1000, Ease:=New AniEaseInoutFluent(AniEasePower.Strong, 0.3)), + AaOpacity(Shape, -Shape.Opacity, 1000), + AaCode(Sub() PanScale.Children.Remove(Shape), After:=True) + }, "ExtraButton Ribble " & GetUuid()) + End Sub) End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb index 9784cd0..266ba47 100644 --- a/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb @@ -81,12 +81,12 @@ Public Class MyExtraTextButton '触发点击事件 Private Sub Button_LeftMouseUp(sender As Object, e As MouseButtonEventArgs) Handles PanClick.MouseLeftButtonUp - If IsLeftMouseHeld Then - Log("[Control] 按下附加图标按钮：" & Text) - RaiseEvent Click(sender, e) - e.Handled = True - Button_LeftMouseUp() - End If + If Not IsLeftMouseHeld Then Return + Log("[Control] 按下附加图标按钮：" & Text) + RaiseEvent Click(sender, e) + e.Handled = True + RaiseCustomEvent() + Button_LeftMouseUp() End Sub '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） diff --git a/Plain Craft Launcher 2/Controls/MyHint.xaml.vb b/Plain Craft Launcher 2/Controls/MyHint.xaml.vb index f26df16..9724691 100644 --- a/Plain Craft Launcher 2/Controls/MyHint.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyHint.xaml.vb @@ -99,21 +99,24 @@ Public Class MyHint End Property Public Property RelativeSetup As String = "" Private Sub MyHint_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded - If CanClose AndAlso Setup.Get(RelativeSetup) Then Visibility = Visibility.Collapsed + If CanClose AndAlso Settings.Get(RelativeSetup) Then Visibility = Visibility.Collapsed End Sub Private Sub BtnClose_Click(sender As Object, e As EventArgs) Handles BtnClose.Click - Setup.Set(RelativeSetup, True) + Settings.SetSafe(RelativeSetup, True) AniDispose(Me, False) End Sub '触发点击事件 + Public Event Click(sender As Object, e As MouseButtonEventArgs) Private IsMouseDown As Boolean = False Private Sub MyHint_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp If Not IsMouseDown Then Return IsMouseDown = False Log("[Control] 按下提示条" & If(String.IsNullOrEmpty(Name), "", "：" & Name)) + RaiseEvent Click(sender, e) + If e.Handled Then Return e.Handled = True - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub Private Sub MyHint_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True @@ -121,24 +124,6 @@ Public Class MyHint Private Sub MyHint_MouseLeave() Handles Me.MouseLeave IsMouseDown = False End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyHint), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyHint), New PropertyMetadata(Nothing)) End Class Partial Public Module ModAnimation diff --git a/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb index 5271696..5da1eaf 100644 --- a/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb @@ -48,36 +48,16 @@ End Set End Property - '触发点击事件 + '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） + Private IsMouseDown As Boolean = False Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp If Not IsMouseDown Then Return Log("[Control] 按下图标按钮" & If(String.IsNullOrEmpty(Name), "", "：" & Name)) RaiseEvent Click(sender, e) e.Handled = True Button_MouseUp() - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyIconButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyIconButton), New PropertyMetadata(Nothing)) - - '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） - Private IsMouseDown As Boolean = False Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True Focus() @@ -102,7 +82,6 @@ RefreshAnim() '直接刷新颜色以判断是否已触发 MouseLeave End Sub - '自定义事件 '务必放在 IsMouseDown 更新之后 Private Const AnimationColorIn As Integer = 120 Private Const AnimationColorOut As Integer = 150 diff --git a/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb index 47fdbf9..dd5ed21 100644 --- a/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb @@ -8,9 +8,6 @@ Public Class MyIconTextButton Public Uuid As Integer = GetUuid() Public Event Check(sender As Object, raiseByMouse As Boolean) Public Event Change(sender As Object, raiseByMouse As Boolean) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序可以引发本控件的 Change 事件 '自定义属性 @@ -76,7 +73,7 @@ Public Class MyIconTextButton Log("[Control] 按下带图标按钮：" & Text) IsMouseDown = False RaiseEvent Click(Me, New RouteEventArgs(True)) - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 RefreshColor() End Sub Private Sub MyIconTextButton_MouseDown() Handles Me.MouseLeftButtonDown @@ -87,24 +84,6 @@ Public Class MyIconTextButton IsMouseDown = False RefreshColor() End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyIconTextButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyIconTextButton), New PropertyMetadata(Nothing)) '动画 diff --git a/Plain Craft Launcher 2/Controls/MyImage.vb b/Plain Craft Launcher 2/Controls/MyImage.vb index 06ffc39..7ff8949 100644 --- a/Plain Craft Launcher 2/Controls/MyImage.vb +++ b/Plain Craft Launcher 2/Controls/MyImage.vb @@ -25,7 +25,7 @@ ''' ''' 与 Image 的 Source 类似。 - ''' 若输入以 http 开头的字符串，则会尝试下载图片然后显示，图片会保存为本地缓存。 + ''' 若输入以 http 开头的字符串，则会尝试下载图片然后显示；若 EnableCache 设为 True，图片还会保存为本地缓存。 ''' 支持 WebP 格式的图片。 ''' Public Shadows Property Source As String '覆写 Image 的 Source 属性 @@ -46,7 +46,7 @@ Sub(sender, e) If sender IsNot Nothing Then CType(sender, MyImage).Source = e.NewValue.ToString()))) ''' - ''' 当 Source 首次下载失败时，会从该备用地址加载图片。 + ''' 若 Source 是一个网络图片，该地址将作为第二图片源。 ''' Public Property FallbackSource As String Get @@ -85,8 +85,8 @@ If _ActualSource = value Then Return _ActualSource = value Try - Dim Bitmap As MyBitmap = If(value Is Nothing, Nothing, New MyBitmap(value)) '在这里先触发可能的文件读取，尽量避免在 UI 线程中读取文件 - RunInUiWait(Sub() MyBase.Source = Bitmap) + Dim Bitmap As ImageSource = If(value Is Nothing, Nothing, New MyBitmap(value)) '在这里先触发可能的文件读取，尽量避免在 UI 线程中读取文件 + RunInUi(Sub() MyBase.Source = Bitmap) Catch ex As Exception Log(ex, $"加载图片失败（{value}）") Try @@ -111,79 +111,46 @@ Return End If '从缓存加载网络图片 - Dim Url As String = Source - Dim Retried As Boolean = False - Dim TempPath As String = GetTempPath(Url) - Dim TempFile As New FileInfo(TempPath) Dim EnableCache As Boolean = Me.EnableCache + Dim TempPath As String = $"{PathTemp}MyImage\{GetHash(Source)}.png{If(EnableCache, "", GetUuid())}" '不启用缓存时在末尾加上随机字符串，避免冲突 + Dim TempFile As New FileInfo(TempPath) If EnableCache AndAlso TempFile.Exists Then - ActualSource = TempPath + ActualSource = TempPath '显示缓存的图片 If (Date.Now - TempFile.LastWriteTime) < FileCacheExpiredTime Then Return '无需刷新缓存 + Else + ActualSource = LoadingSource '显示加载中图片 End If RunInNewThread( Sub() - Dim TempDownloadingPath As String = Nothing + Dim IsLocalFallback As Boolean = Not String.IsNullOrEmpty(FallbackSource) AndAlso Not FallbackSource.StartsWithF("http") Try -RetryStart: '下载 - ActualSource = LoadingSource '显示加载中图片 - TempDownloadingPath = TempPath & RandomInteger(0, 10000000) - Directory.CreateDirectory(GetPathFromFullPath(TempPath)) '重新实现下载，以避免携带 Header（#5072） - Using Client As New Net.WebClient - Client.DownloadFile(Url, TempDownloadingPath) - End Using - If Url <> Source AndAlso Url <> FallbackSource Then - '已经更换了地址 - File.Delete(TempDownloadingPath) - ElseIf EnableCache Then - '保存缓存并显示 - If File.Exists(TempPath) Then File.Delete(TempPath) - FileSystem.Rename(TempDownloadingPath, TempPath) - RunInUi(Sub() ActualSource = TempPath) - Else - '直接显示 - RunInUiWait(Sub() ActualSource = TempDownloadingPath) - File.Delete(TempDownloadingPath) - End If + NetDownloadByLoader( + If(FallbackSource IsNot Nothing AndAlso FallbackSource.StartsWithF("http") AndAlso Source <> FallbackSource, + {Source, FallbackSource}, {Source}), + TempPath, SimulateBrowserHeaders:=True) + ActualSource = TempPath + If Not EnableCache Then File.Delete(TempPath) Catch ex As Exception Try If TempPath IsNot Nothing Then File.Delete(TempPath) - If TempDownloadingPath IsNot Nothing Then File.Delete(TempDownloadingPath) Catch End Try - If Not Retried Then - '更换备用地址 - Log(ex, $"下载图片可重试地失败（{Url}）", LogLevel.Developer) - Retried = True - Url = If(FallbackSource, Source) - '空 - If Url Is Nothing Then - ActualSource = Nothing + '加载本地备用图片 + If IsLocalFallback Then + Try + ActualSource = FallbackSource + Log(ex, $"下载图片失败，使用本地备用图片（{Source}）") Return - End If - '本地图片 - If Not Url.StartsWithF("http") Then - ActualSource = Url - Return - End If - '从缓存加载网络图片 - TempPath = GetTempPath(Url) - TempFile = New FileInfo(TempPath) - If EnableCache AndAlso TempFile.Exists() Then - ActualSource = TempPath - If (Date.Now - TempFile.CreationTime) < FileCacheExpiredTime Then Return '无需刷新缓存 - End If - '下载 - If Source = Url Then Thread.Sleep(1000) '延迟 1s 重试 - GoTo RetryStart + Catch exx As Exception + Log(ex, $"下载图片失败（{Source}）", LogLevel.Hint) + Log(exx, $"加载备用图片失败（{FallbackSource}）", LogLevel.Hint) + End Try Else - Log(ex, $"下载图片失败（{Url}）", LogLevel.Hint) + Log(ex, $"下载图片失败（{Source}，备用：{FallbackSource}）", LogLevel.Hint) End If End Try End Sub, "MyImage PicLoader " & GetUuid() & "#", ThreadPriority.BelowNormal) End Sub - Public Shared Function GetTempPath(Url As String) As String - Return $"{PathTemp}MyImage\{GetHash(Url)}.png" - End Function End Class \ No newline at end of file diff --git a/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb b/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb index 0f5fd3f..b0ff29f 100644 --- a/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb @@ -396,6 +396,7 @@ Public Class MyListItem Dim CheckedCount As Integer = 0 '收集控件列表与选中个数 For Each Control In CType(Parent, Object).Children + Control = MyVirtualizingElement.TryInit(Control) If TypeOf Control Is MyListItem AndAlso CType(Control, MyListItem).Type = CheckType.RadioBox Then RadioboxList.Add(Control) If Control.Checked Then CheckedCount += 1 @@ -506,8 +507,8 @@ Public Class MyListItem RaiseEvent Click(sender, e) If e.Handled Then Return '触发自定义事件 - If Not String.IsNullOrEmpty(EventType) Then - ModEvent.TryStartEvent(EventType, EventData) + If CustomEventService.GetEventType(sender) <> CustomEvent.EventType.None Then + RaiseCustomEvent() e.Handled = True End If If e.Handled Then Return @@ -537,26 +538,6 @@ Public Class MyListItem If ButtonStack IsNot Nothing Then ButtonStack.IsHitTestVisible = True End Sub - '实现自定义事件 - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyListItem), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyListItem), New PropertyMetadata(Nothing)) - #End Region Private StateLast As String @@ -564,7 +545,7 @@ Public Class MyListItem Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp '菜单虚拟化检测 If ContentHandler IsNot Nothing Then - ContentHandler(sender, e) + ContentHandler(Me, e) ContentHandler = Nothing End If '判断当前颜色 @@ -657,13 +638,14 @@ Public Class MyListItem SetResourceReference(ForegroundProperty, "ColorBrush1") End If ColumnPaddingRight.Width = New GridLength(MinPaddingRight) - If EventType = "打开帮助" AndAlso Not (Title <> "" AndAlso Info <> "") Then '#3266 + If CustomEventService.GetEventType(Me) = CustomEvent.EventType.打开帮助 AndAlso Not (Title <> "" AndAlso Info <> "") Then '#3266 Try - Dim Unused = New HelpEntry(GetEventAbsoluteUrls(EventData, EventType)(0)).SetToListItem(Me) + Dim Entry As New HelpEntry(CustomEvent.GetAbsoluteUrls(CustomEventService.GetEventData(Me), CustomEventService.GetEventType(Me))(0)) + Entry.SetToListItem(Me) Catch ex As Exception Log(ex, "设置帮助 MyListItem 失败", LogLevel.Msgbox) - EventType = Nothing - EventData = Nothing + CustomEventService.SetEventType(Me, CustomEvent.EventType.None) + CustomEventService.SetEventData(Me, "") End Try End If End Sub diff --git a/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb b/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb index b6a4638..e4f6785 100644 --- a/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb @@ -79,11 +79,7 @@ Public Class MyLoading Do While Ex.InnerException IsNot Nothing Ex = Ex.InnerException Loop - LabText.Text = StrTrim(Ex.Message) - If {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", - "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) LabText.Text.Contains(s)) Then - LabText.Text = "网络环境不佳，请稍后重试，或使用 VPN 以改善网络环境" - End If + LabText.Text = If(Ex.IsNetworkRelated(), "网络环境不佳，请稍后再试，或使用 VPN 改善网络环境", StrTrim(Ex.Message)) End If Else LabText.Text = TextError @@ -187,30 +183,29 @@ Public Class MyLoading IsLooping = True ErrorAnimationWaiting = True AniStart({ - AaRotateTransform(PathPickaxe, -20 - CType(PathPickaxe.RenderTransform, RotateTransform).Angle, 350, 250, New AniEaseInBack(AniEasePower.Weak)), - AaRotateTransform(PathPickaxe, 50, 900,, New AniEaseOutFluent, True), - AaRotateTransform(PathPickaxe, 25, 900,, New AniEaseOutElastic(AniEasePower.Weak)), - AaCode(Sub() - PathLeft.Opacity = 1 - PathLeft.Margin = New Thickness(7, 41, 0, 0) - PathRight.Opacity = 1 - PathRight.Margin = New Thickness(14, 41, 0, 0) - ErrorAnimationWaiting = False - End Sub), - AaOpacity(PathLeft, -1, 100, 50), - AaX(PathLeft, -5, 180,, New AniEaseOutFluent), - AaY(PathLeft, -6, 180,, New AniEaseOutFluent), - AaOpacity(PathRight, -1, 100, 50), - AaX(PathRight, 5, 180,, New AniEaseOutFluent), - AaY(PathRight, -6, 180,, New AniEaseOutFluent), - AaCode(Sub() - IsLooping = False - AniLoop() - End Sub,, True) - }, "MyLoader Loop " & Uuid & "/" & GetUuid()) - If ShowProgress Then - - End If + AaRotateTransform(PathPickaxe, -20 - CType(PathPickaxe.RenderTransform, RotateTransform).Angle, 350, 250, New AniEaseInBack(AniEasePower.Weak)), + AaRotateTransform(PathPickaxe, 50, 900,, New AniEaseOutFluent, True), + AaRotateTransform(PathPickaxe, 25, 900,, New AniEaseOutElastic(AniEasePower.Weak)), + AaCode( + Sub() + PathLeft.Opacity = 1 + PathLeft.Margin = New Thickness(7, 41, 0, 0) + PathRight.Opacity = 1 + PathRight.Margin = New Thickness(14, 41, 0, 0) + ErrorAnimationWaiting = False + End Sub), + AaOpacity(PathLeft, -1, 100, 50), + AaX(PathLeft, -5, 180,, New AniEaseOutFluent), + AaY(PathLeft, -6, 180,, New AniEaseOutFluent), + AaOpacity(PathRight, -1, 100, 50), + AaX(PathRight, 5, 180,, New AniEaseOutFluent), + AaY(PathRight, -6, 180,, New AniEaseOutFluent), + AaCode( + Sub() + IsLooping = False + AniLoop() + End Sub,, True) + }, "MyLoader Loop " & Uuid & "/" & GetUuid()) End Sub ''' diff --git a/Plain Craft Launcher 2/Controls/MyMenuItem.vb b/Plain Craft Launcher 2/Controls/MyMenuItem.vb index cc70ee6..629456a 100644 --- a/Plain Craft Launcher 2/Controls/MyMenuItem.vb +++ b/Plain Craft Launcher 2/Controls/MyMenuItem.vb @@ -7,7 +7,7 @@ If IconControl IsNot Nothing Then IconControl.Data = (New GeometryConverter).ConvertFromString(Icon) End If '对父级设置透明度 - CType(Parent, ContextMenu).Opacity = Setup.Get("UiLauncherTransparent") / 1000 + 0.4 + CType(Parent, ContextMenu).Opacity = Settings.Get("UiLauncherTransparent") / 1000 + 0.4 End Sub '基础 @@ -54,4 +54,7 @@ End If End Sub + Private Sub MyMenuItem_Click(sender As Object, e As RoutedEventArgs) Handles Me.Click + RaiseCustomEvent() + End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyMsg/MyMsgSelect.xaml.vb b/Plain Craft Launcher 2/Controls/MyMsg/MyMsgSelect.xaml.vb index 59bb7fc..72e72ec 100644 --- a/Plain Craft Launcher 2/Controls/MyMsg/MyMsgSelect.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyMsg/MyMsgSelect.xaml.vb @@ -21,7 +21,9 @@ ShapeLine.StrokeThickness = GetWPFSize(1) '添加选择控件 Btn1.IsEnabled = False - For Each Selection As IMyRadio In Converter.Content + For Each Content In Converter.Content + Content = MyVirtualizingElement.TryInit(Content) + Dim Selection As IMyRadio = Content PanSelection.Children.Add(Selection) AddHandler Selection.Check, AddressOf OnChecked If TypeOf Selection Is MyListItem Then diff --git a/Plain Craft Launcher 2/Controls/MyPageLeft.vb b/Plain Craft Launcher 2/Controls/MyPageLeft.vb index da00f6f..aceae13 100644 --- a/Plain Craft Launcher 2/Controls/MyPageLeft.vb +++ b/Plain Craft Launcher 2/Controls/MyPageLeft.vb @@ -3,15 +3,15 @@ Private Uuid As Integer = GetUuid() '执行逐个进入动画的控件 - Public Property AnimatedControl As FrameworkElement + Public Property AnimatedControl As String '需要在 Loaded 之后才能获取到控件，所以不能用 Binding 直接绑定（#6664） Get Return GetValue(AnimatedControlProperty) End Get - Set(value As FrameworkElement) + Set(value As String) SetValue(AnimatedControlProperty, value) End Set End Property - Public Shared ReadOnly AnimatedControlProperty As DependencyProperty = DependencyProperty.Register("AnimatedControl", GetType(FrameworkElement), GetType(MyPageLeft), New PropertyMetadata(Nothing)) + Public Shared ReadOnly AnimatedControlProperty As DependencyProperty = DependencyProperty.Register("AnimatedControl", GetType(String), GetType(MyPageLeft), New PropertyMetadata(Nothing)) Public Sub TriggerShowAnimation() If AnimatedControl Is Nothing Then @@ -30,6 +30,7 @@ Dim AniList As New List(Of AniData) Dim Id As Integer = 0, Delay As Integer = 0 For Each Element As FrameworkElement In GetAllAnimControls(True) + Element = MyVirtualizingElement.TryInit(Element) If Element.Visibility = Visibility.Collapsed Then '还原之前的隐藏动画可能导致的改变（#2436） Element.Opacity = 1 @@ -84,7 +85,7 @@ '遍历获取所有需要生成动画的控件 Private Function GetAllAnimControls(Optional IgnoreInvisibility As Boolean = False) As List(Of FrameworkElement) Dim AllControls As New List(Of FrameworkElement) - GetAllAnimControls(AnimatedControl, AllControls, IgnoreInvisibility) + GetAllAnimControls(FindName(AnimatedControl), AllControls, IgnoreInvisibility) Return AllControls End Function Private Sub GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean) @@ -105,7 +106,3 @@ End Sub End Class - -Public Interface IRefreshable - Sub Refresh() -End Interface \ No newline at end of file diff --git a/Plain Craft Launcher 2/Controls/MyPageRight.vb b/Plain Craft Launcher 2/Controls/MyPageRight.vb index 59545f5..ba337ce 100644 --- a/Plain Craft Launcher 2/Controls/MyPageRight.vb +++ b/Plain Craft Launcher 2/Controls/MyPageRight.vb @@ -3,16 +3,16 @@ Public PageUuid As Integer = GetUuid() '“返回顶部” 按钮检测的滚动区域 - Public Property PanScroll As MyScrollViewer + Public Property PanScroll As String '需要在 Loaded 之后才能获取到控件，所以不能用 Binding 直接绑定（#6664） Get Return GetValue(PanScrollProperty) End Get - Set(value As MyScrollViewer) + Set(value As String) SetValue(PanScrollProperty, value) End Set End Property Private Shared ReadOnly PanScrollProperty = - DependencyProperty.Register("PanScroll", GetType(MyScrollViewer), GetType(MyPageRight), New PropertyMetadata(Nothing)) + DependencyProperty.Register("PanScroll", GetType(String), GetType(MyPageRight), New PropertyMetadata(Nothing)) '当前状态 Public Enum PageStates @@ -129,30 +129,31 @@ RaiseEvent PageEnter() Select Case PageState Case PageStates.Empty - If PageLoader Is Nothing OrElse PageLoader.State = LoadState.Finished OrElse PageLoader.State = LoadState.Waiting OrElse PageLoader.State = LoadState.Aborted Then - '如果加载器在进入页面时不启动（例如 HiPer 联机），那么在此时就会有 State = Waiting + If PageLoader Is Nothing OrElse PageLoader.State = LoadState.Finished OrElse PageLoader.State = LoadState.Waiting OrElse PageLoader.State = LoadState.Interrupted Then + '如果加载器在进入页面时不启动（例如联机），那么在此时就会有 State = Waiting PageState = PageStates.ContentEnter TriggerEnterAnimation(PanAlways, If(PanContent, Child)) ElseIf PageLoader.State = LoadState.Loading Then PageState = PageStates.LoaderWait - AniStart(AaCode(AddressOf PageOnLoaderWaitFinished, 200), "PageRight PageChange " & PageUuid) + AniStart(AaCode(AddressOf PageOnLoaderWaitFinished, 400), "PageRight PageChange " & PageUuid) Else 'PageLoader.State = LoadState.Failed PageState = PageStates.LoaderEnter TriggerEnterAnimation(PanAlways, PanLoader) End If Case PageStates.ContentExit '和上面的一样，但是不管 PanAlways - If PageLoader Is Nothing OrElse PageLoader.State = LoadState.Finished OrElse PageLoader.State = LoadState.Waiting OrElse PageLoader.State = LoadState.Aborted Then + If PageLoader Is Nothing OrElse PageLoader.State = LoadState.Finished OrElse PageLoader.State = LoadState.Waiting OrElse PageLoader.State = LoadState.Interrupted Then PageState = PageStates.ContentEnter TriggerEnterAnimation(If(PanContent, Child)) ElseIf PageLoader.State = LoadState.Loading Then PageState = PageStates.LoaderWait - AniStart(AaCode(AddressOf PageOnLoaderWaitFinished, 200), "PageRight PageChange " & PageUuid) + AniStart(AaCode(AddressOf PageOnLoaderWaitFinished, 400), "PageRight PageChange " & PageUuid) Else 'PageLoader.State = LoadState.Failed PageState = PageStates.LoaderEnter TriggerEnterAnimation(PanLoader) End If - Case PageStates.ContentEnter '重复调用 PageOnEnter，直接忽略 + Case PageStates.ContentEnter + '重复调用 PageOnEnter，直接忽略 Case Else Throw New Exception("在状态为 " & GetStringFromEnum(PageState) & " 时触发了 PageOnEnter 事件。") End Select @@ -207,8 +208,8 @@ Public Sub PageOnContentExit() If ModeDebug Then Log("[UI] 已触发 PageOnContentExit") If PageLoader IsNot Nothing AndAlso PageLoader.State = LoadState.Loading Then - Throw New Exception("在调用 PageOnContentExit 时，加载器不能为 Loading 状态") 'Loading 的加载器可能触发进一步变化，难以预测会触发子页面的动画还是加载器完成的动画 + Throw New Exception("在调用 PageOnContentExit 时，加载器不能为 Loading 状态") End If Select Case PageState Case PageStates.ContentEnter, PageStates.ContentStay @@ -219,8 +220,12 @@ Case PageStates.LoaderEnter, PageStates.LoaderStayForce, PageStates.LoaderStay PageState = PageStates.ContentExit TriggerExitAnimation(PanLoader) - Case PageStates.LoaderWait, PageStates.Empty + Case PageStates.LoaderWait PageOnEnter() + Case PageStates.Empty + '可能是在离开页面后，其他后台线程调用了本函数，此时不应触发 PageOnEnter() + '例如：在加入联机房间后，切换到其他页面，然后联机房间被解散 + If IsLoaded Then PageOnEnter() End Select End Sub @@ -313,9 +318,9 @@ Case PageStates.LoaderExit PageState = PageStates.ContentExit End Select - Case LoadState.Finished, LoadState.Aborted, LoadState.Waiting + Case LoadState.Finished, LoadState.Interrupted, LoadState.Waiting If Not (OldState = LoadState.Failed OrElse OldState = LoadState.Loading) Then Return - If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Stop/Abort)") + If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Stop/Interrupt)") '运行结束 '需要从 LoaderWait 切换到 ContentEnter，或从 LoaderStay 切换到 LoaderExit Select Case PageState @@ -373,7 +378,7 @@ End If '结束 AniList.Add(AaCode(Sub() PageOnEnterAnimationFinished(),, True)) - AniStart(AniList, "PageRight PageChange " & PageUuid) + AniStart(AniList, "PageRight PageChange " & PageUuid, True) End Sub '逐个退出动画 diff --git a/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb b/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb index 5dd839f..59d55ff 100644 --- a/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb @@ -2,7 +2,7 @@ Public Class MyRadioBox - Implements IMyRadio + Implements IMyRadio, ISettingControl '基础 @@ -89,14 +89,15 @@ Public Class MyRadioBox End If End Select - '触发事件 If IsChanged Then + '触发事件 If Checked Then RaiseEvent Check(Me, New RouteEventArgs(user)) RaiseEvent Changed(Me, New RouteEventArgs(user)) + RaiseCustomEvent() + '更改动画 + SyncUI() End If - '更改动画 - SyncUI() Catch ex As Exception Log(ex, "单选框勾选改变错误", LogLevel.Hint) End Try @@ -115,7 +116,7 @@ Public Class MyRadioBox AaOpacity(ShapeDot, 1 - ShapeDot.Opacity, AnimationTimeOfCheck * 0.5, AnimationTimeOfCheck * 0.6) }, "MyRadioBox Dot " & Uuid) AniStart({ - AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsMouseOver, "ColorBrush3", If(IsEnabled, "ColorBrush2", "ColorBrushGray4")), AnimationTimeOfCheck) + AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsMouseOver, "ColorBrush3", If(IsEnabled, "ColorBrush2", "ColorBrushGray5")), AnimationTimeOfCheck) }, "MyRadioBox BorderColor " & Uuid) Else '由有变无 @@ -127,7 +128,7 @@ Public Class MyRadioBox AaOpacity(ShapeDot, -ShapeDot.Opacity, AnimationTimeOfCheck * 0.5, AnimationTimeOfCheck * 0.2) }, "MyRadioBox Dot " & Uuid) AniStart({ - AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsMouseOver, "ColorBrush3", If(IsEnabled, "ColorBrush1", "ColorBrushGray4")), AnimationTimeOfCheck) + AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsMouseOver, "ColorBrush3", If(IsEnabled, "ColorBrush1", "ColorBrushGray5")), AnimationTimeOfCheck) }, "MyRadioBox BorderColor " & Uuid) End If Else @@ -140,13 +141,13 @@ Public Class MyRadioBox ShapeDot.Height = 9 ShapeDot.Opacity = 1 ShapeDot.Margin = New Thickness(5.5, 0, 0, 0) - ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, "ColorBrush2", "ColorBrushGray4")) + ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, "ColorBrush2", "ColorBrushGray5")) Else ShapeDot.Width = 0 ShapeDot.Height = 0 ShapeDot.Opacity = 0 ShapeDot.Margin = New Thickness(10, 0, 0, 0) - ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4")) + ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray5")) End If End If End Sub @@ -208,15 +209,15 @@ Public Class MyRadioBox Radiobox_MouseLeaveAnimation() Else '不可用 - AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, ColorGray4 - ShapeBorder.Stroke, AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid) - AniStart(AaColor(LabText, TextBlock.ForegroundProperty, ColorGray4 - LabText.Foreground, AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid) + AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, ColorGray5 - ShapeBorder.Stroke, AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid) + AniStart(AaColor(LabText, TextBlock.ForegroundProperty, ColorGray5 - LabText.Foreground, AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid) End If Else '无动画 AniStop("MyRadioBox BorderColor " & Uuid) AniStop("MyRadioBox TextColor " & Uuid) - LabText.SetResourceReference(TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray4")) - ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4")) + LabText.SetResourceReference(TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray5")) + ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(Me.IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray5")) End If End Sub Private Sub Radiobox_MouseEnterAnimation() Handles Me.MouseEnter @@ -226,14 +227,30 @@ Public Class MyRadioBox Private Sub Radiobox_MouseLeaveAnimation() Handles Me.MouseLeave If Not Me.IsEnabled Then Return 'MouseLeave 比 IsEnabledChanged 后执行，所以如果自定义事件修改了 IsEnabled，将导致显示错误 If IsLoaded AndAlso AniControlEnabled = 0 Then - AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid) - AniStart(AaColor(LabText, TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid) + AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray5"), AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid) + AniStart(AaColor(LabText, TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray5"), AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid) Else AniStop("MyRadioBox BorderColor " & Uuid) AniStop("MyRadioBox TextColor " & Uuid) - ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4")) - LabText.SetResourceReference(TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4")) + ShapeBorder.SetResourceReference(Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray5")) + LabText.SetResourceReference(TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray5")) End If End Sub +#Region "设置" + + Private Sub RefreshSetting(NewValue As String) Implements ISettingControl.RefreshSetting + Checked = NewValue = SettingService.GetValue(Me) + End Sub + + Private Function GetCurrentSetting() As String Implements ISettingControl.GetCurrentSetting + Return If(Checked, SettingService.GetValue(Me), Nothing) + End Function + + Private Sub SaveSetting() Handles Me.Check + SettingService.SaveSetting(Me) + End Sub + +#End Region + End Class diff --git a/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb index 4be05b8..2753034 100644 --- a/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb @@ -7,10 +7,6 @@ Public Class MyRadioButton Public Uuid As Integer = GetUuid() Public Event Check(sender As Object, raiseByMouse As Boolean) - Public Event Change(sender As Object, raiseByMouse As Boolean) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序可以引发本控件的 Change 事件 '自定义属性 @@ -46,23 +42,22 @@ Public Class MyRadioButton ''' 手动设置 Checked 属性。 ''' ''' 新的 Checked 属性。 - ''' 是否由用户引发。 + ''' 是否由用户引发。 ''' 是否执行动画。 - Public Sub SetChecked(value As Boolean, user As Boolean, anime As Boolean) + Public Sub SetChecked(value As Boolean, raiseByMouse As Boolean, anime As Boolean) Try '自定义属性基础 Dim IsChanged As Boolean = False - If IsLoaded AndAlso Not value = _Checked Then RaiseEvent Change(Me, user) - If Not value = _Checked Then + If _Checked <> value Then _Checked = value IsChanged = True End If '保证只有一个单选框选中 - If IsNothing(Parent) Then Return + If Parent Is Nothing Then Return Dim RadioboxList As New List(Of MyRadioButton) Dim CheckedCount As Integer = 0 '收集控件列表与选中个数 @@ -105,7 +100,8 @@ Public Class MyRadioButton RefreshColor(Nothing, anime) '触发事件 - If Checked Then RaiseEvent Check(Me, user) + If Checked Then RaiseEvent Check(Me, raiseByMouse) + RaiseCustomEvent() Catch ex As Exception Log(ex, "单选按钮勾选改变错误", LogLevel.Hint) diff --git a/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb b/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb index ee3bb15..a8fde05 100644 --- a/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb @@ -39,4 +39,7 @@ TextBox.Focus() End Sub + Private Sub MySearchBox_KeyUp(sender As Object, e As KeyEventArgs) Handles Me.KeyUp + If e.Key = Key.Enter Then RaiseCustomEvent() + End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MySlider.xaml.vb b/Plain Craft Launcher 2/Controls/MySlider.xaml.vb index 0a3b9ca..4077891 100644 --- a/Plain Craft Launcher 2/Controls/MySlider.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MySlider.xaml.vb @@ -1,4 +1,5 @@ Public Class MySlider + Implements ISettingControl '基础 @@ -188,4 +189,20 @@ End If End Sub +#Region "设置" + + Private Sub RefreshSetting(NewValue As String) Implements ISettingControl.RefreshSetting + Value = Val(NewValue) + End Sub + + Private Function GetCurrentSetting() As String Implements ISettingControl.GetCurrentSetting + Return Value + End Function + + Private Sub SaveSetting() Handles Me.Change + SettingService.SaveSetting(Me) + End Sub + +#End Region + End Class \ No newline at end of file diff --git a/Plain Craft Launcher 2/Controls/MyTextBox.vb b/Plain Craft Launcher 2/Controls/MyTextBox.vb index 9149737..2b84873 100644 --- a/Plain Craft Launcher 2/Controls/MyTextBox.vb +++ b/Plain Craft Launcher 2/Controls/MyTextBox.vb @@ -1,5 +1,6 @@ Public Class MyTextBox Inherits TextBox + Implements ISettingControl '自定义属性 @@ -44,7 +45,13 @@ Public Uuid As Integer = GetUuid() Public Shared Event ValidateChanged(sender As Object, e As EventArgs) - Public ChangedEventList As New List(Of RoutedEventHandler) + Private _ChangedEventList As List(Of RoutedEventHandler) + Public ReadOnly Property ChangedEventList As List(Of RoutedEventHandler) + Get + If _ChangedEventList Is Nothing Then _ChangedEventList = New List(Of RoutedEventHandler) + Return _ChangedEventList + End Get + End Property Public Custom Event ValidatedTextChanged As RoutedEventHandler AddHandler(value As RoutedEventHandler) ChangedEventList.Add(value) @@ -264,7 +271,7 @@ If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 '有动画 AniStart({ - AaColor(Me, BorderBrushProperty, ForeColorName, AnimationTime)， + AaColor(Me, BorderBrushProperty, ForeColorName, AnimationTime), AaColor(Me, BackgroundProperty, BackColorName, AnimationTime) }, "MyTextBox Color " & Uuid) Else @@ -291,4 +298,25 @@ End If End Sub + '在按下回车时触发自定义事件 + Private Sub MyTextBox_KeyUp(sender As Object, e As KeyEventArgs) Handles Me.KeyUp + If e.Key = Key.Enter Then RaiseCustomEvent() + End Sub + +#Region "设置" + + Private Sub RefreshSetting(NewValue As String) Implements ISettingControl.RefreshSetting + Text = NewValue + End Sub + + Private Function GetCurrentSetting() As String Implements ISettingControl.GetCurrentSetting + Return Text + End Function + + Private Sub SaveSetting() Handles Me.ValidatedTextChanged + SettingService.SaveSetting(Me) + End Sub + +#End Region + End Class diff --git a/Plain Craft Launcher 2/Controls/MyTextButton.vb b/Plain Craft Launcher 2/Controls/MyTextButton.vb index b7e3a73..4bde410 100644 --- a/Plain Craft Launcher 2/Controls/MyTextButton.vb +++ b/Plain Craft Launcher 2/Controls/MyTextButton.vb @@ -22,15 +22,15 @@ End Set End Property Public Shared ReadOnly TextProperty As DependencyProperty = - DependencyProperty.Register("Text", GetType(String), GetType(MyTextButton), New PropertyMetadata("", Sub(sender As MyTextButton, e As DependencyPropertyChangedEventArgs) - If Not e.OldValue = e.NewValue Then - AniStart({ - AaOpacity(sender, -sender.Opacity, 50), - AaCode(Sub() sender.Content = e.NewValue,, True), - AaOpacity(sender, 1, 170) - }, "MyTextButton Text " & sender.Uuid) - End If - End Sub)) + DependencyProperty.Register("Text", GetType(String), GetType(MyTextButton), New PropertyMetadata("", + Sub(sender As MyTextButton, e As DependencyPropertyChangedEventArgs) + If e.OldValue = e.NewValue Then Return + AniStart({ + AaOpacity(sender, -sender.Opacity, 50), + AaCode(Sub() sender.Content = e.NewValue,, True), + AaOpacity(sender, 1, 170) + }, "MyTextButton Text " & sender.Uuid) + End Sub)) '鼠标事件 @@ -43,13 +43,12 @@ IsMouseDown = False End Sub Private Sub MyTextButton_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp - If IsMouseDown Then - IsMouseDown = False - Log("[Control] 按下文本按钮：" & Text) - RaiseEvent Click(Me, Nothing) - ModEvent.TryStartEvent(EventType, EventData) - e.Handled = True - End If + If Not IsMouseDown Then Return + IsMouseDown = False + Log("[Control] 按下文本按钮：" & Text) + RaiseEvent Click(Me, Nothing) + RaiseCustomEvent() + e.Handled = True End Sub '指向动画 @@ -57,7 +56,7 @@ Private Const AnimationTimeIn As Integer = 100 Private Const AnimationTimeOut As Integer = 200 Private ColorName As String - Private Sub RefreshColor() Handles Me.MouseEnter, Me.MouseLeave, Me.IsEnabledChanged, Me.MouseLeftButtonDown， Me.MouseLeftButtonUp + Private Sub RefreshColor() Handles Me.MouseEnter, Me.MouseLeave, Me.IsEnabledChanged, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp '判断当前颜色 Dim ForeName As String Dim Time As Integer @@ -85,26 +84,4 @@ End If End Sub - '实现自定义事件 - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register( - "EventType", GetType(String), GetType(MyTextButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register( - "EventData", GetType(String), GetType(MyTextButton), New PropertyMetadata(Nothing)) - End Class diff --git a/Plain Craft Launcher 2/Controls/MyVirtualizingElement.vb b/Plain Craft Launcher 2/Controls/MyVirtualizingElement.vb new file mode 100644 index 0000000..c9a5265 --- /dev/null +++ b/Plain Craft Launcher 2/Controls/MyVirtualizingElement.vb @@ -0,0 +1,70 @@ +Public Class MyVirtualizingElement(Of T As FrameworkElement) + Inherits FrameworkElement + + Private Initializer As Func(Of T) + Public Sub New(Initializer As Func(Of T)) + Me.Initializer = Initializer + LazyLoadBehavior.OnFirstEnterScrollViewerViewport(Me, AddressOf Init) + End Sub + + ''' + ''' 实例化此控件。 + ''' + Public Function Init() As T + Dim Element As T = Initializer() + If Parent IsNot Nothing Then + If TypeOf Parent IsNot Panel Then Throw New Exception("MyVirtualizingElement 的父级必须是一个 Panel") + Dim ParentPanel As Panel = Parent + Dim CurrentIndex As Integer = ParentPanel.Children.IndexOf(Me) + ParentPanel.Children.RemoveAt(CurrentIndex) + ParentPanel.Children.Insert(CurrentIndex, Element) + End If + Return Element + End Function + Public Shared Widening Operator CType(Virtualized As MyVirtualizingElement(Of T)) As T + Return Virtualized.Init() + End Operator + +End Class + +'非泛型形式 +Public Class MyVirtualizingElement + Inherits FrameworkElement + + Private Initializer As Func(Of FrameworkElement) + Public Sub New(Initializer As Func(Of FrameworkElement)) + Me.Initializer = Initializer + LazyLoadBehavior.OnFirstEnterScrollViewerViewport(Me, AddressOf Init) + End Sub + + ''' + ''' 实例化此控件。 + ''' + Public Function Init() As FrameworkElement + Dim Element As FrameworkElement = Initializer() + If Parent IsNot Nothing Then + If TypeOf Parent IsNot Panel Then Throw New Exception("MyVirtualizingElement 的父级必须是一个 Panel") + Dim ParentPanel As Panel = Parent + Dim CurrentIndex As Integer = ParentPanel.Children.IndexOf(Me) + ParentPanel.Children.RemoveAt(CurrentIndex) + ParentPanel.Children.Insert(CurrentIndex, Element) + End If + Return Element + End Function + + ''' + ''' 获取实例化后的控件。 + ''' 如果该控件没有实例化，则会立即实例化。 + ''' 如果类型错误，则返回原值。 + ''' + Public Shared Function TryInit(Element As FrameworkElement) As FrameworkElement + If GetType(MyVirtualizingElement(Of )).IsInstanceOfGenericType(Element) Then + Return CType(Element, Object).Init() + ElseIf TypeOf Element Is MyVirtualizingElement Then + Return CType(Element, MyVirtualizingElement).Init() + Else + Return Element + End If + End Function + +End Class diff --git a/Plain Craft Launcher 2/FormMain.xaml b/Plain Craft Launcher 2/FormMain.xaml index 0582efb..1236d58 100644 --- a/Plain Craft Launcher 2/FormMain.xaml +++ b/Plain Craft Launcher 2/FormMain.xaml @@ -95,7 +95,8 @@ - + diff --git a/Plain Craft Launcher 2/FormMain.xaml.vb b/Plain Craft Launcher 2/FormMain.xaml.vb index b9a8d1d..fd8cee3 100644 --- a/Plain Craft Launcher 2/FormMain.xaml.vb +++ b/Plain Craft Launcher 2/FormMain.xaml.vb @@ -1,4 +1,5 @@ Imports System.ComponentModel +Imports System.Windows.Interop Public Class FormMain @@ -10,6 +11,83 @@ Public Class FormMain Dim FeatureList As New List(Of KeyValuePair(Of Integer, String)) '统计更新日志条目 #If BETA Then + If LastVersion < 391 Then 'Release 2.12.6.2 + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：会为部分 Forge / NeoForge 选择不支持的 Java")) + BugCount += 4 + End If + If LastVersion < 389 Then 'Release 2.12.6.1 + If LastVersion = 387 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法使用 Java 25+ 启动 Forge")) + FeatureCount += 4 + BugCount += 3 + End If + If LastVersion < 387 Then 'Release 2.12.6 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：降低 Minecraft 的内存占用")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：Minecraft 使用 Java 25+ 时的一个性能问题")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法下载 NeoForge 26.1")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：部分关键词搜不到资源，特别是中文 Mod 搜索经常没有结果")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：老版本 Windows 无法启动游戏")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：连接 Mojang 的服务可能失败，提示错误码 421")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法访问爱发电")) + FeatureCount += 24 + BugCount += 19 + End If + If LastVersion < 383 Then 'Release 2.12.3 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：部分关键词搜不到资源，特别是中文 Mod 搜索经常没有结果")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：下载可能完全卡住，或是下载进度反复回退")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：内存管理设置，可以选择 G1GC、ZGC 或分代 ZGC")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：来自 Modrinth 的文件下载速度")) + FeatureCount += 15 + BugCount += 16 + End If + If LastVersion < 381 Then 'Release 2.12.2 + FeatureCount += 3 + BugCount += 13 + End If + If LastVersion < 379 Then 'Release 2.12.1 + If LastVersion >= 376 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "删除：暂时隐藏联机入口……不过只是暂时关闭，它还会回来的！")) + End If + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：适配新的 Minecraft 版本号系统与 Unobfuscated 版本")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：巨幅优化各个下载页面和 Mod 管理页面的性能")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：更换披风时会显示当前使用的披风")) + FeatureCount += 33 + BugCount += 29 + End If + If LastVersion < 376 Then 'Release 2.11.2 + 'FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增：联机功能！")) + FeatureCount += 32 + BugCount += 21 + End If + If LastVersion < 372 Then 'Release 2.10.9 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：如果版本设置了自定义描述，会在标题后面以淡灰色显示其版本号")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：支持为一个控件设置多个自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：修改变量、弹出提示自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：添加大量替换标记，允许在更多设置和 XAML 中使用更多替换标记")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 MMC 整合包")) + FeatureCount += 33 + BugCount += 11 + End If + If LastVersion < 369 Then 'Release 2.10.8 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许在版本设置中设置禁止更新 Mod，以防整合包玩家误操作")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：若整合包需要 PCL 不兼容的加载器，允许选择跳过它的安装")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "删除：由于已不再需要，删除手动安装包下载功能")) + FeatureCount += 21 + BugCount += 32 + End If + If LastVersion < 367 Then 'Release 2.10.6 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：启用 MCIM 社区资源镜像源，以缓解社区资源难以下载的问题")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：正版登录出错时无法给出正确的错误信息")) + FeatureCount += 9 + BugCount += 9 + End If + If LastVersion < 365 Then 'Release 2.10.5 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：下载资源时，会单独记忆每种资源上次下载到的文件夹，以防混淆")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：网络底层框架与下载稳定性")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法启动一部分 LabyMod 和 GTNH 客户端")) + FeatureCount += 22 + BugCount += 26 + End If If LastVersion < 361 Then 'Release 2.10.3 FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法安装部分使用老版本 PCL 导出的整合包")) End If @@ -26,62 +104,138 @@ Public Class FormMain FeatureCount += 9 BugCount += 26 End If - If LastVersion < 355 Then 'Release 2.9.3 - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：Minecraft 会优先使用独立显卡运行")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：简化下载新版本第二步的 UI")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：使用新的版本隔离策略")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：添加了在全局启动设置与版本独立设置之间互相跳转的按钮")) - FeatureCount += 20 - BugCount += 28 - End If - If LastVersion < 352 Then 'Release 2.9.1 - FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增：导出整合包功能")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：支持在超长路径下安装、启动游戏")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 1.21 OptiFine")) - FeatureCount += 23 - BugCount += 10 - End If - If LastVersion < 349 Then 'Release 2.8.13 - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：网络环境不佳时，Mod、整合包页面的加载速度")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：部分电脑无法打开程序")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：可能无法识别、更新 Mod")) - FeatureCount += 6 - BugCount += 14 - End If - If LastVersion < 347 Then 'Release 2.8.12 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：Mod 管理页面添加下载 Mod、安装 Mod 选项")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：Mod 详情页面支持按加载器、游戏版本进行分类和筛选")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：支持安装同时包含 modpack 文件和启动器的懒人包")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：整合包导入流程")) - FeatureCount += 43 - BugCount += 37 - End If - If LastVersion < 342 Then 'Release 2.8.9 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：支持下载原版服务端")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：本地 Mod 的标题支持选择显示 Mod 原始文件名")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：搜索后启用/禁用 Mod 时出错")) - FeatureCount += 17 - BugCount += 13 - End If - If LastVersion < 340 Then 'Release 2.8.8 - If LastVersion = 338 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：数个与新正版登录相关的严重 Bug")) - FeatureCount += 3 - BugCount += 7 - End If - If LastVersion < 338 Then 'Release 2.8.7 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "优化：使用新的正版登录方式，以提高安全性")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：安装整合包、检索 Mod 的稳定性")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法加载部分 Mod 的图标")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：在 Mod 管理页面删除 Mod 导致报错")) - FeatureCount += 11 - BugCount += 21 - End If #Else '5： FEAT+ '4： IMP+ FEAT* '3：BUG+ IMP* FEAT- '2：BUG* IMP- '1：BUG- + If LastVersion < 390 Then 'Snapshot 2.12.6.2 + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：会为部分 Forge / NeoForge 选择不支持的 Java")) + BugCount += 4 + End If + If LastVersion < 388 Then 'Snapshot 2.12.6.1 + If LastVersion = 386 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法使用 Java 25+ 启动 Forge")) + FeatureCount += 4 + BugCount += 3 + End If + If LastVersion < 386 Then 'Snapshot 2.12.6 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：Minecraft 使用 Java 25+ 时的一个性能问题")) + If LastVersion = 384 OrElse LastVersion = 385 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法正常重命名游戏版本")) + If LastVersion = 385 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法显示 Modrinth 整合包的版本列表")) + BugCount += 1 + End If + If LastVersion < 385 Then 'Snapshot 2.12.5 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法下载 NeoForge 26.1")) + If LastVersion = 384 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：下载可能失败，提示下载管理刷新线程出错")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法保存选择的 Minecraft 文件夹")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：使用中文搜索 Mod 时，部分结果会忽略筛选条件")) + End If + FeatureCount += 3 + BugCount += 6 + End If + If LastVersion < 384 Then 'Snapshot 2.12.4 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：降低 Minecraft 的内存占用")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：部分关键词搜不到资源，特别是中文 Mod 搜索经常没有结果")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：老版本 Windows 无法启动游戏")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：连接 Mojang 的服务可能失败，提示错误码 421")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法访问爱发电")) + FeatureCount += 21 + BugCount += 14 + End If + If LastVersion < 382 Then 'Snapshot 2.12.3 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：下载可能完全卡住，或是下载进度反复回退")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：内存管理设置，可以选择 G1GC、ZGC 或分代 ZGC")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：来自 Modrinth 的文件下载速度")) + FeatureCount += 15 + BugCount += 16 + End If + If LastVersion < 380 Then 'Snapshot 2.12.2 + FeatureCount += 3 + BugCount += 13 + End If + If LastVersion < 378 Then 'Snapshot 2.12.1 + If LastVersion >= 377 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：在版本列表中存在 OptiFine 时可能无法加载版本列表")) + BugCount += 2 + End If + End If + If LastVersion < 377 Then 'Snapshot 2.12.0 + If LastVersion >= 373 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "删除：暂时隐藏联机入口……不过只是暂时关闭，它还会回来的！")) + End If + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：适配新的 Minecraft 版本号系统与 Unobfuscated 版本")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：巨幅优化各个下载页面和 Mod 管理页面的性能")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：更换披风时会显示当前使用的披风")) + FeatureCount += 33 + BugCount += 29 + End If + If LastVersion < 375 Then 'Snapshot 2.11.2 + 'If LastVersion >= 373 Then + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：对联机进行了各种各样的优化，以改善稳定性")) + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：若有加入者的网络环境比房主更好，会提示可以让那位加入者担任房主")) + 'End If + FeatureCount += 16 + BugCount += 4 + End If + If LastVersion < 374 Then 'Snapshot 2.11.1 + 'If LastVersion >= 373 Then + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：使用离线登录也可以直接加入联机房间了")) + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：会从所有共享节点中自动选择负载最低的进行中继连接")) + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：若复制了邀请码，则可以直接快速加入房间")) + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：关闭 PCL 时总是会提示是否退出联机，防止在关闭 PCL 时无意地关闭或退出了房间")) + ' FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许自定义要连接的节点")) + 'End If + FeatureCount += 9 + BugCount += 7 + End If + If LastVersion < 373 Then 'Snapshot 2.11.0 + 'FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增：联机功能！")) + FeatureCount += 7 + BugCount += 10 + End If + If LastVersion < 371 Then 'Snapshot 2.10.9 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：如果版本设置了自定义描述，会在标题后面以淡灰色显示其版本号")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：支持为一个控件设置多个自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：修改变量、弹出提示自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：添加大量替换标记，允许在更多设置和 XAML 中使用更多替换标记")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 MMC 整合包")) + FeatureCount += 33 + BugCount += 11 + End If + If LastVersion < 370 Then 'Snapshot 2.10.8 + If LastVersion >= 368 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureCount += 3 + BugCount += 4 + End If + If LastVersion < 368 Then 'Snapshot 2.10.7 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许在版本设置中设置禁止更新 Mod，以防整合包玩家误操作")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：若整合包需要 PCL 不兼容的加载器，允许选择跳过它的安装")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "删除：由于已不再需要，删除手动安装包下载功能")) + FeatureCount += 19 + BugCount += 28 + End If + If LastVersion < 366 Then 'Snapshot 2.10.6 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：启用 MCIM 社区资源镜像源，以缓解社区资源难以下载的问题")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：正版登录出错时无法给出正确的错误信息")) + FeatureCount += 9 + BugCount += 9 + End If + If LastVersion < 364 Then 'Snapshot 2.10.5 + If LastVersion >= 363 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法添加新的正版账号")) + BugCount += 1 + End If + End If + If LastVersion < 363 Then 'Snapshot 2.10.4 + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：下载资源时，会单独记忆每种资源上次下载到的文件夹，以防混淆")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：网络底层框架与下载稳定性")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法启动一部分 LabyMod 和 GTNH 客户端")) + FeatureCount += 22 + BugCount += 26 + End If If LastVersion < 362 Then 'Snapshot 2.10.3 FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复：无法安装部分使用老版本 PCL 导出的整合包")) End If @@ -103,81 +257,6 @@ Public Class FormMain FeatureCount += 9 BugCount += 26 End If - If LastVersion < 354 Then 'Snapshot 2.9.3 - If LastVersion = 352 Then - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：低版本 MC 没有声音")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：若不安装 Mod 加载器，则无法安装 OptiFine 1.14+")) - End If - FeatureCount += 8 - BugCount += 8 - End If - If LastVersion < 352 Then 'Snapshot 2.9.2 - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：Minecraft 会优先使用独立显卡运行")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：简化下载新版本第二步的 UI")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：使用新的版本隔离策略")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：添加了在全局启动设置与版本独立设置之间互相跳转的按钮")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：使用快照版导出带 PCL 的整合包可能失败")) - FeatureCount += 12 - BugCount += 20 - End If - If LastVersion < 351 Then 'Snapshot 2.9.1 - If LastVersion = 350 Then - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "优化：对导出整合包功能进行了 7 项优化，详见完整更新日志")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法进行第三方登录")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：在部分版本下，打开导出页面会导致启动器崩溃")) - BugCount += 1 - End If - BugCount += 2 - End If - If LastVersion < 350 Then 'Snapshot 2.9.0 - FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增：导出整合包功能")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：支持在超长路径下安装、启动游戏")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 1.21 OptiFine")) - FeatureCount += 21 - BugCount += 10 - End If - If LastVersion < 348 Then 'Snapshot 2.8.13 - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：网络环境不佳时，Mod、整合包页面的加载速度")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：部分电脑无法打开程序")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：可能无法识别、更新 Mod")) - FeatureCount += 6 - BugCount += 14 - End If - If LastVersion < 346 Then 'Snapshot 2.8.12 - If LastVersion = 345 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：帮助页面报错")) - End If - If LastVersion < 345 Then 'Snapshot 2.8.11 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：Mod 管理页面添加下载 Mod、安装 Mod 选项")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：Mod 详情页面支持按加载器、游戏版本进行分类和筛选")) - FeatureCount += 23 - BugCount += 21 - End If - If LastVersion < 343 Then 'Snapshot 2.8.10 - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：支持安装同时包含 modpack 文件和启动器的懒人包")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：整合包导入流程")) - FeatureCount += 20 - BugCount += 16 - End If - If LastVersion < 341 Then 'Snapshot 2.8.9 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "新增：支持下载原版服务端")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增：本地 Mod 的标题支持选择显示 Mod 原始文件名")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：搜索后启用/禁用 Mod 时出错")) - FeatureCount += 17 - BugCount += 13 - End If - If LastVersion < 339 Then 'Snapshot 2.8.8 - If LastVersion = 337 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：数个与新正版登录相关的严重 Bug")) - FeatureCount += 3 - BugCount += 7 - End If - If LastVersion < 337 Then 'Snapshot 2.8.7 - FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "优化：使用新的正版登录方式，以提高安全性")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：安装整合包、检索 Mod 的稳定性")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法加载部分 Mod 的图标")) - FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：在 Mod 管理页面删除 Mod 导致报错")) - FeatureCount += 11 - BugCount += 21 - End If #End If '整理更新日志文本 Dim ContentList As New List(Of String) @@ -193,12 +272,12 @@ Public Class FormMain If(BugCount > 0, "修复了 " & BugCount & " 个 Bug", "") & "，详见完整更新日志") End If - Dim Content As String = "· " & Join(ContentList, vbCrLf & "· ") + Dim Content As String = "· " & ContentList.Join(vbCrLf & "· ") '输出更新日志 RunInNewThread( Sub() - If MyMsgBox(Content, "PCL 已更新至 " & VersionDisplayName, "确定", "完整更新日志") = 2 Then - OpenWebsite("https://afdian.com/a/LTCat?tab=feed") + If MyMsgBox(Content, "PCL 已更新至" & VersionDisplayName, "确定", "完整更新日志") = 2 Then + OpenWebsite("https://meloong.com/afd/a/LTCat?tab=feed") End If End Sub, "UpdateLog Output") End Sub @@ -206,13 +285,13 @@ Public Class FormMain '窗口加载 Private IsWindowLoadFinished As Boolean = False Public Sub New() - ApplicationStartTick = GetTimeTick() + ApplicationStartTick = GetTimeMs() '窗体参数初始化 FrmMain = Me FrmLaunchLeft = New PageLaunchLeft FrmLaunchRight = New PageLaunchRight '版本号改变 - Dim LastVersion As Integer = Setup.Get("SystemLastVersionReg") + Dim LastVersion As Integer = Settings.Get("SystemLastVersionReg") If LastVersion < VersionCode Then '触发升级 UpgradeSub(LastVersion) @@ -221,34 +300,39 @@ Public Class FormMain DowngradeSub(LastVersion) End If '版本隔离设置迁移 - If Setup.IsUnset("LaunchArgumentIndieV2") Then - If Not Setup.IsUnset("LaunchArgumentIndie") Then + If Not Settings.HasSaved("LaunchArgumentIndieV2") Then + If Settings.HasSaved("LaunchArgumentIndie") Then Log("[Start] 从老 PCL 迁移版本隔离") - Setup.Set("LaunchArgumentIndieV2", Setup.Get("LaunchArgumentIndie")) - ElseIf Not Setup.IsUnset("WindowHeight") Then + Settings.Set("LaunchArgumentIndieV2", Settings.Get("LaunchArgumentIndie")) + ElseIf HasIniKey("Setup", "LaunchVersionSelect") Then Log("[Start] 从老 PCL 升级，但此前未调整版本隔离，使用老的版本隔离默认值") - Setup.Set("LaunchArgumentIndieV2", Setup.GetDefault("LaunchArgumentIndie")) + Settings.Set("LaunchArgumentIndieV2", Settings.GetDefault("LaunchArgumentIndie")) Else Log("[Start] 全新的 PCL，使用新的版本隔离默认值") - Setup.Set("LaunchArgumentIndieV2", Setup.GetDefault("LaunchArgumentIndieV2")) + Settings.Set("LaunchArgumentIndieV2", Settings.GetDefault("LaunchArgumentIndieV2")) End If End If '刷新主题 ThemeCheckAll(False) - Setup.Load("UiLauncherTheme") + ThemeRefresh(Settings.Get("UiLauncherTheme")) '注册拖拽事件（不能直接加 Handles，否则没用；#6340） [AddHandler](DragDrop.DragEnterEvent, New DragEventHandler(AddressOf HandleDrag), handledEventsToo:=True) [AddHandler](DragDrop.DragOverEvent, New DragEventHandler(AddressOf HandleDrag), handledEventsToo:=True) '加载 UI InitializeComponent() Opacity = 0 - ''开启管理员权限下的文件拖拽，但下列代码也没用（#2531） - 'If IsAdmin() Then - ' Log("[Start] PCL 正以管理员权限运行") - ' ChangeWindowMessageFilter(&H233, 1) - ' ChangeWindowMessageFilter(&H4A, 1) - ' ChangeWindowMessageFilter(&H49, 1) - 'End If + '开启管理员权限下的文件拖拽 + If IsAdmin() Then + Static Helper As New DragHelper + AddHandler SourceInitialized, + Sub() + Dim WpfHelper As New WindowInteropHelper(Me) + Helper.HwndIntPtrSource = HwndSource.FromHwnd(WpfHelper.Handle) + Helper.AddHook() + End Sub + AddHandler Closing, Sub() Helper.RemoveDragHook() + AddHandler Helper.DragDrop, Sub() FileDrag(Helper.DropFilePaths) + End If '切换到首页 If Not IsNothing(FrmLaunchLeft.Parent) Then FrmLaunchLeft.SetValue(ContentPresenter.ContentProperty, Nothing) If Not IsNothing(FrmLaunchRight.Parent) Then FrmLaunchRight.SetValue(ContentPresenter.ContentProperty, Nothing) @@ -259,22 +343,20 @@ Public Class FormMain FrmLaunchRight.PageState = MyPageRight.PageStates.ContentStay '模式提醒 #If DEBUG Then - Hint("[开发者模式] PCL 正以开发者模式运行，这可能会造成严重的性能下降，请务必立即向开发者反馈此问题！", HintType.Critical) + Hint("[开发者模式] PCL 正以开发者模式运行，这可能会造成严重的性能下降，请务必立即向开发者反馈此问题！", HintType.Red) #End If If ModeDebug Then Hint("[调试模式] PCL 正以调试模式运行，这可能会导致性能下降，若无必要请不要开启！") '尽早执行的加载池 McFolderListLoader.Start(0) '为了让下载已存在文件检测可以正常运行，必须跑一次；为了让启动按钮尽快可用，需要尽早执行；为了与 PageLaunchLeft 联动，需要为 0 而不是 GetUuid - Log("[Start] 第二阶段加载用时：" & GetTimeTick() - ApplicationStartTick & " ms") + Log("[Start] 第二阶段加载用时：" & GetTimeMs() - ApplicationStartTick & " ms") End Sub Private Sub FormMain_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded - ApplicationStartTick = GetTimeTick() - Handle = New Interop.WindowInteropHelper(Me).Handle + ApplicationStartTick = GetTimeMs() + Handle = New WindowInteropHelper(Me).Handle '读取设置 - Setup.Load("UiBackgroundOpacity") - Setup.Load("UiBackgroundBlur") - Setup.Load("UiLogoType") - Setup.Load("UiHiddenPageDownload") + UpdateBackgroundAndTitleBar() + PageSetupUI.HiddenRefresh() PageSetupUI.BackgroundRefresh(False, True) MusicRefreshPlay(False, True) '扩展按钮 @@ -300,8 +382,8 @@ Public Class FormMain '加载窗口 ThemeRefreshMain() Try - Height = Setup.Get("WindowHeight") - Width = Setup.Get("WindowWidth") + Height = Settings.Get("WindowHeight") + Width = Settings.Get("WindowWidth") Catch ex As Exception '修复 #2019 Log(ex, "读取窗口默认大小失败", LogLevel.Hint) Height = MinHeight + 100 @@ -322,7 +404,7 @@ Public Class FormMain HwndSource.AddHook(New Interop.HwndSourceHook(AddressOf WndProc)) AniStart({ AaCode(Sub() AniControlEnabled -= 1, 50), - AaOpacity(Me, Setup.Get("UiLauncherTransparent") / 1000 + 0.4, 250, 100), + AaOpacity(Me, Settings.Get("UiLauncherTransparent") / 1000 + 0.4, 250, 100), AaDouble(Sub(i) TransformPos.Y += i, -TransformPos.Y, 600, 100, New AniEaseOutBack(AniEasePower.Weak)), AaDouble(Sub(i) TransformRotate.Angle += i, -TransformRotate.Angle, 500, 100, New AniEaseOutBack(AniEasePower.Weak)), AaCode( @@ -339,11 +421,16 @@ Public Class FormMain RunInNewThread( Sub() 'EULA 提示 - If Not Setup.Get("SystemEula") Then - Select Case MyMsgBox("在使用 PCL 前，请同意 PCL 的用户协议与免责声明。", "协议授权", "同意", "拒绝", "查看用户协议与免责声明", + Const EulaVersion As Integer = 2 + If Settings.Get("SystemEulaVersion") < EulaVersion Then + Select Case MyMsgBox( + If(Settings.Get("SystemEulaVersion") = 0, + "在使用 PCL 前，请先阅读用户协议与免责声明。", + $"PCL 的用户协议与免责声明已更新。{vbCrLf}请阅读更新后的用户协议与免责声明。"), + "协议授权", "同意", "拒绝", "查看用户协议与免责声明", Button3Action:=Sub() OpenWebsite("https://shimo.im/docs/rGrd8pY8xWkt6ryW")) Case 1 - Setup.Set("SystemEula", True) + Settings.Set("SystemEulaVersion", EulaVersion) Case 2 EndProgram(False) End Select @@ -354,7 +441,7 @@ Public Class FormMain Thread.Sleep(100) DlClientListMojangLoader.Start(1) 'PCL 会同时根据这里的加载结果决定是否使用官方源进行下载 RunCountSub() - ServerLoader.Start(1) + ServerLoader.Start() RunInNewThread(AddressOf TryClearTaskTemp, "TryClearTaskTemp", ThreadPriority.BelowNormal) Catch ex As Exception Log(ex, "初始化加载池运行失败", LogLevel.Feedback) @@ -365,21 +452,23 @@ Public Class FormMain Catch ex As Exception Log(ex, "清理自动更新文件失败") End Try - End Sub, "Start Loader", ThreadPriority.Lowest) + '上报 + Telemetry("启动") + End Sub, "初始化", ThreadPriority.Lowest) - Log("[Start] 第三阶段加载用时：" & GetTimeTick() - ApplicationStartTick & " ms") + Log("[Start] 第三阶段加载用时：" & GetTimeMs() - ApplicationStartTick & " ms") End Sub '根据打开次数触发的事件 Private Sub RunCountSub() - Setup.Set("SystemCount", Setup.Get("SystemCount") + 1) + Settings.Set("SystemCount", Settings.Get("SystemCount") + 1) #If Not BETA Then - Select Case Setup.Get("SystemCount") + Select Case Settings.Get("SystemCount") Case 1 MyMsgBox("欢迎使用 PCL 快照版！" & vbCrLf & "快照版包含尚未在正式版发布的测试性功能，仅用于赞助者本人尝鲜。所以请不要发给其他人或者用于制作整合包哦！" & vbCrLf & "如果你并非通过赞助或赞助者本人邀请进群获得的本程序，那么可能是有人在违规传播，记得提醒他一下啦。", "快照版使用说明") End Select - If Setup.Get("SystemCount") >= 99 Then + If Settings.Get("SystemCount") >= 99 Then If ThemeUnlock(6, False) Then MyMsgBox("你已经使用了 99 次 PCL 啦，感谢你长期以来的支持！" & vbCrLf & "隐藏主题 铁杆粉 已解锁！", "提示") @@ -390,44 +479,44 @@ Public Class FormMain '升级与降级事件 Private Sub UpgradeSub(LastVersionCode As Integer) Log("[Start] 版本号从 " & LastVersionCode & " 升高到 " & VersionCode) - Setup.Set("SystemLastVersionReg", VersionCode) + Settings.Set("SystemLastVersionReg", VersionCode) '检查有记录的最高版本号 Dim LowerVersionCode As Integer #If BETA Then - LowerVersionCode = Setup.Get("SystemHighestBetaVersionReg") + LowerVersionCode = Settings.Get("SystemHighestBetaVersionReg") If LowerVersionCode < VersionCode Then - Setup.Set("SystemHighestBetaVersionReg", VersionCode) + Settings.Set("SystemHighestBetaVersionReg", VersionCode) Log("[Start] 最高版本号从 " & LowerVersionCode & " 升高到 " & VersionCode) End If #Else - LowerVersionCode = Setup.Get("SystemHighestAlphaVersionReg") + LowerVersionCode = Settings.Get("SystemHighestAlphaVersionReg") If LowerVersionCode < VersionCode Then - Setup.Set("SystemHighestAlphaVersionReg", VersionCode) + Settings.Set("SystemHighestAlphaVersionReg", VersionCode) Log("[Start] 最高版本号从 " & LowerVersionCode & " 升高到 " & VersionCode) End If #End If '被移除的窗口设置选项 - If Setup.Get("LaunchArgumentWindowType") = 5 Then Setup.Set("LaunchArgumentWindowType", 1) + If Settings.Get("LaunchArgumentWindowType") = 5 Then Settings.Set("LaunchArgumentWindowType", 1) '修改主题设置项名称 If LowerVersionCode <= 207 Then Dim UnlockedTheme As New List(Of String) From {"2"} - UnlockedTheme.AddRange(New List(Of String)(Setup.Get("UiLauncherThemeHide").ToString.Split("|"))) - UnlockedTheme.AddRange(New List(Of String)(Setup.Get("UiLauncherThemeHide2").ToString.Split("|"))) - Setup.Set("UiLauncherThemeHide2", Join(UnlockedTheme.Distinct.ToList, "|")) + UnlockedTheme.AddRange(New List(Of String)(Settings.Get("UiLauncherThemeHide").ToString.Split("|"))) + UnlockedTheme.AddRange(New List(Of String)(Settings.Get("UiLauncherThemeHide2").ToString.Split("|"))) + Settings.Set("UiLauncherThemeHide2", UnlockedTheme.Distinct.ToList.Join("|"c)) End If '重置欧皇彩 - If LastVersionCode <= 115 AndAlso Setup.Get("UiLauncherThemeHide2").ToString.Split("|").Contains("13") Then - Dim UnlockedTheme As New List(Of String)(Setup.Get("UiLauncherThemeHide2").ToString.Split("|")) + If LastVersionCode <= 115 AndAlso Settings.Get("UiLauncherThemeHide2").ToString.Split("|").Contains("13") Then + Dim UnlockedTheme As New List(Of String)(Settings.Get("UiLauncherThemeHide2").ToString.Split("|")) UnlockedTheme.Remove("13") - Setup.Set("UiLauncherThemeHide2", Join(UnlockedTheme, "|")) + Settings.Set("UiLauncherThemeHide2", UnlockedTheme.Join("|"c)) MyMsgBox("由于新版 PCL 修改了欧皇彩的解锁方式，你需要重新解锁欧皇彩。" & vbCrLf & "多谢各位的理解啦！", "重新解锁提醒") End If '重置滑稽彩 - If LastVersionCode <= 152 AndAlso Setup.Get("UiLauncherThemeHide2").ToString.Split("|").Contains("12") Then - Dim UnlockedTheme As New List(Of String)(Setup.Get("UiLauncherThemeHide2").ToString.Split("|")) + If LastVersionCode <= 152 AndAlso Settings.Get("UiLauncherThemeHide2").ToString.Split("|").Contains("12") Then + Dim UnlockedTheme As New List(Of String)(Settings.Get("UiLauncherThemeHide2").ToString.Split("|")) UnlockedTheme.Remove("12") - Setup.Set("UiLauncherThemeHide2", Join(UnlockedTheme, "|")) + Settings.Set("UiLauncherThemeHide2", UnlockedTheme.Join("|"c)) MyMsgBox("由于新版 PCL 修改了滑稽彩的解锁方式，你需要重新解锁滑稽彩。" & vbCrLf & "多谢各位的理解啦！", "重新解锁提醒") End If @@ -442,24 +531,30 @@ Public Class FormMain End If '解除帮助页面的隐藏 If LastVersionCode <= 205 Then - Setup.Set("UiHiddenOtherHelp", False) + Settings.Set("UiHiddenOtherHelp", False) Log("[Start] 已解除帮助页面的隐藏") End If '单向迁移微软登录结果（#4836） - If Not Setup.Get("CacheMsV2Migrated") Then - Setup.Set("CacheMsV2Migrated", True) - Setup.Set("CacheMsV2OAuthRefresh", Setup.Get("CacheMsOAuthRefresh")) - Setup.Set("CacheMsV2Access", Setup.Get("CacheMsAccess")) - Setup.Set("CacheMsV2ProfileJson", Setup.Get("CacheMsProfileJson")) - Setup.Set("CacheMsV2Uuid", Setup.Get("CacheMsUuid")) - Setup.Set("CacheMsV2Name", Setup.Get("CacheMsName")) + If Not Settings.Get("CacheMsV2Migrated") Then + Settings.Set("CacheMsV2Migrated", True) + Settings.Set("CacheMsV2OAuthRefresh", Settings.Get("CacheMsOAuthRefresh")) + Settings.Set("CacheMsV2Access", Settings.Get("CacheMsAccess")) + Settings.Set("CacheMsV2ProfileJson", Settings.Get("CacheMsProfileJson")) + Settings.Set("CacheMsV2Uuid", Settings.Get("CacheMsUuid")) + Settings.Set("CacheMsV2Name", Settings.Get("CacheMsName")) Log("[Start] 已从老版本迁移微软登录结果") End If 'Mod 命名设置迁移 - If Not Setup.IsUnset("ToolDownloadTranslate") AndAlso Setup.IsUnset("ToolDownloadTranslateV2") Then - Setup.Set("ToolDownloadTranslateV2", Setup.Get("ToolDownloadTranslate") + 1) + If Settings.HasSaved("ToolDownloadTranslate") AndAlso Not Settings.HasSaved("ToolDownloadTranslateV2") Then + Settings.Set("ToolDownloadTranslateV2", Settings.Get("ToolDownloadTranslate") + 1) Log("[Start] 已从老版本迁移 Mod 命名设置") End If + '重置 JVM 参数设置 + If LastVersionCode <= 381 AndAlso Settings.HasSaved("LaunchAdvanceJvm") AndAlso + Settings.Get("LaunchAdvanceJvm").ToString.Replace("-XX:+UseG1GC ", "").Replace("-XX:-UseAdaptiveSizePolicy ", "").Trim = Settings.GetDefault("LaunchAdvanceJvm") Then + Settings.Reset("LaunchAdvanceJvm") + Log("[Start] 已重置 JVM 参数设置") + End If '输出更新日志 If LastVersionCode <= 0 Then Return If LowerVersionCode >= VersionCode Then Return @@ -467,7 +562,7 @@ Public Class FormMain End Sub Private Sub DowngradeSub(LastVersionCode As Integer) Log("[Start] 版本号从 " & LastVersionCode & " 降低到 " & VersionCode) - Setup.Set("SystemLastVersionReg", VersionCode) + Settings.Set("SystemLastVersionReg", VersionCode) End Sub #End Region @@ -484,21 +579,19 @@ Public Class FormMain ''' ''' 是否在还有下载任务未完成时发出警告。 Public Sub EndProgram(SendWarning As Boolean) - '发出警告 - If SendWarning AndAlso HasDownloadingTask() Then - If MyMsgBox("还有下载任务尚未完成，是否确定退出？", "提示", "确定", "取消") = 1 Then - '强行结束下载任务 - RunInNewThread( - Sub() - Log("[System] 正在强行停止任务") - For Each Task As LoaderBase In LoaderTaskbar.ToList() - Task.Abort() - Next - End Sub, "强行停止下载任务") - Else - Return - End If + '强行结束下载任务？ + If HasDownloadingTask() Then + If SendWarning AndAlso MyMsgBox("还有下载任务尚未完成，是否确定退出？", "提示", "确定", "取消") = 2 Then Return + RunInNewThread( + Sub() + Log("[System] 正在强行停止任务") + For Each Task As LoaderBase In LoaderTaskbar.ToList() + Task.Interrupt() + Next + End Sub, "强行停止下载任务") End If + '关闭联机？ + If FrmLinkMain?.TryExit(Not SendWarning, True) Then Return '关闭 RunInUiWait( Sub() @@ -540,9 +633,9 @@ Public Class FormMain If ReturnCode = ProcessReturnValues.Exception Then If Not IsLogShown Then FeedbackInfo() - Log("请在 https://github.com/Hex-Dragon/PCL2/issues 提交错误报告，以便于作者解决此问题！") + Log("请在 https://github.com/Meloong-Git/PCL/issues 提交错误报告，以便于作者解决此问题！") IsLogShown = True - ShellOnly(Path & "PCL\Log1.txt") + StartProcess(Path & "PCL\Log1.txt") End If Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉 End If @@ -568,8 +661,8 @@ Public Class FormMain Public IsSizeSaveable As Boolean = False Private Sub FormMain_SizeChanged() Handles Me.SizeChanged, Me.Loaded If IsSizeSaveable Then - Setup.Set("WindowHeight", Height) - Setup.Set("WindowWidth", Width) + Settings.Set("WindowHeight", Height) + Settings.Set("WindowWidth", Width) End If RectForm.Rect = New Rect(0, 0, BorderForm.ActualWidth, BorderForm.ActualHeight) PanForm.Width = BorderForm.ActualWidth + 0.001 @@ -584,6 +677,131 @@ Public Class FormMain WindowState = WindowState.Minimized End Sub + '背景图片与标题栏 + Public Shared Sub UpdateBackgroundAndTitleBar(Value) '从设置更新 + If FrmMain Is Nothing OrElse Not FrmMain.IsLoaded Then Return + FrmMain.UpdateBackgroundAndTitleBar() + End Sub + Public Sub UpdateBackgroundAndTitleBar() + Log("[FormMain] 从设置更新背景图片与标题栏样式") + '背景图片透明度 + ImgBack.Opacity = Settings.Get("UiBackgroundOpacity") / 1000 + '背景图片模糊 + Dim BlurRadius As Double = Settings.Get("UiBackgroundBlur") + 1 + If BlurRadius = 1 Then + ImgBack.Effect = Nothing + Else + ImgBack.Effect = New Effects.BlurEffect With {.Radius = BlurRadius} + End If + ImgBack.Margin = New Thickness(-BlurRadius / 1.8) + '背景图片适应方式 + Dim BackgroundType As Integer = Settings.Get("UiBackgroundSuit") + If ImgBack.Background IsNot Nothing Then + Dim Brush As ImageBrush = CType(ImgBack.Background, ImageBrush) + If BackgroundType = 0 Then + '智能：当图片较小时平铺，较大时适应 + If Brush.ImageSource.Width < PanMain.ActualWidth / 2 AndAlso Brush.ImageSource.Height < PanMain.ActualHeight / 2 Then + BackgroundType = 4 '平铺 + Else + BackgroundType = 2 '适应 + End If + End If + Brush.Stretch = Stretch.UniformToFill + Brush.TileMode = TileMode.None + Brush.Viewport = New Rect(0, 0, 1, 1) + Brush.ViewportUnits = BrushMappingMode.RelativeToBoundingBox + Brush.AlignmentX = AlignmentX.Center + Brush.AlignmentY = AlignmentY.Center + Select Case BackgroundType + Case 1 '中 + Brush.Stretch = Stretch.None + Case 3 '拉伸 + Brush.Stretch = Stretch.Fill + Case 4 '平铺 + Brush.Stretch = Stretch.None + Brush.TileMode = TileMode.Tile + Brush.Viewport = New Rect(0, 0, Brush.ImageSource.Width, Brush.ImageSource.Height) + Brush.ViewportUnits = BrushMappingMode.Absolute + + Case 2 '适应 + Case 5 '左上 + Brush.AlignmentX = AlignmentX.Left + Brush.AlignmentY = AlignmentY.Top + Case 6 '右上 + Brush.AlignmentX = AlignmentX.Right + Brush.AlignmentY = AlignmentY.Top + Case 7 '左下 + Brush.AlignmentX = AlignmentX.Left + Brush.AlignmentY = AlignmentY.Bottom + Case 8 '右下 + Brush.AlignmentX = AlignmentX.Right + Brush.AlignmentY = AlignmentY.Bottom + Case 9 '左 + Brush.AlignmentX = AlignmentX.Left + Brush.AlignmentY = AlignmentY.Center + Case 10 '右 + Brush.AlignmentX = AlignmentX.Right + Brush.AlignmentY = AlignmentY.Center + Case 11 '上 + Brush.AlignmentX = AlignmentX.Center + Brush.AlignmentY = AlignmentY.Top + Case 12 '下 + Brush.AlignmentX = AlignmentX.Center + Brush.AlignmentY = AlignmentY.Bottom + End Select + End If + '标题栏显示类型 + Select Case Settings.Get("UiLogoType") + Case 0 '无 + ShapeTitleLogo.Visibility = Visibility.Collapsed + LabTitleLogo.Visibility = Visibility.Collapsed + ImageTitleLogo.Visibility = Visibility.Collapsed + If Not IsNothing(FrmSetupUI) Then 'TODO: 和 FrmSetupUI 解耦 + FrmSetupUI.CheckLogoLeft.Visibility = Visibility.Visible + FrmSetupUI.PanLogoText.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoChange.Visibility = Visibility.Collapsed + End If + Case 1 '默认 + ShapeTitleLogo.Visibility = Visibility.Visible + LabTitleLogo.Visibility = Visibility.Collapsed + ImageTitleLogo.Visibility = Visibility.Collapsed + If Not IsNothing(FrmSetupUI) Then + FrmSetupUI.CheckLogoLeft.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoText.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoChange.Visibility = Visibility.Collapsed + End If + Case 2 '文本 + ShapeTitleLogo.Visibility = Visibility.Collapsed + LabTitleLogo.Visibility = Visibility.Visible + ImageTitleLogo.Visibility = Visibility.Collapsed + If Not IsNothing(FrmSetupUI) Then + FrmSetupUI.CheckLogoLeft.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoText.Visibility = Visibility.Visible + FrmSetupUI.PanLogoChange.Visibility = Visibility.Collapsed + End If + Case 3 '图片 + ShapeTitleLogo.Visibility = Visibility.Collapsed + LabTitleLogo.Visibility = Visibility.Collapsed + ImageTitleLogo.Visibility = Visibility.Visible + If Not IsNothing(FrmSetupUI) Then + FrmSetupUI.CheckLogoLeft.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoText.Visibility = Visibility.Collapsed + FrmSetupUI.PanLogoChange.Visibility = Visibility.Visible + End If + Try + ImageTitleLogo.Source = Path & "PCL\Logo.png" + Catch ex As Exception + ImageTitleLogo.Source = Nothing + Log(ex, "显示标题栏图片失败", LogLevel.Msgbox) + End Try + End Select + FrmSetupUI?.CardLogo.TriggerForceResize() + '标题栏文本 + LabTitleLogo.Text = Settings.Get("UiLogoText") + '标题栏文本是否居左 + PanTitleMain.ColumnDefinitions(0).Width = New GridLength(If(Settings.Get("UiLogoLeft") AndAlso Settings.Get("UiLogoType") = 0, 0, 1), GridUnitType.Star) + End Sub + #End Region #Region "窗体事件" @@ -591,11 +809,12 @@ Public Class FormMain '按键事件 Private Sub FormMain_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown If e.IsRepeat Then Return - '调用弹窗：回车选择第一个，Esc 选择最后一个 - If PanMsg.Children.Count > 0 Then + '修复按下 Alt 后误认为弹出系统菜单导致的冻结 + If e.SystemKey = Key.LeftAlt OrElse e.SystemKey = Key.RightAlt Then e.Handled = True + '在有弹窗时：回车选择第一个，Esc 选择最后一个 + If PanMsg.Children.Any Then If e.Key = Key.Enter Then CType(PanMsg.Children(0), Object).Btn1_Click() - Return ElseIf e.Key = Key.Escape Then Dim Msg As Object = PanMsg.Children(0) If TypeOf Msg IsNot MyMsgInput AndAlso TypeOf Msg IsNot MyMsgSelect AndAlso Msg.Btn3.Visibility = Visibility.Visible Then @@ -605,24 +824,29 @@ Public Class FormMain Else Msg.Btn1_Click() End If - Return End If + Return End If + + '========================== + ' 在没有弹窗时：继续检查…… + '========================== + '按 ESC 返回上一级 If e.Key = Key.Escape Then TriggerPageBack() '更改隐藏版本可见性 - If e.Key = Key.F11 AndAlso PageCurrent = FormMain.PageType.VersionSelect Then + If e.Key = Key.F11 AndAlso PageCurrent = FormMain.PageType.InstanceSelect Then FrmSelectRight.ShowHidden = Not FrmSelectRight.ShowHidden - LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") + LoaderFolderRun(McInstanceListLoader, McFolderSelected, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") Return End If '更改功能隐藏可见性 If e.Key = Key.F12 Then PageSetupUI.HiddenForceShow = Not PageSetupUI.HiddenForceShow If PageSetupUI.HiddenForceShow Then - Hint("功能隐藏设置已暂时关闭！", HintType.Finish) + Hint("功能隐藏设置已暂时关闭！", HintType.Green) Else - Hint("功能隐藏设置已重新开启！", HintType.Finish) + Hint("功能隐藏设置已重新开启！", HintType.Green) End If PageSetupUI.HiddenRefresh() Return @@ -641,8 +865,6 @@ Public Class FormMain FrmLaunchLeft.LaunchButtonClick() End If End If - '修复按下 Alt 后误认为弹出系统菜单导致的冻结 - If e.SystemKey = Key.LeftAlt OrElse e.SystemKey = Key.RightAlt Then e.Handled = True End Sub Private Sub FormMain_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseDown '鼠标侧键返回上一级 @@ -660,16 +882,33 @@ Public Class FormMain '切回窗口 Private Sub FormMain_Activated() Handles Me.Activated Try - If PageCurrent = PageType.VersionSetup AndAlso PageCurrentSub = PageSubType.VersionMod Then + If PageCurrent = PageType.InstanceSetup AndAlso PageCurrentSub = PageSubType.InstanceMod Then 'Mod 管理自动刷新 - FrmVersionMod.ReloadModList() - ElseIf PageCurrent = PageType.VersionSelect Then + FrmInstanceMod.ReloadModList() + ElseIf PageCurrent = PageType.InstanceSelect Then '版本选择自动刷新 - LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.RunOnUpdated, MaxDepth:=1, ExtraPath:="versions\") + LoaderFolderRun(McInstanceListLoader, McFolderSelected, LoaderFolderRunType.RunOnUpdated, MaxDepth:=1, ExtraPath:="versions\") End If Catch ex As Exception Log(ex, "切回窗口时出错", LogLevel.Feedback) End Try + '读取剪贴板，自动加入联机房间 + Return 'TODO: 联机复活赛 + If PageLinkMain.LinkState <> PageLinkMain.LinkStates.Waiting Then Return '已启动联机 + If PageCurrent = PageType.Link Then Return '已在联机界面 + Dim Code = ClipboardGetText() : If Code Is Nothing Then Return '剪贴板无文本 + If Settings.Get("LinkLastAutoJoinInviteCode") = Code Then Return + If PageLinkMain.ValidateCodeFormat(Code) IsNot Nothing Then Return '不是邀请码 + Settings.Set("LinkLastAutoJoinInviteCode", Code) + RunInThread( + Sub() + If MyMsgBox("嘿，是否使用复制的邀请码加入房间？", "加入联机房间", "加入", "取消") = 2 Then Return '防止弹窗阻碍主线程，所以必须放在工作线程 + RunInUi( + Sub() + PageLinkMain.Join(Code) + ClipboardSet(Nothing, False) + End Sub) + End Sub) End Sub '文件拖放 @@ -707,6 +946,7 @@ Public Class FormMain End Sub Private Sub FrmMain_Drop(sender As Object, e As DragEventArgs) Handles Me.Drop Try + ShowWindowToTop() If e.Data.GetDataPresent(DataFormats.Text) Then '获取文本 Try @@ -719,39 +959,39 @@ Public Class FormMain Dim AuthlibServer As String = Net.WebUtility.UrlDecode(Str.Substring("authlib-injector:yggdrasil-server:".Length)) Log("[System] Authlib 拖拽：" & AuthlibServer) If Not String.IsNullOrEmpty(New ValidateHttp().Validate(AuthlibServer)) Then - Hint($"输入的 Authlib 验证服务器不符合网址格式（{AuthlibServer}）！", HintType.Critical) + Hint($"输入的 Authlib 验证服务器不符合网址格式（{AuthlibServer}）！", HintType.Red) Return End If - Dim TargetVersion = If(PageCurrent = PageType.VersionSetup, PageVersionLeft.Version, McVersionCurrent) - If TargetVersion Is Nothing Then - Hint("请先下载游戏，再设置第三方登录！", HintType.Critical) + Dim Target = If(PageCurrent = PageType.InstanceSetup, PageInstanceLeft.Instance, McInstanceSelected) + If Target Is Nothing Then + Hint("请先下载游戏，再设置第三方登录！", HintType.Red) Return End If If AuthlibServer = "https://littleskin.cn/api/yggdrasil" Then 'LittleSkin - If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启 LittleSkin 登录？" & vbCrLf & + If MyMsgBox($"是否要在版本 {Target.Name} 中开启 LittleSkin 登录？" & vbCrLf & "你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then Return End If - Setup.Set("VersionServerLogin", 4, Version:=TargetVersion) - Setup.Set("VersionServerAuthServer", "https://littleskin.cn/api/yggdrasil", Version:=TargetVersion) - Setup.Set("VersionServerAuthRegister", "https://littleskin.cn/auth/register", Version:=TargetVersion) - Setup.Set("VersionServerAuthName", "LittleSkin 登录", Version:=TargetVersion) + Settings.Set("VersionServerLogin", 4, Instance:=Target) + Settings.Set("VersionServerAuthServer", "https://littleskin.cn/api/yggdrasil", Instance:=Target) + Settings.Set("VersionServerAuthRegister", "https://littleskin.cn/auth/register", Instance:=Target) + Settings.Set("VersionServerAuthName", "LittleSkin 登录", Instance:=Target) Else '第三方 Authlib 服务器 - If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启第三方登录？" & vbCrLf & + If MyMsgBox($"是否要在版本 {Target.Name} 中开启第三方登录？" & vbCrLf & $"登录服务器：{AuthlibServer}" & vbCrLf & vbCrLf & "你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then Return End If - Setup.Set("VersionServerLogin", 4, Version:=TargetVersion) - Setup.Set("VersionServerAuthServer", AuthlibServer, Version:=TargetVersion) - Setup.Set("VersionServerAuthRegister", AuthlibServer.Replace("api/yggdrasil", "auth/register"), Version:=TargetVersion) - Setup.Set("VersionServerAuthName", "", Version:=TargetVersion) + Settings.Set("VersionServerLogin", 4, Instance:=Target) + Settings.Set("VersionServerAuthServer", AuthlibServer, Instance:=Target) + Settings.Set("VersionServerAuthRegister", AuthlibServer.Replace("api/yggdrasil", "auth/register"), Instance:=Target) + Settings.Set("VersionServerAuthName", "", Instance:=Target) End If - If PageCurrent = PageType.VersionSetup AndAlso PageCurrentSub = PageSubType.VersionSetup Then + If PageCurrent = PageType.InstanceSetup AndAlso PageCurrentSub = PageSubType.InstanceSetup Then '正在服务器选项页，需要刷新设置项显示 - FrmVersionSetup.Reload() + FrmInstanceSetup.Reload() ElseIf PageCurrent = PageType.Launch Then '正在主页，需要刷新左边栏 FrmLaunchLeft.RefreshPage(True, False) @@ -771,7 +1011,7 @@ Public Class FormMain '获取文件并检查 Dim FilePathRaw = e.Data.GetData(DataFormats.FileDrop) If FilePathRaw Is Nothing Then '#2690 - Hint("请将文件解压后再拖入！", HintType.Critical) + Hint("请将文件解压后再拖入！", HintType.Red) Return End If e.Handled = True @@ -789,24 +1029,24 @@ Public Class FormMain Log("[System] 接受文件拖拽：" & FilePath & If(FilePathList.Any, $" 等 {FilePathList.Count} 个文件", ""), LogLevel.Developer) '基础检查 If Directory.Exists(FilePathList.First) AndAlso Not File.Exists(FilePathList.First) Then - Hint("请拖入一个文件，而非文件夹！", HintType.Critical) + Hint("请拖入一个文件，而非文件夹！", HintType.Red) Return ElseIf Not File.Exists(FilePathList.First) Then - Hint("拖入的文件不存在：" & FilePathList.First, HintType.Critical) + Hint("拖入的文件不存在：" & FilePathList.First, HintType.Red) Return End If '多文件拖拽 If FilePathList.Count > 1 Then '必须要求全部为 jar 文件 For Each File In FilePathList - If Not {"jar", "litemod", "disabled", "old"}.Contains(File.AfterLast(".").ToLower) Then - Hint("一次请只拖入一个文件！", HintType.Critical) + If Not {"jar", "litemod", "disabled", "old"}.Contains(File.AfterLast(".").Lower) Then + Hint("一次请只拖入一个文件！", HintType.Red) Return End If Next End If '主页 - Dim Extension As String = FilePath.AfterLast(".").ToLower + Dim Extension As String = FilePath.AfterLast(".").Lower If Extension = "xaml" Then Log("[System] 文件后缀为 XAML，作为主页加载") If File.Exists(Path & "PCL\Custom.xaml") Then @@ -817,14 +1057,14 @@ Public Class FormMain CopyFile(FilePath, Path & "PCL\Custom.xaml") RunInUi( Sub() - Setup.Set("UiCustomType", 1) + Settings.Set("UiCustomType", 1) FrmLaunchRight.ForceRefresh() - Hint("已加载主页自定义文件！", HintType.Finish) + Hint("已加载主页自定义文件！", HintType.Green) End Sub) Return End If '安装 Mod - If PageVersionMod.InstallMods(FilePathList) Then Return + If PageInstanceMod.InstallMods(FilePathList) Then Return '安装整合包 If {"zip", "rar", "mrpack"}.Any(Function(t) t = Extension) Then '部分压缩包是 zip 格式但后缀为 rar，总之试一试 Log("[System] 文件为压缩包，尝试作为整合包安装") @@ -845,7 +1085,7 @@ Public Class FormMain '错误报告分析 Try Log("[System] 尝试进行错误报告分析") - Dim Analyzer As New CrashAnalyzer(GetUuid()) + Dim Analyzer As New CrashAnalyzer Analyzer.Import(FilePath) If Not Analyzer.Prepare() Then Exit Try Analyzer.Analyze() @@ -929,9 +1169,9 @@ Public Class FormMain #Region "切换页面" '页面种类与属性 - '注意，这一枚举在 “切换页面” EventType 中调用，应视作公开 API 的一部分 ''' ''' 页面种类。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum PageType ''' @@ -957,7 +1197,7 @@ Public Class FormMain ''' ''' 版本选择。这是一个副页面。 ''' - VersionSelect = 5 + InstanceSelect = 5 ''' ''' 下载管理。这是一个副页面。 ''' @@ -965,7 +1205,7 @@ Public Class FormMain ''' ''' 版本设置。这是一个副页面。 ''' - VersionSetup = 7 + InstanceSetup = 7 ''' ''' 资源工程详情。这是一个副页面。 ''' @@ -977,50 +1217,41 @@ Public Class FormMain End Enum ''' ''' 次要页面种类。其数值必须与 StackPanel 中的下标一致。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum PageSubType [Default] = 0 - DownloadInstall = 1 - DownloadClient = 4 - DownloadOptiFine = 5 - DownloadForge = 6 - DownloadNeoForge = 7 - DownloadFabric = 8 - DownloadLiteLoader = 9 - DownloadMod = 11 - DownloadPack = 12 - DownloadDataPack = 13 - DownloadResourcePack = 14 - DownloadShader = 15 + DownloadInstall = 0 + DownloadMod = 2 + DownloadPack = 3 + DownloadDataPack = 4 + DownloadResourcePack = 5 + DownloadShader = 6 SetupLaunch = 0 - SetupUI = 1 - SetupSystem = 2 - SetupLink = 3 - LinkHiper = 1 - LinkIoi = 2 - LinkSetup = 4 - LinkHelp = 5 - LinkFeedback = 6 + SetupLink = 1 + SetupUI = 2 + SetupSystem = 3 + LinkMain = 0 OtherHelp = 0 OtherAbout = 1 OtherTest = 2 - VersionOverall = 0 - VersionSetup = 1 - VersionMod = 2 - VersionModDisabled = 3 - VersionExport = 4 + InstanceOverall = 0 + InstanceSetup = 1 + InstanceMod = 2 + InstanceModDisabled = 3 + InstanceExport = 4 End Enum ''' ''' 获取次级页面的名称。若并非次级页面则返回空字符串，故可以以此判断是否为次级页面。 ''' Private Function PageNameGet(Stack As PageStackData) As String Select Case Stack.Page - Case PageType.VersionSelect + Case PageType.InstanceSelect Return "版本选择" Case PageType.DownloadManager Return "下载管理" - Case PageType.VersionSetup - Return "版本设置 - " & If(PageVersionLeft.Version Is Nothing, "未知版本", PageVersionLeft.Version.Name) + Case PageType.InstanceSetup + Return "版本设置 - " & If(PageInstanceLeft.Instance Is Nothing, "未知版本", PageInstanceLeft.Instance.Name) Case PageType.CompDetail Return "资源下载 - " & CType(Stack.Additional(0), CompProject).TranslatedName Case PageType.HelpDetail @@ -1066,9 +1297,9 @@ Public Class FormMain Case PageType.Other If FrmOtherLeft Is Nothing Then FrmOtherLeft = New PageOtherLeft Return FrmOtherLeft.PageID - Case PageType.VersionSetup - If FrmVersionLeft Is Nothing Then FrmVersionLeft = New PageVersionLeft - Return FrmVersionLeft.PageID + Case PageType.InstanceSetup + If FrmInstanceLeft Is Nothing Then FrmInstanceLeft = New PageInstanceLeft + Return FrmInstanceLeft.PageID Case Else Return 0 '没有子页面 End Select @@ -1142,9 +1373,9 @@ Public Class FormMain Else '切换到次页面 Select Case Stack.Page - Case PageType.VersionSetup - If FrmVersionLeft Is Nothing Then FrmVersionLeft = New PageVersionLeft - CType(FrmVersionLeft.PanItem.Children(SubType), MyListItem).SetChecked(True, True, Stack = PageCurrent) + Case PageType.InstanceSetup + If FrmInstanceLeft Is Nothing Then FrmInstanceLeft = New PageInstanceLeft + CType(FrmInstanceLeft.PanItem.Children(SubType), MyListItem).SetChecked(True, True, Stack = PageCurrent) End Select PageChangeActual(Stack, SubType) End If @@ -1228,15 +1459,15 @@ Public Class FormMain 'PageGet 方法会在未设置 SubType 时指定默认值，并建立相关页面的实例 PageChangeAnim(FrmDownloadLeft, FrmDownloadLeft.PageGet(SubType)) Case PageType.Link '联机 - If FrmLinkLeft Is Nothing Then FrmLinkLeft = New PageLinkLeft - PageChangeAnim(FrmLinkLeft, FrmLinkLeft.PageGet(SubType)) + If FrmLinkMain Is Nothing Then FrmLinkMain = New PageLinkMain + PageChangeAnim(New MyPageLeft, FrmLinkMain) Case PageType.Setup '设置 If FrmSetupLeft Is Nothing Then FrmSetupLeft = New PageSetupLeft PageChangeAnim(FrmSetupLeft, FrmSetupLeft.PageGet(SubType)) Case PageType.Other '更多 If FrmOtherLeft Is Nothing Then FrmOtherLeft = New PageOtherLeft PageChangeAnim(FrmOtherLeft, FrmOtherLeft.PageGet(SubType)) - Case PageType.VersionSelect '版本选择 + Case PageType.InstanceSelect '版本选择 If FrmSelectLeft Is Nothing Then FrmSelectLeft = New PageSelectLeft If FrmSelectRight Is Nothing Then FrmSelectRight = New PageSelectRight PageChangeAnim(FrmSelectLeft, FrmSelectRight) @@ -1244,9 +1475,9 @@ Public Class FormMain If FrmSpeedLeft Is Nothing Then FrmSpeedLeft = New PageSpeedLeft If FrmSpeedRight Is Nothing Then FrmSpeedRight = New PageSpeedRight PageChangeAnim(FrmSpeedLeft, FrmSpeedRight) - Case PageType.VersionSetup '版本设置 - If FrmVersionLeft Is Nothing Then FrmVersionLeft = New PageVersionLeft - PageChangeAnim(FrmVersionLeft, FrmVersionLeft.PageGet(SubType)) + Case PageType.InstanceSetup '版本设置 + If FrmInstanceLeft Is Nothing Then FrmInstanceLeft = New PageInstanceLeft + PageChangeAnim(FrmInstanceLeft, FrmInstanceLeft.PageGet(SubType)) Case PageType.CompDetail 'Mod 信息 If FrmDownloadCompDetail Is Nothing Then FrmDownloadCompDetail = New PageDownloadCompDetail PageChangeAnim(New MyPageLeft, FrmDownloadCompDetail) @@ -1425,7 +1656,7 @@ Public Class FormMain '投降 Public Sub AprilGiveup() Handles BtnExtraApril.Click If IsAprilEnabled AndAlso Not IsAprilGiveup Then - Hint("=D", HintType.Finish) + Hint("=D", HintType.Green) IsAprilGiveup = True FrmLaunchLeft.AprilScaleTrans.ScaleX = 1 FrmLaunchLeft.AprilScaleTrans.ScaleY = 1 @@ -1439,11 +1670,11 @@ Public Class FormMain '关闭 Minecraft Public Sub BtnExtraShutdown_Click() Handles BtnExtraShutdown.Click Try - If McLaunchLoaderReal IsNot Nothing Then McLaunchLoaderReal.Abort() + If McLaunchLoaderReal IsNot Nothing Then McLaunchLoaderReal.Interrupt() For Each Watcher In McWatcherList Watcher.Kill() Next - Hint("已关闭运行中的 Minecraft！", HintType.Finish) + Hint("已关闭运行中的 Minecraft！", HintType.Green) Catch ex As Exception Log(ex, "强制关闭所有 Minecraft 失败", LogLevel.Feedback) End Try @@ -1469,7 +1700,8 @@ Public Class FormMain End Function Private Function BtnExtraBack_GetRealChild() As MyScrollViewer If PanMainRight.Child Is Nothing OrElse TypeOf PanMainRight.Child IsNot MyPageRight Then Return Nothing - Return CType(PanMainRight.Child, MyPageRight).PanScroll + Dim Page As MyPageRight = PanMainRight.Child + Return Page.FindName(Page.PanScroll) End Function #End Region diff --git a/Plain Craft Launcher 2/Images/Heads/EasyTier.png b/Plain Craft Launcher 2/Images/Heads/EasyTier.png new file mode 100644 index 0000000..3460251 Binary files /dev/null and b/Plain Craft Launcher 2/Images/Heads/EasyTier.png differ diff --git a/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb b/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb index 06bf1a6..3064d4c 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb @@ -8,7 +8,12 @@ Public Module ModAnimation ''' ''' 动画速度。最大为 200。 ''' - Public AniSpeed As Double = 1 + Public ReadOnly Property AniSpeed As Double + Get + Dim Setting = PCL.Settings.Get("SystemDebugAnim") + Return If(Setting >= 30, 200, MathClamp(Setting * 0.1 + 0.1, 0.1, 3)) + End Get + End Property ''' ''' 动画组列表。 ''' @@ -467,7 +472,7 @@ Public Module ModAnimation ''' 按照 WPF 方式旋转控件的动画。 ''' ''' 动画的对象。它必须已经拥有了单一的 ScaleTransform 值。 - ''' 大小改变的百分比（如-0.6）。 + ''' 旋转角度（度）。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 @@ -743,9 +748,9 @@ Public Module ModAnimation ''' 由 Aa 开头的函数初始化的 AniData 对象集合。 ''' 动画组的名称。如果重复会直接停止同名动画组。 Public Sub AniStart(AniGroup As IList, Optional Name As String = "", Optional RefreshTime As Boolean = False) - If RefreshTime Then AniLastTick = GetTimeTick() '避免处理动画时已经造成了极大的延迟，导致动画突然结束 + If RefreshTime Then AniLastTick = GetTimeMs() '避免处理动画时已经造成了极大的延迟，导致动画突然结束 '添加到正在执行的动画组 - Dim NewEntry As New AniGroupEntry With {.Data = GetFullList(Of AniData)(AniGroup), .StartTick = GetTimeTick()} + Dim NewEntry As New AniGroupEntry With {.Data = GetFullList(Of AniData)(AniGroup), .StartTick = GetTimeMs()} If Name = "" Then Name = NewEntry.Uuid Else @@ -788,48 +793,50 @@ Public Module ModAnimation ''' Public Sub AniStart() '初始化计时器 - AniLastTick = GetTimeTick() + AniLastTick = GetTimeMs() AniFPSTimer = AniLastTick AniRunning = True '标记动画执行开始 - RunInNewThread(Sub() - Try - Log("[Animation] 动画线程开始") - Do While True - '两帧之间的间隔时间 - Dim DeltaTime As Long = MathClamp(GetTimeTick() - AniLastTick, 0, 100000) - If DeltaTime < 3 Then GoTo Sleeper - AniLastTick = GetTimeTick() - '记录 FPS - If ModeDebug Then - If MathClamp(AniLastTick - AniFPSTimer, 0, 100000) >= 500 Then - AniFPS = AniFPSCounter - AniFPSCounter = 0 - AniFPSTimer = AniLastTick - End If - AniFPSCounter += 2 - End If - '执行动画 - RunInUiWait(Sub() - AniCount = 0 - AniTimer(DeltaTime * AniSpeed) - '#If DEBUG Then - ' FrmMain.Title = "F " & AniFPS & ", A " & AniCount & ", R " & NetManage.FileRemain - '#Else - ' If ModeDebug Then FrmMain.Title = "FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManage.FileRemain - '#End If - If RandomInteger(0, 64 * If(ModeDebug, 5, 30)) = 0 AndAlso ((AniFPS < 62 AndAlso AniFPS > 0) OrElse AniCount > 4 OrElse NetManager.FileRemain <> 0) Then - Log("[Report] FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManager.FileRemain & "（" & GetString(NetManager.Speed) & "/s）") - End If - End Sub) + RunInNewThread( + Sub() + Try + Log("[Animation] 动画线程开始") + Do While True + '两帧之间的间隔时间 + Dim DeltaTime As Long = MathClamp(GetTimeMs() - AniLastTick, 0, 100000) + If DeltaTime < 3 Then GoTo Sleeper + AniLastTick = GetTimeMs() + '记录 FPS + If ModeDebug Then + If MathClamp(AniLastTick - AniFPSTimer, 0, 100000) >= 500 Then + AniFPS = AniFPSCounter + AniFPSCounter = 0 + AniFPSTimer = AniLastTick + End If + AniFPSCounter += 2 + End If + '执行动画 + RunInUiWait( + Sub() + AniCount = 0 + AniTimer(DeltaTime * AniSpeed) + '#If DEBUG Then + ' FrmMain.Title = "F " & AniFPS & ", A " & AniCount & ", R " & NetManage.FileRemain + '#Else + ' If ModeDebug Then FrmMain.Title = "FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManage.FileRemain + '#End If + If RandomInteger(0, 64 * If(ModeDebug, 5, 30)) = 0 AndAlso ((AniFPS < 62 AndAlso AniFPS > 0) OrElse AniCount > 4 OrElse NetManager.FileRemain <> 0) Then + Log("[Report] FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManager.FileRemain & "（" & GetString(NetManager.Speed) & "/s）") + End If + End Sub) Sleeper: - '控制 FPS - Thread.Sleep(1) - Loop - Catch ex As Exception - Log(ex, "动画帧执行失败", LogLevel.Critical) - End Try - End Sub, "Animation", ThreadPriority.AboveNormal) + '控制 FPS + Thread.Sleep(1) + Loop + Catch ex As Exception + Log(ex, "动画帧执行失败", LogLevel.Critical) + End Try + End Sub, "Animation", ThreadPriority.AboveNormal) End Sub ''' @@ -838,7 +845,7 @@ Sleeper: Public Sub AniTimer(DeltaTick As Integer) Try - If DeltaTick / AniSpeed > 200 Then Log("[Animation] 两个动画帧间隔 " & DeltaTick & " ms", LogLevel.Developer) + If DeltaTick / AniSpeed > 100 Then Log("[Animation] 两个动画帧间隔 " & DeltaTick & " ms", LogLevel.Developer) Dim i As Integer = -1 '循环每个动画组 Do While i + 1 < AniGroups.Count @@ -996,7 +1003,7 @@ NextAni: Case AniType.ScaleTransform Dim Obj As FrameworkElement = Ani.Obj If TypeOf Obj.RenderTransform IsNot ScaleTransform Then - Obj.RenderTransformOrigin = New Point(0.5, 0.5) + If Obj.RenderTransformOrigin = New Point(0, 0) Then Obj.RenderTransformOrigin = New Point(0.5, 0.5) Obj.RenderTransform = New ScaleTransform(1, 1) End If Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.TimeFinished / Ani.TimeTotal, Ani.TimePercent)) @@ -1006,7 +1013,7 @@ NextAni: Case AniType.RotateTransform Dim Obj As FrameworkElement = Ani.Obj If TypeOf Obj.RenderTransform IsNot RotateTransform Then - Obj.RenderTransformOrigin = New Point(0.5, 0.5) + If Obj.RenderTransformOrigin = New Point(0, 0) Then Obj.RenderTransformOrigin = New Point(0.5, 0.5) Obj.RenderTransform = New RotateTransform(0) End If Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.TimeFinished / Ani.TimeTotal, Ani.TimePercent)) diff --git a/Plain Craft Launcher 2/Modules/Base/ModBase.vb b/Plain Craft Launcher 2/Modules/Base/ModBase.vb index 407855a..9b5cc20 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModBase.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModBase.vb @@ -1,10 +1,11 @@ Imports System.Globalization Imports System.IO.Compression -Imports System.Reflection +Imports System.Net.Sockets Imports System.Runtime.CompilerServices Imports System.Security.Cryptography Imports System.Security.Principal Imports System.Text.RegularExpressions +Imports System.Threading.Tasks Imports System.Xaml Imports Newtonsoft.Json @@ -13,25 +14,24 @@ Public Module ModBase #Region "声明" '下列版本信息由更新器自动修改 - Public Const VersionBaseName As String = "2.10.3" '不含分支前缀的显示用版本名 - Public Const VersionStandardCode As String = "2.10.3." & VersionBranchCode '标准格式的四段式版本号 + Public Const VersionBaseName As String = "2.12.6.2" '显示用版本名 Public Const CommitHash As String = "" 'Commit Hash，由 GitHub Workflow 自动替换 #If BETA Then - Public Const VersionCode As Integer = 361 'Release + Public Const VersionCode As Integer = 391 '正式版 #Else - Public Const VersionCode As Integer = 362 'Snapshot + Public Const VersionCode As Integer = 390 '快照版 #End If '自动生成的版本信息 Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName #If RELEASE Then - Public Const VersionBranchName As String = "Snapshot" - Public Const VersionBranchCode As String = "0" + Public Const VersionBranchName As String = "快照版" + Public Const VersionBranchCode As Integer = 0 #ElseIf BETA Then - Public Const VersionBranchName As String = "Release" - Public Const VersionBranchCode As String = "50" + Public Const VersionBranchName As String = "正式版" + Public Const VersionBranchCode As Integer = 50 #Else - Public Const VersionBranchName As String = "Debug" - Public Const VersionBranchCode As String = "100" + Public Const VersionBranchName As String = "开发版" + Public Const VersionBranchCode As Integer = 100 #End If ''' @@ -55,13 +55,9 @@ Public Module ModBase ''' Public Lang As String = "zh_CN" ''' - ''' 设置对象。 - ''' - Public Setup As New ModSetup - ''' ''' 程序的打开计时。 ''' - Public ApplicationStartTick As Long = GetTimeTick() + Public ApplicationStartTick As Long = GetTimeMs() ''' ''' 程序打开时的时间。 ''' @@ -69,7 +65,7 @@ Public Module ModBase ''' ''' 识别码。 ''' - Public UniqueAddress As String = SecretGetUniqueAddress() + Public Identify As String = SecretGetIdentify() ''' ''' 程序是否已结束。 ''' @@ -85,11 +81,11 @@ Public Module ModBase ''' ''' 系统盘盘符，以 \ 结尾。例如 “C:\”。 ''' - Public OsDrive As String = Environment.GetLogicalDrives().Where(Function(p) Directory.Exists(p)).First.ToUpper.First & ":\" '#3799 + Public OsDrive As String = Environment.GetLogicalDrives().Where(Function(p) Directory.Exists(p)).First.Upper.First & ":\" '#3799 ''' ''' 程序的缓存文件夹路径，以 \ 结尾。 ''' - Public PathTemp As String = If(Setup.Get("SystemSystemCache") = "", IO.Path.GetTempPath() & "PCL\", Setup.Get("SystemSystemCache")).ToString.Replace("/", "\").TrimEnd("\") & "\" + Public PathTemp As String = If(Settings.Get("SystemSystemCache") = "", IO.Path.GetTempPath() & "PCL\", Settings.Get("SystemSystemCache")).ToString.Replace("/", "\").TrimEnd("\") & "\" ''' ''' AppData 中的 PCL 文件夹路径，以 \ 结尾。 ''' @@ -415,17 +411,13 @@ Public Module ModBase Loading Finished Failed - Aborted + Interrupted End Enum ''' ''' 执行返回值。 ''' Public Enum ProcessReturnValues - ''' - ''' 执行成功，或进程被中断。 - ''' - Aborted = -1 ''' ''' 执行成功。 ''' @@ -498,6 +490,7 @@ Public Module ModBase RealNum += Digit * Scale Scale *= FromRadix Next + If RealNum = 0 Then Return "0" '转换为指定进制 Dim Result = "" While RealNum > 0 @@ -587,8 +580,7 @@ Public Module ModBase ''' Public Function ReadReg(Key As String, Optional DefaultValue As String = "") As String Try - Dim SubKey = My.Computer.Registry.CurrentUser.OpenSubKey("Software\" & RegFolder, False) - Return If(SubKey?.GetValue(Key), DefaultValue) + Return If(My.Computer.Registry.CurrentUser.OpenSubKey("Software\" & RegFolder, False)?.GetValue(Key), DefaultValue) Catch ex As Exception Log(ex, "读取注册表出错：" & Key, LogLevel.Hint) Return DefaultValue @@ -619,7 +611,8 @@ Public Module ModBase Public Sub DeleteReg(Key As String, Optional ThrowException As Boolean = False) Try Dim SubKey As Microsoft.Win32.RegistryKey = My.Computer.Registry.CurrentUser.OpenSubKey("Software\" & RegFolder, True) - SubKey?.DeleteValue(Key) + If SubKey?.GetValue(Key) Is Nothing Then Return + SubKey.DeleteValue(Key) Catch ex As Exception Log(ex, "删除注册表出错：" & Key, If(ThrowException, LogLevel.Hint, LogLevel.Developer)) If ThrowException Then Throw @@ -761,21 +754,9 @@ Public Module ModBase If FilePath.Contains("\") Then FilePath = FilePath.Substring(FilePath.LastIndexOfF("\") + 1) Dim length As Integer = FilePath.Length If length = 0 Then Throw New Exception("不包含文件名：" & FilePath) - If length > 250 Then Throw New PathTooLongException("文件名过长：" & FilePath) Return FilePath End Function ''' - ''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。 - ''' - Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String - Dim Name As String = GetFileNameFromPath(FilePath) - If Name.Contains(".") Then - Return Name.Substring(0, Name.LastIndexOfF(".")) - Else - Return Name - End If - End Function - ''' ''' 从文件夹路径获取文件夹名。 ''' Public Function GetFolderNameFromPath(FolderPath As String) As String @@ -791,8 +772,8 @@ Public Module ModBase Public Sub CopyFile(FromPath As String, ToPath As String) Try '还原文件路径 - If Not FromPath.Contains(":\") Then FromPath = Path & FromPath - If Not ToPath.Contains(":\") Then ToPath = Path & ToPath + FromPath = If(FromPath.Contains(":\"), FromPath, Path & FromPath) + ToPath = If(ToPath.Contains(":\"), ToPath, Path & ToPath) '如果复制同一个文件则跳过 If FromPath = ToPath Then Return '确保目录存在 @@ -861,7 +842,7 @@ Public Module ModBase ''' 是否将文件内容追加到当前文件，而不是覆盖它。 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 + FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath) '确保目录存在 Directory.CreateDirectory(GetPathFromFullPath(FilePath)) '写入文件 @@ -886,7 +867,7 @@ Public Module ModBase ''' 是否将文件内容追加到当前文件，而不是覆盖它。 Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) '处理相对路径 - If Not FilePath.Contains(":\") Then FilePath = Path & FilePath + FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath) '确保目录存在 Directory.CreateDirectory(GetPathFromFullPath(FilePath)) '写入文件 @@ -1082,25 +1063,25 @@ Public Module ModBase ''' 获取文件 MD5，若失败则返回空字符串。 ''' Public Function GetFileMD5(FilePath As String) As String - Dim Retry As Boolean = False + Dim Retried As Boolean = False Re: Try - '获取 MD5 - Dim Result As New StringBuilder() - Dim File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) - Dim MD5 As MD5 = New MD5CryptoServiceProvider() - Dim Retval As Byte() = MD5.ComputeHash(File) - File.Close() - For i = 0 To Retval.Length - 1 - Result.Append(Retval(i).ToString("x2")) - Next - Return Result.ToString + Using File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) + Using h = MD5Cng.Create() + Dim Retval As Byte() = h.ComputeHash(File) + Dim Result As New StringBuilder(Retval.Length * 2) + For i = 0 To Retval.Length - 1 + Result.Append(Retval(i).ToString("x2")) + Next + Return Result.ToString + End Using + End Using Catch ex As Exception - If Retry OrElse TypeOf ex Is FileNotFoundException Then + If Retried OrElse TypeOf ex Is FileNotFoundException Then Log(ex, "获取文件 MD5 失败：" & FilePath) Return "" Else - Retry = True + Retried = True Log(ex, "获取文件 MD5 可重试失败：" & FilePath, LogLevel.Normal) Thread.Sleep(RandomInteger(200, 500)) GoTo Re @@ -1111,27 +1092,25 @@ Re: ''' 获取文件 SHA512，若失败则返回空字符串。 ''' Public Function GetFileSHA512(FilePath As String) As String - Dim Retry As Boolean = False + Dim Retried As Boolean = False Re: Try - ''检测该文件是否在下载中，若在下载则放弃检测 - 'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return "" - '获取 SHA512 - Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) - Dim sha512 As SHA512 = New SHA512CryptoServiceProvider() - Dim retval As Byte() = sha512.ComputeHash(file) - file.Close() - Dim Result As New StringBuilder() - For i As Integer = 0 To retval.Length - 1 - Result.Append(retval(i).ToString("x2")) - Next - Return Result.ToString + Using File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) + Using h = SHA512Cng.Create() + Dim retval As Byte() = h.ComputeHash(File) + Dim Result As New StringBuilder(retval.Length * 2) + For i As Integer = 0 To retval.Length - 1 + Result.Append(retval(i).ToString("x2")) + Next + Return Result.ToString + End Using + End Using Catch ex As Exception - If Retry OrElse TypeOf ex Is FileNotFoundException Then + If Retried OrElse TypeOf ex Is FileNotFoundException Then Log(ex, "获取文件 SHA512 失败：" & FilePath) Return "" Else - Retry = True + Retried = True Log(ex, "获取文件 SHA512 可重试失败：" & FilePath, LogLevel.Normal) Thread.Sleep(RandomInteger(200, 500)) GoTo Re @@ -1145,18 +1124,16 @@ Re: Dim Retry As Boolean = False Re: Try - ''检测该文件是否在下载中，若在下载则放弃检测 - 'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return "" - '获取 SHA256 - Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) - Dim sha256 As SHA256 = New SHA256CryptoServiceProvider() - Dim retval As Byte() = sha256.ComputeHash(file) - file.Close() - Dim Result As New StringBuilder() - For i As Integer = 0 To retval.Length - 1 - Result.Append(retval(i).ToString("x2")) - Next - Return Result.ToString + Using File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) + Using h = SHA256Cng.Create() + Dim retval As Byte() = h.ComputeHash(File) + Dim Result As New StringBuilder(retval.Length * 2) + For i As Integer = 0 To retval.Length - 1 + Result.Append(retval(i).ToString("x2")) + Next + Return Result.ToString() + End Using + End Using Catch ex As Exception If Retry OrElse TypeOf ex Is FileNotFoundException Then Log(ex, "获取文件 SHA256 失败：" & FilePath) @@ -1176,16 +1153,16 @@ Re: Dim Retry As Boolean = False Re: Try - '获取 SHA1 - Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) - Dim sha1 As SHA1 = New SHA1CryptoServiceProvider() - Dim retval As Byte() = sha1.ComputeHash(file) - file.Close() - Dim Result As New StringBuilder() - For i As Integer = 0 To retval.Length - 1 - Result.Append(retval(i).ToString("x2")) - Next - Return Result.ToString + Using File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) + Using h = SHA1Cng.Create() + Dim retval As Byte() = h.ComputeHash(File) + Dim Result As New StringBuilder(retval.Length * 2) + For i As Integer = 0 To retval.Length - 1 + Result.Append(retval(i).ToString("x2")) + Next + Return Result.ToString + End Using + End Using Catch ex As Exception If Retry OrElse TypeOf ex Is FileNotFoundException Then Log(ex, "获取文件 SHA1 失败：" & FilePath) @@ -1221,14 +1198,17 @@ Re: Public Class FileChecker ''' ''' 文件的准确大小。 + ''' 不检查则为 -1。 ''' Public ActualSize As Long = -1 ''' ''' 文件的最小大小。 + ''' 不检查则为 -1。 ''' Public MinSize As Long = -1 ''' ''' 文件的 MD5、SHA1 或 SHA256。会根据输入字符串的长度自动判断种类。 + ''' 不检查则为 Nothing。 ''' Public Hash As String = Nothing ''' @@ -1236,7 +1216,8 @@ Re: ''' Public CanUseExistsFile As Boolean = True ''' - ''' 是否为 Json 文件。 + ''' 是否要求为 JSON 文件。 + ''' 即，开头结尾必须为 {} 或 []。 ''' Public IsJson As Boolean = False Public Sub New(Optional MinSize As Long = -1, Optional ActualSize As Long = -1, Optional Hash As String = Nothing, Optional CanUseExistsFile As Boolean = True, Optional IsJson As Boolean = False) @@ -1264,11 +1245,11 @@ Re: End If If Not String.IsNullOrEmpty(Hash) Then If Hash.Length < 35 Then 'MD5 - If Hash.ToLowerInvariant <> GetFileMD5(LocalPath) Then Return "文件 MD5 应为 " & Hash & "，实际为 " & GetFileMD5(LocalPath) + If Hash.Lower <> GetFileMD5(LocalPath) Then Return "文件 MD5 应为 " & Hash & "，实际为 " & GetFileMD5(LocalPath) ElseIf Hash.Length = 64 Then 'SHA256 - If Hash.ToLowerInvariant <> GetFileSHA256(LocalPath) Then Return "文件 SHA256 应为 " & Hash & "，实际为 " & GetFileSHA256(LocalPath) + If Hash.Lower <> GetFileSHA256(LocalPath) Then Return "文件 SHA256 应为 " & Hash & "，实际为 " & GetFileSHA256(LocalPath) Else 'SHA1 (40) - If Hash.ToLowerInvariant <> GetFileSHA1(LocalPath) Then Return "文件 SHA1 应为 " & Hash & "，实际为 " & GetFileSHA1(LocalPath) + If Hash.Lower <> GetFileSHA1(LocalPath) Then Return "文件 SHA1 应为 " & Hash & "，实际为 " & GetFileSHA1(LocalPath) End If End If If IsJson Then @@ -1283,45 +1264,78 @@ Re: Return Nothing Catch ex As Exception Log(ex, "检查文件出错") - Return GetExceptionSummary(ex) + Return ex.GetBrief() End Try End Function End Class + '压缩文件 ''' ''' 尝试根据后缀名判断文件种类并解压文件，支持 gz 与 zip，会尝试将 jar 以 zip 方式解压。 ''' 会尝试创建，但不会清空目标文件夹。 + ''' 会先使用 UTF-8 解压，失败后换用 GB18030 解压。 ''' - Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing, - Optional ProgressIncrementHandler As Action(Of Double) = Nothing) + Public Sub ExtractCompressedFile(CompressFilePath As String, DestDirectory As String, Optional ProgressIncrementHandler As Action(Of Double) = Nothing) Directory.CreateDirectory(DestDirectory) + '解压 gz（gz 不需要考虑编码） If CompressFilePath.EndsWithF(".gz", True) Then - '以 gz 方式解压 - Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress) - Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write) - Dim data As Integer = stream.ReadByte() - While data <> -1 - decompressedFile.WriteByte(data) - data = stream.ReadByte() - End While - decompressedFile.Close() - stream.Close() - Else - '以 zip 方式解压 - Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030"))) - Dim TotalCount As Integer = Archive.Entries.Count - For Each Entry As ZipArchiveEntry In Archive.Entries - If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / TotalCount) - Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName) - If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then - Continue For '不创建空文件夹 - Else - Directory.CreateDirectory(GetPathFromFullPath(DestinationPath)) - Entry.ExtractToFile(DestinationPath, True) - End If + Using stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.Read, FileShare.Read), CompressionMode.Decompress) + Using decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).Lower.Replace(".tar", "").Replace(".gz", ""), + FileMode.OpenOrCreate, FileAccess.Write) + Dim data As Integer = stream.ReadByte() + While data <> -1 + decompressedFile.WriteByte(data) + data = stream.ReadByte() + End While + End Using + End Using + Return + End If + '解压 zip + Dim TryExtractZip = + Sub(Encoding As Encoding) + Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, Encoding) + Dim EntryCount = Archive.Entries.Count + For Each Entry In Archive.Entries + If ProgressIncrementHandler IsNot Nothing AndAlso EntryCount > 0 Then ProgressIncrementHandler(1 / EntryCount) + Dim DestinationFullPath As String = IO.Path.Combine(DestDirectory, Entry.FullName) + If Not IO.Path.GetFullPath(DestinationFullPath).StartsWithF(IO.Path.GetFullPath(DestDirectory), True) Then Continue For 'ZipSlip 漏洞修复 + If DestinationFullPath.EndsWithF("\") OrElse DestinationFullPath.EndsWithF("/") Then Continue For '不创建空文件夹 + Dim DestinationDirectory As String = GetPathFromFullPath(DestinationFullPath) + Directory.CreateDirectory(DestinationDirectory) + Entry.ExtractToFile(DestinationFullPath.Replace(DestinationDirectory, ShortenPath(DestinationDirectory)), True) '#7329 Next End Using - End If + End Sub + Try + TryExtractZip(New UTF8Encoding(False, True)) + Catch ex As Exception + Log(ex, $"首次解压尝试失败，将更换编码并重试（{CompressFilePath} → {DestDirectory}）") + Try + TryExtractZip(Encoding.GetEncoding("GB18030")) + Catch + Throw + End Try + End Try + End Sub + ''' + ''' 将多个文件打包为一个压缩文件。 + ''' 这些文件会被直接放在压缩包根目录下。 + ''' + Public Sub CreateCompressedFile(OutputFullPath As String, SourceFiles As IEnumerable(Of String)) + Dim DirectoryPath = IO.Path.GetDirectoryName(OutputFullPath) + If Not Directory.Exists(DirectoryPath) Then Directory.CreateDirectory(DirectoryPath) + Using ZipStream As New FileStream(OutputFullPath, FileMode.Create) + Using Archive As New ZipArchive(ZipStream, ZipArchiveMode.Create) + For Each FilePath In SourceFiles + If Not File.Exists(FilePath) Then Return + Using SourceStream As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.Read), + EntryStream As Stream = Archive.CreateEntry(IO.Path.GetFileName(FilePath)).Open() + SourceStream.CopyTo(EntryStream) + End Using + Next + End Using + End Using End Sub ''' @@ -1329,14 +1343,24 @@ Re: ''' Public Function DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False) As Integer If Not Directory.Exists(Path) Then Return 0 + If Not Path.EndsWithF("\") Then Path &= "\" + If Path.EndsWithF(":\") OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.Desktop) & "\" OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory) & "\" OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments) & "\" Then '#7030 + Throw New UnauthorizedAccessException("这是重要的系统文件夹，无法删除：" & Path) + End If + '实际删除 Dim DeletedCount As Integer = 0 Dim Files As String() Try Files = Directory.GetFiles(Path) - Catch ex As DirectoryNotFoundException '#4549 - Log(ex, $"疑似为孤立符号链接，尝试直接删除（{Path}）", LogLevel.Developer) - Directory.Delete(Path) - Return 0 + Catch ex As DirectoryNotFoundException '#4549，也可能已被其他线程删除 + If Directory.Exists(Path) Then + Log(ex, $"疑似为孤立符号链接，尝试直接删除（{Path}）", LogLevel.Developer) + Directory.Delete(Path) + End If + Return DeletedCount End Try For Each FilePath As String In Files Dim RetriedFile As Boolean = False @@ -1344,6 +1368,8 @@ RetryFile: Try File.Delete(FilePath) DeletedCount += 1 + Catch ex As DirectoryNotFoundException + Return DeletedCount Catch ex As Exception If Not RetriedFile Then RetriedFile = True @@ -1364,6 +1390,7 @@ RetryFile: RetryDir: Try Directory.Delete(Path, True) + Catch ex As DirectoryNotFoundException Catch ex As Exception If Not RetriedDir AndAlso Not RunInUi() Then RetriedDir = True @@ -1387,17 +1414,17 @@ RetryDir: ToPath = ToPath.Replace("/", "\") If Not ToPath.EndsWithF("\") Then ToPath &= "\" Dim AllFiles = EnumerateFiles(FromPath).ToList - Dim FileCount As Integer = AllFiles.Count + Dim FileCount As Long = AllFiles.Count For Each File In AllFiles CopyFile(File.FullName, File.FullName.Replace(FromPath, ToPath)) - If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / FileCount) + If ProgressIncrementHandler IsNot Nothing AndAlso FileCount > 0 Then ProgressIncrementHandler(1 / FileCount) Next End Sub ''' ''' 遍历文件夹中的所有文件。 ''' Public Function EnumerateFiles(Directory As String) As IEnumerable(Of FileInfo) - Dim Info As New DirectoryInfo(ShortenPath(Directory)) + Dim Info As New DirectoryInfo(Directory) If Not Info.Exists Then Return New List(Of FileInfo) Return Info.EnumerateFiles("*", SearchOption.AllDirectories) End Function @@ -1405,13 +1432,24 @@ RetryDir: ''' ''' 若路径长度大于指定值，则将长路径转换为短路径。 ''' - Public Function ShortenPath(LongPath As String, Optional ShortenThreshold As Integer = 247) As String - If LongPath.Length <= ShortenThreshold Then Return LongPath - Dim ShortPath As New StringBuilder(260) - GetShortPathName(LongPath, ShortPath, 260) - Return ShortPath.ToString + Public Function ShortenPath(Raw As String) As String + If Raw.Length <= 200 OrElse Raw.StartsWithF("http", True) Then Return Raw + If Not Directory.Exists(Raw) AndAlso Not File.Exists(Raw) Then Return Raw + Dim PathToShorten As String, Ignored As String + If Not Directory.Exists(Raw) AndAlso Raw.EndsWithF(".jar", True) Then '只能缩短文件夹部分，必须保留 jar 文件名，否则会导致 Forge 1.20.1 无法通过文件名识别模块名 + PathToShorten = GetPathFromFullPath(Raw) + Ignored = GetFileNameFromPath(Raw) + Else + PathToShorten = Raw + Ignored = "" + End If + Dim ShortPathBuffer As New StringBuilder(260) + GetShortPathNameW(PathToShorten.Replace("/", "\"), ShortPathBuffer, 260) + Dim DirShortPath As String = ShortPathBuffer.ToString() + If String.IsNullOrEmpty(DirShortPath) Then Return Raw + Return If(String.IsNullOrEmpty(Ignored), DirShortPath, IO.Path.Combine(DirShortPath, Ignored)) End Function - Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As StringBuilder, ByVal cchBuffer As Integer) As Integer + Private Declare Unicode Function GetShortPathNameW Lib "kernel32" Alias "GetShortPathNameW" (lpszLongPath As String, lpszShortPath As StringBuilder, cchBuffer As Integer) As Integer #End Region @@ -1420,13 +1458,14 @@ RetryDir: Public vbRQ As Char = Convert.ToChar(8221) ''' - ''' 提取 Exception 的具体描述与堆栈。 + ''' 提取 Exception 与 Inner Exception 的详细描述与堆栈信息。返回内容总是多于一行。 ''' ''' 是否必须显示所有堆栈。通常用于判定堆栈信息。 - Public Function GetExceptionDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String + Public Function GetDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String If Ex Is Nothing Then Return "无可用错误信息！" '获取最底层的异常 + Dim OuterEx As Exception = Ex Dim InnerEx As Exception = Ex Do Until InnerEx.InnerException Is Nothing InnerEx = InnerEx.InnerException @@ -1449,35 +1488,22 @@ RetryDir: IsInner = True Loop - '常见错误（记得同时修改下面的） - Dim CommonReason As String = Nothing - If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then - CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。" - ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then - CommonReason = "PCL 的权限不足。请尝试右键 PCL，选择以管理员身份运行。" - ElseIf TypeOf InnerEx Is OutOfMemoryException Then - CommonReason = "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。" - ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then - CommonReason = "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。" - ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", - "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then - CommonReason = "你的网络环境不佳，导致难以连接到服务器。请稍后重试，或使用 VPN 以改善网络环境。" - End If - '构造输出信息 - If CommonReason Is Nothing Then + Dim UsualReason As String = AnalyzeUsualReason(InnerEx, OuterEx, DescList) + If UsualReason Is Nothing Then Return DescList.Join(vbCrLf) Else - Return CommonReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf) + Return UsualReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf) End If End Function ''' - ''' 提取 Exception 描述，汇总到一行。 + ''' 提取 Exception 与 Inner Exception 的描述，汇总到一行。 ''' - Public Function GetExceptionSummary(Ex As Exception) As String + Public Function GetBrief(Ex As Exception) As String If Ex Is Nothing Then Return "无可用错误信息！" '获取最底层的异常 + Dim OuterEx As Exception = Ex Dim InnerEx As Exception = Ex Do Until InnerEx.InnerException Is Nothing InnerEx = InnerEx.InnerException @@ -1490,29 +1516,32 @@ RetryDir: Ex = Ex.InnerException Loop DescList = DescList.Distinct.ToList - Dim Desc As String = Join(DescList, vbCrLf & "→ ") - - '常见错误（记得同时修改上面的） - Dim CommonReason As String = Nothing - If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then - CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。" - ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then - CommonReason = "PCL 的权限不足。请尝试右键 PCL，选择以管理员身份运行。" - ElseIf TypeOf InnerEx Is OutOfMemoryException Then - CommonReason = "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。" - ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then - CommonReason = "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。" - ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", - "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) Desc.Contains(s)) Then - CommonReason = "你的网络环境不佳，导致难以连接到服务器。请稍后重试，或使用 VPN 以改善网络环境。" - End If + Dim Desc As String = DescList.Join(vbCrLf & "→ ") '构造输出信息 - If CommonReason IsNot Nothing Then - Return CommonReason & "详细错误：" & DescList.First + Dim UsualReason As String = AnalyzeUsualReason(InnerEx, OuterEx, DescList) + If UsualReason IsNot Nothing Then + Return UsualReason & "详细错误：" & DescList.First Else DescList.Reverse() '让最深层错误在最左边 - Return Join(DescList, " ← ") + Return DescList.Join(" ← ") + End If + End Function + Private Function AnalyzeUsualReason(InnerEx As Exception, OuterEx As Exception, DescList As List(Of String)) As String + If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then + Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。" + ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then + Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行。" + ElseIf TypeOf InnerEx Is OutOfMemoryException Then + Return "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。" + ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then + Return "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。" + ElseIf TypeOf InnerEx Is SocketException AndAlso DescList.Any(Function(l) l.Contains("WSAStartup")) Then + Return "请尝试卸载中国移动云盘，然后再试。" + ElseIf OuterEx.IsNetworkRelated() Then + Return "你的网络环境不佳，请稍后再试，或使用 VPN 改善网络环境。" + Else + Return Nothing End If End Function @@ -1524,6 +1553,19 @@ RetryDir: Return [Enum].GetName(EnumData.GetType, EnumData) End Function ''' + ''' 将字符串转换为枚举类型，支持数字或原文两种格式，若为空字符串则返回 0。 + ''' 若转换失败会抛出异常。 + ''' + Public Function ParseToEnum(Of T)(Str As String) As T + If String.IsNullOrEmpty(Str) Then + Return CType(0, Object) + ElseIf IsNumeric(Str) Then + Return CType(CInt(Str), Object) + Else + Return [Enum].Parse(GetType(T), Str, True) + End If + End Function + ''' ''' 将文件大小转化为适合的文本形式，如“1.28 M”。 ''' ''' 以字节为单位的大小表示。 @@ -1551,12 +1593,12 @@ RetryDir: ''' ''' 获取 JSON 对象。 ''' - Public Function GetJson(Data As String) + Public Function GetJson(Data As String) As JToken Try Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local}) Catch ex As Exception Dim Length As Integer = If(Data, "").Length - Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data)) + Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data), ex) End Try End Function @@ -1565,7 +1607,7 @@ RetryDir: ''' Public Function Capitalize(word As String) As String If String.IsNullOrEmpty(word) Then Return word - Return word.Substring(0, 1).ToUpperInvariant() & word.Substring(1).ToLowerInvariant() + Return word.Substring(0, 1).Upper() & word.Substring(1).Lower() End Function ''' @@ -1576,16 +1618,6 @@ RetryDir: Return Mid(Str.PadRight(Length, Code), Str.Length + 1) & Str End Function ''' - ''' 将一个小数显示为固定的小数点后位数形式，将向零取整。 - ''' 如 12 保留 2 位则输出 12.00，而 95.678 保留 2 位则输出 95.67。 - ''' - Public Function StrFillNum(Num As Double, Length As Integer) As String - Num = Math.Round(Num, Length, MidpointRounding.AwayFromZero) - StrFillNum = Num - If Not StrFillNum.Contains(".") Then Return (StrFillNum & ".").PadRight(StrFillNum.Length + 1 + Length, "0") - Return StrFillNum.PadRight(StrFillNum.Split(".")(0).Length + 1 + Length, "0") - End Function - ''' ''' 移除字符串首尾的标点符号、回车，以及括号中、冒号后的补充说明内容。 ''' Public Function StrTrim(Str As String, Optional RemoveQuote As Boolean = True) @@ -1595,7 +1627,24 @@ RetryDir: ''' ''' 连接字符串。 ''' + Public Function Join(List As IEnumerable, Split As Char) As String + Dim Builder As New StringBuilder + Dim IsFirst As Boolean = True + For Each Element In List + If IsFirst Then + IsFirst = False + Else + Builder.Append(Split) + End If + If Element IsNot Nothing Then Builder.Append(Element) + Next + Return Builder.ToString + End Function + ''' + ''' 连接字符串。 + ''' Public Function Join(List As IEnumerable, Split As String) As String + If Split.IsSingle Then Return List.Join(Split(0)) Dim Builder As New StringBuilder Dim IsFirst As Boolean = True For Each Element In List @@ -1610,9 +1659,10 @@ RetryDir: End Function ''' ''' 分割字符串。 + ''' 若原始字符串为空，则返回 {""}。 ''' Public Function Split(FullStr As String, SplitStr As String) As String() - If SplitStr.Length = 1 Then + If SplitStr.IsSingle Then Return FullStr.Split(SplitStr(0)) Else Return FullStr.Split({SplitStr}, StringSplitOptions.None) @@ -1633,14 +1683,14 @@ RetryDir: ''' 获取字符串 MD5。 ''' Public Function GetStringMD5(Str As String) As String - Dim md5Hasher As New MD5CryptoServiceProvider - Dim hashedDataBytes As Byte() - hashedDataBytes = md5Hasher.ComputeHash(Encoding.GetEncoding("gb2312").GetBytes(Str)) - Dim tmp As New StringBuilder() - For Each i As Byte In hashedDataBytes - tmp.Append(i.ToString("x2")) - Next - Return tmp.ToString() + Using h = MD5Cng.Create() + Dim hashedDataBytes = h.ComputeHash(Encoding.GetEncoding("gb2312").GetBytes(Str)) + Dim tmp As New StringBuilder(hashedDataBytes.Length * 2) + For Each i As Byte In hashedDataBytes + tmp.Append(i.ToString("x2")) + Next + Return tmp.ToString() + End Using End Function ''' ''' 检查字符串中的字符是否均为 ASCII 字符。 @@ -1724,6 +1774,7 @@ RetryDir: ''' Public Function StartsWithF(Str As String, Prefix As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.StartsWith(Prefix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) End Function ''' @@ -1731,6 +1782,7 @@ RetryDir: ''' Public Function EndsWithF(Str As String, Suffix As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.EndsWith(Suffix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) End Function ''' @@ -1738,6 +1790,7 @@ RetryDir: ''' Public Function ContainsF(Str As String, SubStr As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.IndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) >= 0 End Function ''' @@ -1774,6 +1827,7 @@ RetryDir: ''' 如果输入有误，返回 0。 ''' Public Function Val(Str As Object) As Double + If Str Is Nothing Then Return 0 Try Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str)) Catch @@ -1781,6 +1835,19 @@ RetryDir: End Try End Function + ''' + ''' 等效 ToLowerInvariant。 + ''' + Public Function Lower(Str As String) As String + Return Str.ToLowerInvariant() + End Function + ''' + ''' 等效 ToUpperInvariant。 + ''' + Public Function Upper(Str As String) As String + Return Str.ToUpperInvariant() + End Function + '转义 ''' ''' 为字符串进行 XML 转义。 @@ -1870,50 +1937,53 @@ RetryDir: ''' 被搜索的长内容。 ''' 用户输入的搜索文本。 Private Function SearchSimilarity(Source As String, Query As String) As Double + If String.IsNullOrEmpty(Source) OrElse String.IsNullOrEmpty(Query) Then Return 0 Dim qp As Integer = 0, lenSum As Double = 0 - Source = Source.ToLower.Replace(" ", "") - Query = Query.ToLower.Replace(" ", "") - Dim sourceLength As Integer = Source.Length, queryLength As Integer = Query.Length '用于计算最后因数的长度缓存 + Dim str As New StringBuilder(Source.Length) + str.Append(Source.Lower().Replace(" ", "")) + Query = Query.Lower().Replace(" ", "") + Dim sourceLength As Integer = str.Length, queryLength As Integer = Query.Length '用于计算最后因数的长度缓存 + If queryLength = 0 Then Return 0 Do While qp < queryLength '对 qp 作为开始位置计算 Dim sp As Integer = 0, lenMax As Integer = 0, spMax As Integer = 0 - '查找以 qp 为头的最大子串 - Do While sp < Source.Length - '对每个 sp 作为开始位置计算最大子串 + Dim currentSourceLength As Integer = str.Length + Do While sp < currentSourceLength Dim len As Integer = 0 - Do While (qp + len) < queryLength AndAlso (sp + len) < Source.Length AndAlso Source(sp + len) = Query(qp + len) + While (qp + len) < queryLength AndAlso (sp + len) < currentSourceLength AndAlso str(sp + len) = Query(qp + len) len += 1 - Loop + End While '存储 len If len > lenMax Then lenMax = len spMax = sp End If '根据结果增加 sp - sp += Math.Max(1, len) + sp += If(len > 0, len, 1) Loop If lenMax > 0 Then - Source = Source.Substring(0, spMax) & If(Source.Count > spMax + lenMax, Source.Substring(spMax + lenMax), String.Empty) '将源中的对应字段替换空 + str.Remove(spMax, lenMax) '将源中的对应字段移除 '存储 lenSum Dim IncWeight = (Math.Pow(1.4, 3 + lenMax) - 3.6) '根据长度加成 IncWeight *= 1 + 0.3 * Math.Max(0, 3 - Math.Abs(qp - spMax)) '根据位置加成 lenSum += IncWeight End If - '根据结果增加 qp - qp += Math.Max(1, lenMax) + qp += If(lenMax > 0, lenMax, 1) Loop '计算结果：重复字段量 × 源长度影响比例 - Return (lenSum / queryLength) * (3 / Math.Pow(sourceLength + 15, 0.5)) * If(queryLength <= 2, 3 - queryLength, 1) + Return (lenSum / queryLength) * (3 / Math.Sqrt(sourceLength + 15)) * If(queryLength <= 2, 3 - queryLength, 1) End Function ''' ''' 获取多段文本加权后的相似度。 ''' - Private Function SearchSimilarityWeighted(Source As List(Of KeyValuePair(Of String, Double)), Query As String) As Double + Private Function SearchSimilarityWeighted(Source As List(Of SearchSource), Query As String) As Double Dim TotalWeight As Double = 0 Dim Sum As Double = 0 For Each Pair In Source - Sum += SearchSimilarity(Pair.Key, Query) * Pair.Value - TotalWeight += Pair.Value + If Pair.Aliases.Any Then + Sum += Pair.Aliases.Max(Function(a) SearchSimilarity(a, Query)) * Pair.Weight + End If + TotalWeight += Pair.Weight Next Return Sum / TotalWeight End Function @@ -1926,9 +1996,10 @@ RetryDir: ''' Public Item As T ''' - ''' 该项目用于搜索的源。 + ''' 该项目用于搜索的文本源。 + ''' 在搜索时，会对每个文本源单独加权，但单个文本源内的多个别名只取最高的一个的相似度。 ''' - Public SearchSource As List(Of KeyValuePair(Of String, Double)) + Public SearchSource As List(Of SearchSource) ''' ''' 相似度。 ''' @@ -1937,9 +2008,29 @@ RetryDir: ''' 是否完全匹配。 ''' Public AbsoluteRight As Boolean + Public Overrides Function ToString() As String + Return Math.Round(Similarity, 3) & " - " & Item.ToString() + End Function + End Class + ''' + ''' 单个用于搜索的文本源。 + ''' + Public Class SearchSource + Public Aliases As String() + Public Weight As Double + Public Sub New(Aliases As String(), Optional Weight As Double = 1) + Me.Aliases = Aliases + Me.Weight = Weight + End Sub + Public Sub New(Text As String, Optional Weight As Double = 1) + Me.Aliases = {Text} + Me.Weight = Weight + End Sub End Class ''' ''' 进行多段文本加权搜索，获取相似度较高的数项结果。 + ''' 在搜索时，会对每个文本源单独加权，但单个文本源内的多个别名只取最高的一个的相似度。 + ''' 这会修改 Entries 中每项的 Similarity 与 AbsoluteRight 字段。 ''' ''' 返回的最大模糊结果数。 ''' 返回结果要求的最低相似度。 @@ -1948,29 +2039,26 @@ RetryDir: Dim ResultList As New List(Of SearchEntry(Of T)) If Not Entries.Any() Then Return ResultList '进行搜索，获取相似信息 + Dim QueryParts = Query.Split({" "c}, StringSplitOptions.RemoveEmptyEntries) + Dim Candidates As New List(Of SearchEntry(Of T)) For Each Entry In Entries Entry.Similarity = SearchSimilarityWeighted(Entry.SearchSource, Query) Entry.AbsoluteRight = - Query.Split(" ").All( '对于按空格分割的每一段 + QueryParts.All( '对于按空格分割的每一段 Function(QueryPart) Entry.SearchSource.Any( '若与任意一个搜索源完全匹配，则标记为完全匹配项 - Function(Source) Source.Key.Replace(" ", "").ContainsF(QueryPart, True))) + Function(Source) Source.Aliases.Any( + Function([Alias]) [Alias].Replace(" ", "").ContainsF(QueryPart, True)))) + If Entry.AbsoluteRight OrElse Entry.Similarity >= MinBlurSimilarity Then Candidates.Add(Entry) Next '按照相似度进行排序 - Entries = Entries.Sort( - Function(Left, Right) As Boolean - If Left.AbsoluteRight Xor Right.AbsoluteRight Then - Return Left.AbsoluteRight - Else - Return Left.Similarity > Right.Similarity - End If - End Function) + Candidates = Candidates.SortByComparison(Function(Left, Right) If(Left.AbsoluteRight <> Right.AbsoluteRight, Left.AbsoluteRight, Left.Similarity > Right.Similarity)) '返回结果 Dim BlurCount As Integer = 0 - For Each Entry In Entries + For Each Entry In Candidates If Entry.AbsoluteRight Then ResultList.Add(Entry) '完全匹配，直接加入 Else - If Entry.Similarity < MinBlurSimilarity OrElse BlurCount = MaxBlurCount Then Exit For '模糊结果边界条件 + If BlurCount = MaxBlurCount Then Exit For ResultList.Add(Entry) BlurCount += 1 '模糊结果计数 End If @@ -2023,14 +2111,14 @@ RetryDir: Implements IDictionary(Of TKey, TValue) Implements IEnumerable(Of KeyValuePair(Of TKey, TValue)) - Private ReadOnly SyncRoot As New Object + Public ReadOnly SyncRoot As New Object Private ReadOnly _Dictionary As New Dictionary(Of TKey, TValue) '构造函数 Public Sub New() End Sub - Public Sub New(data As IEnumerable(Of KeyValuePair(Of TKey, TValue))) - For Each DataItem In data + Public Sub New(Data As IEnumerable(Of KeyValuePair(Of TKey, TValue))) + For Each DataItem In Data _Dictionary.Add(DataItem.Key, DataItem.Value) Next End Sub @@ -2131,6 +2219,42 @@ RetryDir: End Function End Class + ''' + ''' 将二维数组转换为字典。 + ''' + Public Function ToDictionary(Of T)(arr As T(,)) As Dictionary(Of T, T) + Dim result As New Dictionary(Of T, T) + If arr.Length = 0 Then Return result + If arr.GetLength(1) <> 2 Then Throw New ArgumentException("数组必须为两列，第一列为 Key，第二列为 Value。") + For i As Integer = 0 To arr.GetLength(0) - 1 + result(arr(i, 0)) = arr(i, 1) + Next + Return result + End Function + + ''' + ''' 为 Task 设置超时，在超时时抛出 TimeoutException。 + ''' + Public Function GetResultWithTimeout(Of T)(TargetTask As Task(Of T), TokenSource As CancellationTokenSource, TimeoutMs As Integer) As T + Dim DelayTask = Task.Delay(TimeoutMs) + If Task.WhenAny(TargetTask, DelayTask).ConfigureAwait(False).GetAwaiter().GetResult() Is DelayTask Then + TokenSource.Cancel() + Throw New TimeoutException($"任务超时（{TimeoutMs} ms）") + End If + Return TargetTask.GetAwaiter().GetResult() + End Function + ''' + ''' 为 Task 设置超时，在超时时抛出 TimeoutException。 + ''' + Public Sub GetResultWithTimeout(TargetTask As Task, TokenSource As CancellationTokenSource, TimeoutMs As Integer) + Dim DelayTask = Task.Delay(TimeoutMs) + If Task.WhenAny(TargetTask, DelayTask).ConfigureAwait(False).GetAwaiter().GetResult() Is DelayTask Then + TokenSource.Cancel() + Throw New TimeoutException($"任务超时（{TimeoutMs} ms）") + End If + TargetTask.GetAwaiter().GetResult() + End Sub + ''' ''' 可用于临时存放文件的，不含任何特殊字符的文件夹路径，以“\”结尾。 ''' @@ -2173,16 +2297,29 @@ RetryDir: ''' 返回程序的返回代码，如果运行失败将抛出异常。 ''' Public Function RunAsAdmin(Argument As String) As Integer - Dim NewProcess = Process.Start(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument}) + Dim NewProcess = StartProcess(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument}) NewProcess.WaitForExit() Return NewProcess.ExitCode End Function ''' - ''' 判断当前系统语言是否为 zh-CN。 + ''' 判断当前系统语言是否为中文。 ''' Public Function IsSystemLanguageChinese() As Boolean - Return CultureInfo.CurrentCulture.Name = "zh-CN" OrElse CultureInfo.CurrentUICulture.Name = "zh-CN" + Return CultureInfo.CurrentCulture.Name.StartsWithF("zh-") OrElse CultureInfo.CurrentUICulture.Name.StartsWithF("zh-") + End Function + + ''' + ''' 判断对象是否为某个泛型类型的实例。 + ''' + Public Function IsInstanceOfGenericType(genericType As Type, obj As Object) As Boolean + If obj Is Nothing Then Return False + Dim t = obj.GetType() + While t IsNot Nothing + If t.IsGenericType AndAlso t.GetGenericTypeDefinition() Is genericType Then Return True + t = t.BaseType + End While + Return False End Function Private Uuid As Integer = 1 @@ -2212,7 +2349,7 @@ RetryDir: Next i End Function ''' - ''' 数组去重。 + ''' 去重。 ''' Public Function Distinct(Of T)(Arr As ICollection(Of T), IsEqual As ComparisonBoolean(Of T)) As List(Of T) Dim ResultArray As New List(Of T) @@ -2225,6 +2362,34 @@ NextElement: Next i Return ResultArray End Function + Public Function Any(Arr As UIElementCollection) As Boolean + Return Arr?.Count > 0 + End Function + ''' + ''' 判断这是否是仅有一个元素的集合。 + ''' + Public Function IsSingle(Of T)(Source As IEnumerable(Of T)) As Boolean + If Source Is Nothing Then + Return False + ElseIf TypeOf Source Is IList(Of T) Then + Return DirectCast(Source, IList(Of T)).Count = 1 + Else + Using Enumerator = Source.GetEnumerator() + If Not Enumerator.MoveNext() Then Return False + If Enumerator.MoveNext() Then Return False + Return True + End Using + End If + End Function + ''' + ''' 对集合的每个元素执行指定操作。 + ''' + Public Function ForEach(Of T)(Collection As IEnumerable(Of T), Action As Action(Of T)) As IEnumerable(Of T) + For Each Item As T In Collection + Action(Item) + Next + Return Collection + End Function ''' ''' 获取格式类似于“11:08:52.037”的当前时间的字符串。 @@ -2233,10 +2398,10 @@ NextElement: Return Date.Now.ToString("HH':'mm':'ss'.'fff") End Function ''' - ''' 获取系统运行时间（毫秒），保证为正 Long 且大于 1，但可能突变减小。 + ''' 获取一个单调递增时间值（毫秒）。 ''' - Public Function GetTimeTick() As Long - Return My.Computer.Clock.TickCount + 2147483651L + Public Function GetTimeMs() As Long + Return Stopwatch.GetTimestamp() \ (Stopwatch.Frequency \ 1000L) End Function ''' ''' 将时间间隔转换为类似“5 分 10 秒前”的易于阅读的形式。 @@ -2329,46 +2494,21 @@ NextElement: End Class ''' - ''' 前台运行文件。 + ''' 启动进程并返回进程实例，若失败则抛出异常。 + ''' 会自动进行长路径处理。 ''' - ''' 文件名。可以为“notepad”等缩写。 - ''' 运行参数。 - Public Sub ShellOnly(FileName As String, Optional Arguments As String = "") - Try - FileName = ShortenPath(FileName) - Using Program As New Process - Program.StartInfo.Arguments = Arguments - Program.StartInfo.FileName = FileName - Log("[System] 执行外部命令：" & FileName & " " & Arguments) - Program.Start() - End Using - Catch ex As Exception - Log(ex, "打开文件或程序失败：" & FileName, LogLevel.Msgbox) - End Try - End Sub + Public Function StartProcess(FileName As String, Optional Arguments As String = "") As Process + Return StartProcess(New ProcessStartInfo With {.FileName = FileName, .Arguments = Arguments}) + End Function ''' - ''' 前台运行文件并返回返回值。 + ''' 启动进程并返回进程实例，若失败则抛出异常。 + ''' 会自动进行长路径处理。 ''' - ''' 文件名。可以为“notepad”等缩写。 - ''' 运行参数。 - ''' 等待该程序结束的最长时间（毫秒）。超时会返回 Result.Timeout。 - Public Function ShellAndGetExitCode(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000) As ProcessReturnValues - Try - Using Program As New Process - Program.StartInfo.Arguments = Arguments - Program.StartInfo.FileName = FileName - Log("[System] 执行外部命令并等待返回码：" & FileName & " " & Arguments) - Program.Start() - If Program.WaitForExit(Timeout) Then - Return Program.ExitCode - Else - Return ProcessReturnValues.Timeout - End If - End Using - Catch ex As Exception - Log(ex, "执行命令失败：" & FileName, LogLevel.Msgbox) - Return ProcessReturnValues.Fail - End Try + Public Function StartProcess(StartInfo As ProcessStartInfo) As Process + StartInfo.FileName = ShortenPath(StartInfo.FileName) + If Not String.IsNullOrEmpty(StartInfo.WorkingDirectory) Then StartInfo.WorkingDirectory = ShortenPath(StartInfo.WorkingDirectory) + Log("[System] 启动进程：" & StartInfo.FileName & " " & StartInfo.Arguments) + Return Process.Start(StartInfo) End Function ''' ''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。 @@ -2376,15 +2516,18 @@ NextElement: ''' 文件名。可以为“notepad”等缩写。 ''' 运行参数。 ''' 等待该程序结束的最长时间（毫秒）。超时会抛出错误。 - Public Function ShellAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, Optional WorkingDirectory As String = Nothing) As String + Public Function StartProcessAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, + Optional WorkingDirectory As String = Nothing, Optional Encoding As Encoding = Nothing, Optional PrintLog As Boolean = True) As String Dim Info = New ProcessStartInfo With { .Arguments = Arguments, - .FileName = FileName, + .FileName = ShortenPath(FileName), .UseShellExecute = False, .CreateNoWindow = True, .RedirectStandardError = True, .RedirectStandardOutput = True, - .WorkingDirectory = ShortenPath(If(WorkingDirectory, Path.TrimEnd("\"c))) + .WorkingDirectory = ShortenPath(If(WorkingDirectory, Path.TrimEnd("\"c))), + .StandardErrorEncoding = Encoding, + .StandardOutputEncoding = Encoding } If WorkingDirectory IsNot Nothing Then If Info.EnvironmentVariables.ContainsKey("appdata") Then @@ -2393,8 +2536,8 @@ NextElement: Info.EnvironmentVariables.Add("appdata", WorkingDirectory) End If End If - Log("[System] 执行外部命令并等待返回结果：" & FileName & " " & Arguments) - Using Program As New Process() With {.StartInfo = Info} + If PrintLog Then Log("[System] 执行命令并等待返回结果：" & FileName & " " & Arguments) + Using Program As New Process With {.StartInfo = Info} Program.Start() Dim Result As String = Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd Program.WaitForExit(Timeout) @@ -2462,17 +2605,105 @@ NextElement: ''' Public Sub RunInThread(Action As Action) If RunInUi() Then - RunInNewThread(Action, "Runtime Invoke " & GetUuid() & "#") + RunInNewThread(Action, "Invoke " & GetUuid()) Else Action() End If End Sub ''' - ''' 按照既定的函数进行选择排序。 - ''' 传入两个对象，若第一个对象应该排在前面，则返回 True。 + ''' 选择所有最大值对应的对象。 + ''' 若没有元素则返回空列表。 ''' - Public Function Sort(Of T)(List As IList(Of T), SortRule As ComparisonBoolean(Of T)) As List(Of T) + Public Function MaxByAll(Of T, C As IComparable(Of C))(Source As IEnumerable(Of T), Selector As Func(Of T, C)) As List(Of T) + Dim Results As New List(Of T) + Using Enumerator = Source.GetEnumerator() + If Not Enumerator.MoveNext() Then Return Results + Dim MaxItem As T = Enumerator.Current + Dim MaxValue As C = Selector(MaxItem) + Results.Add(MaxItem) + While Enumerator.MoveNext() + Dim CurrentItem = Enumerator.Current + Dim CurrentValue = Selector(CurrentItem) + Dim Comparison = CurrentValue.CompareTo(MaxValue) + If Comparison > 0 Then + MaxValue = CurrentValue + Results.Clear() + Results.Add(CurrentItem) + ElseIf Comparison = 0 Then + Results.Add(CurrentItem) + End If + End While + End Using + Return Results + End Function + ''' + ''' 选择所有最小值对应的对象。 + ''' 若没有元素则返回空列表。 + ''' + Public Function MinByAll(Of T, C As IComparable(Of C))(List As IEnumerable(Of T), Selector As Func(Of T, C)) As List(Of T) + Dim Results As New List(Of T) + Using Enumerator = List.GetEnumerator() + If Not Enumerator.MoveNext() Then Return Results + Dim MinItem As T = Enumerator.Current + Dim MinValue As C = Selector(MinItem) + Results.Add(MinItem) + While Enumerator.MoveNext() + Dim CurrentItem = Enumerator.Current + Dim CurrentValue = Selector(CurrentItem) + Dim Comparison = CurrentValue.CompareTo(MinValue) + If Comparison < 0 Then + MinValue = CurrentValue + Results.Clear() + Results.Add(CurrentItem) + ElseIf Comparison = 0 Then + Results.Add(CurrentItem) + End If + End While + End Using + Return Results + End Function + ''' + ''' 选择最大值对应的对象。 + ''' 若没有元素则返回 Nothing。 + ''' + Public Function MaxBy(Of T, C As IComparable(Of C))(Source As IEnumerable(Of T), Selector As Func(Of T, C)) As T + Using Enumerator = Source.GetEnumerator() + If Not Enumerator.MoveNext() Then Return Nothing + Dim MaxItem As T = Enumerator.Current + Dim MaxValue As C = Selector(MaxItem) + While Enumerator.MoveNext() + Dim Value = Selector(Enumerator.Current) + If Value.CompareTo(MaxValue) <= 0 Then Continue While + MaxItem = Enumerator.Current + MaxValue = Value + End While + Return MaxItem + End Using + End Function + ''' + ''' 选择最小值对应的对象。 + ''' 若没有元素则返回 Nothing。 + ''' + Public Function MinBy(Of T, C As IComparable(Of C))(List As IEnumerable(Of T), Selector As Func(Of T, C)) As T + Using Enumerator = List.GetEnumerator() + If Not Enumerator.MoveNext() Then Return Nothing + Dim MinItem As T = Enumerator.Current + Dim MinValue As C = Selector(MinItem) + While Enumerator.MoveNext() + Dim Value = Selector(Enumerator.Current) + If Value.CompareTo(MinValue) >= 0 Then Continue While + MinItem = Enumerator.Current + MinValue = Value + End While + Return MinItem + End Using + End Function + ''' + ''' 按照既定的函数进行选择排序。 + ''' 返回第一个对象是否应该排在前面（a > b）。 + ''' + Public Function SortByComparison(Of T)(List As IList(Of T), SortRule As ComparisonBoolean(Of T)) As List(Of T) Dim NewList As New List(Of T) While List.Any Dim Highest = List(0) @@ -2496,17 +2727,14 @@ NextElement: ''' ''' 尝试从字典中获取某项，如果该项不存在，则返回默认值。 ''' - Public Function GetOrDefault(Of TKey, TValue)(Dict As Dictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue - If Dict.ContainsKey(Key) Then - Return Dict(Key) - Else - Return DefaultValue - End If + Public Function GetOrDefault(Of TKey, TValue)(Dict As IDictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue + Dim Result As TValue + Return If(Dict.TryGetValue(Key, Result), Result, DefaultValue) End Function ''' ''' 将某项添加到以列表作为值的字典中。 ''' - Public Sub AddToList(Of TKey, TValue)(Dict As Dictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue) + Public Sub AddToList(Of TKey, TValue)(Dict As IDictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue) If Dict.ContainsKey(Key) Then Dict(Key).Add(Value) Else @@ -2550,11 +2778,11 @@ NextElement: ''' Public Sub OpenWebsite(Url As String) Try - If Not Url.StartsWithF("http", True) AndAlso Not Url.StartsWithF("minecraft://", True) Then + If Not Url.StartsWithF("http", True) AndAlso Not Url.StartsWithF("minecraft://", True) AndAlso Not Url.StartsWithF("minecraft-preview://", True) Then Throw New Exception(Url & " 不是一个有效的网址，它必须以 http 开头！") End If Log("[System] 正在打开网页：" & Url) - Process.Start(Url) + StartProcess(Url) Catch ex As Exception Log(ex, "无法打开网页（" & Url & "）") ClipboardSet(Url, False) @@ -2568,12 +2796,12 @@ NextElement: ''' Public Sub OpenExplorer(Location As String) Try - Location = ShortenPath(Location.Replace("/", "\").Trim(" "c, """"c)) + Location = Location.Replace("/", "\").Trim(" "c, """"c) Log("[System] 正在打开资源管理器：" & Location) - If Location.EndsWith("\") Then - ShellOnly(Location) + If Location.EndsWithF("\") Then + StartProcess(Location) Else - ShellOnly("explorer", $"/select,""{Location}""") + StartProcess("explorer", $"/select,""{Location}""") End If Catch ex As Exception Log(ex, "打开资源管理器失败，请尝试关闭安全软件（如 360 安全卫士）", LogLevel.Msgbox) @@ -2592,7 +2820,7 @@ Retry: RunInUi( Sub() My.Computer.Clipboard.Clear() - My.Computer.Clipboard.SetText(Text) + If Not String.IsNullOrEmpty(Text) Then My.Computer.Clipboard.SetText(Text) End Sub) Catch ex As Exception RetryCount += 1 @@ -2603,9 +2831,24 @@ Retry: Log(ex, "可能由于剪贴板被其他程序占用，文本复制失败", LogLevel.Hint) End If End Try - If ShowSuccessHint Then Hint("已成功复制！", HintType.Finish) + If ShowSuccessHint Then Hint("已成功复制！", HintType.Green) End Sub) End Sub + ''' + ''' 获取剪贴板文本。将在 UI 线程运行，且不会抛出异常。 + ''' + Public Function ClipboardGetText() As String + Dim Result As String = Nothing + RunInUiWait( + Sub() + Try + If My.Computer.Clipboard.ContainsText() Then Result = My.Computer.Clipboard.GetText() + Catch ex As Exception + Log(ex, "获取剪贴板文本失败") + End Try + End Sub) + Return Result + End Function ''' ''' 以 Byte() 形式获取程序中的资源。 @@ -2625,10 +2868,6 @@ Retry: ''' 相对增减控件的左边距。 ''' Public Sub DeltaLeft(control As FrameworkElement, newValue As Double) - '安全性检查 - DebugAssert(Not Double.IsNaN(newValue)) - DebugAssert(Not Double.IsInfinity(newValue)) - If TypeOf control Is Window Then '窗口改变 CType(control, Window).Left += newValue @@ -2640,8 +2879,6 @@ Retry: Case HorizontalAlignment.Right control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right - newValue, control.Margin.Bottom) 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom) - Case Else - DebugAssert(False) End Select End If End Sub @@ -2649,17 +2886,12 @@ Retry: ''' 设置控件的左边距。（仅针对置左控件） ''' Public Sub SetLeft(control As FrameworkElement, newValue As Double) - DebugAssert(control.HorizontalAlignment = HorizontalAlignment.Left) control.Margin = New Thickness(newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom) End Sub ''' ''' 相对增减控件的上边距。 ''' Public Sub DeltaTop(control As FrameworkElement, newValue As Double) - '安全性检查 - DebugAssert(Not Double.IsNaN(newValue)) - DebugAssert(Not Double.IsInfinity(newValue)) - If TypeOf control Is Window Then '窗口改变 CType(control, Window).Top += newValue @@ -2671,11 +2903,8 @@ Retry: Case VerticalAlignment.Bottom control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, control.Margin.Bottom - newValue) 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom) - Case Else - DebugAssert(False) End Select End If - 'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Return '安全性检查 'Select Case control.VerticalAlignment ' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center @@ -2689,7 +2918,6 @@ Retry: ''' 设置控件的顶边距。（仅针对置上控件） ''' Public Sub SetTop(control As FrameworkElement, newValue As Double) - DebugAssert(control.VerticalAlignment = VerticalAlignment.Top) control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom) End Sub @@ -2747,24 +2975,35 @@ Retry: ''' ''' 将 XML 转换为对应 UI 对象。 + ''' 注意：性能较差，不应大量使用。 ''' Public Function GetObjectFromXML(Str As XElement) Return GetObjectFromXML(Str.ToString) End Function ''' ''' 将 XML 转换为对应 UI 对象。 + ''' 注意：性能较差，不应大量使用。 ''' Public Function GetObjectFromXML(Str As String) As Object + Str = Str. '兼容旧版自定义事件写法 + Replace("EventType=""", "local:CustomEventService.EventType="""). + Replace("EventData=""", "local:CustomEventService.EventData="""). + Replace("EventType='", "local:CustomEventService.EventType='"). + Replace("EventData='", "local:CustomEventService.EventData='"). + Replace("Property=""EventType""", "Property=""local:CustomEventService.EventType"""). + Replace("Property=""EventData""", "Property=""local:CustomEventService.EventData"""). + Replace("Property='EventType'", "Property='local:CustomEventService.EventType'"). + Replace("Property='EventData'", "Property='local:CustomEventService.EventData'") Using Stream As New MemoryStream(Encoding.UTF8.GetBytes(Str)) '类型检查 Using Reader As New XamlXmlReader(Stream) While Reader.Read() - For Each BlackListType In {GetType(WebBrowser), GetType(Frame), GetType(MediaElement), GetType(ObjectDataProvider), GetType(XamlReader), GetType(Window), GetType(XmlDataProvider)} - If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 类型。") - If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 值。") + For Each BlackListType In {GetType(WebBrowser), GetType(Frame), GetType(MediaElement), GetType(ObjectDataProvider), GetType(XamlReader), GetType(Window), GetType(XmlDataProvider), GetType(SettingService)} + If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 类型。") + If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 值。") Next For Each BlackListMember In {"Code", "FactoryMethod", "Static"} - If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListMember} 成员。") + If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListMember} 成员。") Next End While End Using @@ -2816,11 +3055,22 @@ Retry: Return formattedText.Width End Function + ''' + ''' 将布尔值转换为 Visibility。True 转换为 Visible，False 转换为 Collapsed。 + ''' + Public Function ToVisibility(IsVisible As Boolean) As Visibility + Return If(IsVisible, Visibility.Visible, Visibility.Collapsed) + End Function + #End Region #Region "Debug" - Public ModeDebug As Boolean = False + Public ReadOnly Property ModeDebug As Boolean + Get + Return Settings.Get("SystemDebugMode") + End Get + End Property 'Log Public Enum LogLevel @@ -2870,7 +3120,7 @@ Retry: File.Create(Path & "PCL\Log1.txt").Dispose() Catch ex As IOException IsInitSuccess = False - Hint("可能同时开启了多个 PCL，程序可能会出现未知问题！", HintType.Critical) + Hint("可能同时开启了多个 PCL，程序可能会出现未知问题！", HintType.Red) Log(ex, "日志初始化失败（疑似文件占用问题）") Catch ex As Exception IsInitSuccess = False @@ -2922,7 +3172,8 @@ Retry: '处理错误会导致再次调用 Log() 导致无限循环 '输出日志 - Dim AppendText As String = "[" & GetTimeNow() & "] " & Text & vbCrLf '减轻同步锁占用 + Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Text}{vbCrLf}" '减轻同步锁占用 + AppendText = FilterUserName(FilterAccessToken(AppendText, "*"), "*") If ModeDebug Then SyncLock LogListLock LogList.Append(AppendText) @@ -2942,16 +3193,16 @@ Retry: Select Case Level #If DEBUG Then Case LogLevel.Developer - Hint("[开发者模式] " & Text, HintType.Info, False) + Hint("[开发者模式] " & Text, HintType.Blue, False) Case LogLevel.Debug - Hint("[调试模式] " & Text, HintType.Info, False) + Hint("[调试模式] " & Text, HintType.Blue, False) #Else Case LogLevel.Developer Case LogLevel.Debug - If ModeDebug Then Hint("[调试模式] " & Text, HintType.Info, False) + If ModeDebug Then Hint("[调试模式] " & Text, HintType.Blue, False) #End If Case LogLevel.Hint - Hint(Text, HintType.Critical, False) + Hint(Text, HintType.Red, False) Case LogLevel.Msgbox MyMsgBox(Text, Title, IsWarn:=True) Case LogLevel.Feedback @@ -2973,6 +3224,13 @@ Retry: End If End Select + '上报 + If Level >= LogLevel.Hint Then + Telemetry("PCL 错误", + "Level", GetStringFromEnum(Level), + "Title", FilterUserName(FilterAccessToken(Title, "*"), "*"), + "Exception", FilterUserName(FilterAccessToken(Text, "*"), "*")) + End If End Sub ''' ''' 输出错误信息。 @@ -2983,10 +3241,11 @@ Retry: If TypeOf Ex Is ThreadInterruptedException Then Return '获取错误信息 - Dim ExFull As String = Desc & "：" & GetExceptionDetail(Ex) + Dim ExFull As String = $"{Desc}：{Ex.GetDetail()}" '输出日志 - Dim AppendText As String = "[" & GetTimeNow() & "] " & Desc & "：" & GetExceptionDetail(Ex, True) & vbCrLf '减轻同步锁占用 + Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}：{Ex.GetDetail(True)}{vbCrLf}" '减轻同步锁占用 + AppendText = FilterUserName(FilterAccessToken(AppendText, "*"), "*") If ModeDebug Then SyncLock LogListLock LogList.Append(AppendText) @@ -3004,20 +3263,20 @@ Retry: Case LogLevel.Normal #If DEBUG Then Case LogLevel.Developer - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint("[开发者模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint("[开发者模式] " & ExLine, HintType.Blue, False) Case LogLevel.Debug - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint("[调试模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint("[调试模式] " & ExLine, HintType.Blue, False) #Else Case LogLevel.Developer Case LogLevel.Debug - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Blue, False) #End If Case LogLevel.Hint - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint(ExLine, HintType.Critical, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint(ExLine, HintType.Red, False) Case LogLevel.Msgbox MyMsgBox(ExFull, Title, IsWarn:=True) Case LogLevel.Feedback @@ -3039,6 +3298,13 @@ Retry: End If End Select + '上报 + If Level >= LogLevel.Hint Then + Telemetry("PCL 异常", + "Level", GetStringFromEnum(Level), + "Title", FilterUserName(FilterAccessToken(Title, "*"), "*"), + "Exception", FilterUserName(FilterAccessToken(ExFull, "*"), "*")) + End If End Sub '反馈 @@ -3048,7 +3314,7 @@ Retry: If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug，请点击 打开文件夹 按钮，并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关，请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then OpenExplorer(Path & "PCL\Log1.txt") End If - OpenWebsite("https://github.com/Hex-Dragon/PCL2/issues/") + OpenWebsite("https://github.com/Meloong-Git/PCL/issues/") End Sub Public Function CanFeedback(ShowHint As Boolean) As Boolean If False.Equals(PageSetupSystem.IsLauncherNewest) Then @@ -3071,21 +3337,38 @@ Retry: "操作系统：" & 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 & + "MC 文件夹：" & If(McFolderSelected, "Nothing") & vbCrLf & "文件位置：" & Path) End Sub - '断言 - Public Sub DebugAssert(Exp As Boolean) - If Not Exp Then Throw New Exception("断言命中") + '遥测 + Public Sub Telemetry([Event] As String, ParamArray Datas As String()) +#If Not RELEASE And Not BETA Then + Return '开发版不上传遥测 +#End If + If Not Settings.Get("SystemSystemTelemetry") Then Return '用户关闭了遥测 + If Not ClsBaseUrl.StartsWithF("http") Then Return '开源版没有设置遥测地址 + RunInNewThread( + Sub() + Try + Log($"[System] 匿名数据上报：{[Event]}") + Dim Url As String = $"{ClsBaseUrl}&Event={WebUtility.UrlEncode([Event])}" + For i = 0 To Datas.Length - 1 Step 2 + Url &= "&" & WebUtility.UrlEncode(Datas(i)) & "=" & WebUtility.UrlEncode(Datas(i + 1).Replace(vbCrLf, vbLf)) + Next + NetRequestByClient(Url, MakeLog:=False) + Catch ex As Exception + Log(ex, "匿名数据上报失败") + End Try + End Sub, "Telemetry", ThreadPriority.Lowest) End Sub '获取当前的堆栈信息 Public Function GetStackTrace() As String - Dim Stack As New StackTrace() - Return Join(Stack.GetFrames().Skip(1).Select(Function(f) f.GetMethod). - Select(Function(f) f.Name & "(" & Join(f.GetParameters.Select(Function(p) p.ToString).ToList, ", ") & ") - " & f.Module.ToString).ToList, - vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf) + Return (New StackTrace).GetFrames().Skip(1). + Select(Function(f) f.GetMethod). + Select(Function(f) $"{f.Name}({f.GetParameters.Select(Function(p) p.ToString).Join(", ")}) - {f.Module}"). + Join(vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf) End Function #End Region @@ -3102,7 +3385,7 @@ Retry: End Function ''' - ''' 取随机整数。 + ''' 取随机整数（包含）。 ''' Public Function RandomInteger(min As Integer, max As Integer) As Integer Return Math.Floor((max - min + 1) * Random.NextDouble) + min @@ -3111,12 +3394,12 @@ Retry: ''' ''' 将数组随机打乱。 ''' - Public Function Shuffle(Of T)(array As IList(Of T)) As IList(Of T) - Shuffle = New List(Of T) - Do While array.Any - Dim i As Integer = RandomInteger(0, array.Count - 1) - Shuffle.Add(array(i)) - array.RemoveAt(i) + Public Iterator Function Shuffle(Of T)(Raw As IEnumerable(Of T)) As IEnumerable(Of T) + Dim RawCopy As New List(Of T)(Raw) + Do While RawCopy.Any + Dim i As Integer = RandomInteger(0, RawCopy.Count - 1) + Yield RawCopy(i) + RawCopy.RemoveAt(i) Loop End Function diff --git a/Plain Craft Launcher 2/Modules/Base/ModLoader.vb b/Plain Craft Launcher 2/Modules/Base/ModLoader.vb index c0bb4c8..4dc8dd0 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModLoader.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModLoader.vb @@ -8,6 +8,7 @@ Implements ILoadingTrigger Public ReadOnly Property IsLoader As Boolean = True Implements ILoadingTrigger.IsLoader + Protected Shared LogBlackList As String() = {"EasyTier CLI"} '基础属性 ''' @@ -87,9 +88,9 @@ Set(value As LoadState) If _State = value Then Return Dim OldState = _State - If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) + If value = LoadState.Finished AndAlso Settings.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) _State = value - Log("[Loader] 加载器 " & Name & " 状态改变：" & GetStringFromEnum(value)) + If Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载器 {Name} 状态改变：{GetStringFromEnum(value)}") '实现 ILoadingTrigger 接口与 OnStateChanged 回调 RunInUi( Sub() @@ -148,7 +149,7 @@ Case LoadState.Waiting Return 0 Case LoadState.Loading - Return If(_Progress = -1, 0.02, _Progress) + Return If(_Progress = -1, 0, _Progress) Case Else Return 1 End Select @@ -169,7 +170,8 @@ '状态变化 Public MustOverride Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False) - Public MustOverride Sub Abort() + Public MustOverride Sub Interrupt() + Public MustOverride Sub Failed(Ex As Exception) '等待结束 Public Const WaitForExitTimeoutMessage As String = "等待加载器执行超时。" @@ -185,7 +187,7 @@ Loop If State = LoadState.Finished Then Return - ElseIf State = LoadState.Aborted Then + ElseIf State = LoadState.Interrupted Then Throw New ThreadInterruptedException("加载器执行已中断。") ElseIf IsNothing([Error]) Then Throw New Exception("未知错误！") @@ -208,7 +210,7 @@ Loop If State = LoadState.Finished Then Return - ElseIf State = LoadState.Aborted Then + ElseIf State = LoadState.Interrupted Then Throw New ThreadInterruptedException("加载器执行已中断。") ElseIf IsNothing([Error]) Then Throw New Exception("未知错误！") @@ -239,16 +241,16 @@ ''' ''' 当前执行线程是否应当中断。只应用在加载器的工作线程中判断，不可跨线程调用。 ''' - Public ReadOnly Property IsAborted As Boolean + Public ReadOnly Property IsInterrupted As Boolean Get - Return IsAbortedWithThread(Thread.CurrentThread) + Return IsInterruptedWithThread(Thread.CurrentThread) End Get End Property ''' ''' 当前执行线程是否应当中断。需要手动提供加载器线程，用于需要跨线程检查的情况。 ''' - Public Function IsAbortedWithThread(Thread As Thread) As Boolean - Return LastRunningThread Is Nothing OrElse Not ReferenceEquals(Thread, LastRunningThread) OrElse State = LoadState.Aborted + Public Function IsInterruptedWithThread(Thread As Thread) As Boolean + Return LastRunningThread Is Nothing OrElse Not ReferenceEquals(Thread, LastRunningThread) OrElse State = LoadState.Interrupted End Function ''' ''' 在输入相同时使用原有结果的超时，单位为毫秒。 @@ -290,18 +292,20 @@ '检验输入以确定情况 If IsForceRestart Then Return True '强制要求重启 If ((Input Is Nothing) <> (Me.Input Is Nothing)) OrElse (Input IsNot Nothing AndAlso Not Input.Equals(Me.Input)) Then Return True '输入不同 - If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束 - (IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时 - Return False '则不重试 + + If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束… + (IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse + LastFinishedTime = 0 OrElse GetTimeMs() - LastFinishedTime < ReloadTimeout) Then '…且没有超时… + Return False '…则不重试 Else - Return True '需要开始 + Return True '否则需要重启 End If End Function Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False) '确认是否开始加载 If ShouldStart(Input, IsForceRestart) Then '输入不同或失败，开始加载 - If State = LoadState.Loading Then TriggerThreadAbort() + If State = LoadState.Loading Then TriggerThreadInterrupt() Me.Input = Input SyncLock LockState State = LoadState.Loading @@ -315,44 +319,57 @@ Sub() Try IsForceRestarting = IsForceRestart - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动") + If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动") LoadDelegate(Me) - If IsAborted Then + If IsInterrupted Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer) Return End If - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成") + If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成") RaisePreviewFinish() State = LoadState.Finished - LastFinishedTime = GetTimeTick() '未中断，本次输出有效 + LastFinishedTime = GetTimeMs() '未中断，本次输出有效 Catch ex As CancelledException If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%") - If Not IsAborted Then State = LoadState.Aborted + If Not IsInterrupted Then State = LoadState.Interrupted Catch ex As ThreadInterruptedException If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%") - '如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted - '如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted - If Not IsAborted Then State = LoadState.Aborted + '如果线程是因为判断到 IsInterrupted 而提前中止，则代表已有新线程被重启，此时不应当改为 Interrupted + '如果线程是在没有 IsInterrupted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Interrupted + If Not IsInterrupted Then State = LoadState.Interrupted Catch ex As Exception - If IsAborted Then Return - Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer) - [Error] = ex - State = LoadState.Failed + Failed(ex) End Try - End Sub) With {.Name = Name, .Priority = ThreadPriority} - LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted + End Sub) With {.Name = "L/" & Name, .Priority = ThreadPriority} + Try + LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsInterrupted + Catch ex As ThreadStateException '若遇到偶发的 “线程正在运行或被终止”，则等待后重试 + Thread.Sleep(500) + LastRunningThread.Start() + End Try End Sub - Public Overrides Sub Abort() - If State <> LoadState.Loading Then Return + Public Overrides Sub Failed(ex As Exception) + [Error] = ex SyncLock LockState - State = LoadState.Aborted + If IsInterrupted OrElse State >= LoadState.Finished Then Return + State = LoadState.Failed End SyncLock - TriggerThreadAbort() + Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer) + TriggerThreadInterrupt() End Sub - Private Sub TriggerThreadAbort() + Public Overrides Sub Interrupt() + SyncLock LockState + If State <> LoadState.Loading Then Return + State = LoadState.Interrupted + End SyncLock + TriggerThreadInterrupt() + End Sub + Private Sub TriggerThreadInterrupt() If LastRunningThread Is Nothing Then Return - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断") - If LastRunningThread.IsAlive Then LastRunningThread.Interrupt() + If LastRunningThread.IsAlive Then + LastRunningThread.Interrupt() + If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断") + End If LastRunningThread = Nothing End Sub @@ -434,11 +451,11 @@ End If RunInThread(AddressOf Update) End Sub - Public Overrides Sub Abort() + Public Overrides Sub Interrupt() '改变状态 SyncLock LockState If State = LoadState.Loading OrElse State = LoadState.Waiting Then - State = LoadState.Aborted + State = LoadState.Interrupted Else Return End If @@ -447,10 +464,21 @@ Sub() '中断加载器 For Each Loader In Loaders - Loader.Abort() + Loader.Interrupt() Next End Sub) End Sub + Public Overrides Sub Failed(Ex As Exception) + [Error] = Ex '先设置错误再调整状态，防止父加载器获取不到异常 + SyncLock LockState + If State >= LoadState.Finished Then Return + State = LoadState.Failed + End SyncLock + For Each Loader In Loaders + Loader.Interrupt() + Next + FrmMain.BtnExtraDownload.ShowRefresh() + End Sub ''' ''' 子任务状态变更。 @@ -465,28 +493,19 @@ Case LoadState.Finished '正常结束，触发刷新 Update() - Case LoadState.Aborted + Case LoadState.Interrupted '被中断，这个任务也中断 - Abort() - Case Else + Interrupt() + Case LoadState.Failed '完蛋，出错了 - SyncLock LockState - If State >= LoadState.Finished Then Return - [Error] = New Exception(Loader.Name & "失败", Loader.Error) - State = Loader.State - End SyncLock - For Each Loader In Loaders - Loader.Abort() - Next - FrmMain.BtnExtraDownload.ShowRefresh() - Return + Failed(New Exception(Loader.Name & "失败", Loader.Error)) End Select End Sub ''' ''' 触发一次更新，以启动新加载器或完成。 ''' Private Sub Update() - If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Return + If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Interrupted Then Return Dim IsFinished As Boolean = True Dim Blocked As Boolean = False Dim Input As Object = Me.Input @@ -588,7 +607,7 @@ Restart: '若单个任务已中止，或全部任务已完成，则刷新并移除 For Each Task In LoaderTaskbar If LoaderTaskbar.All(Function(l) l.State <> LoadState.Loading) OrElse - (Task.State = LoadState.Waiting OrElse Task.State = LoadState.Aborted) Then + (Task.State = LoadState.Waiting OrElse Task.State = LoadState.Interrupted) Then FrmSpeedLeft?.TaskRefresh(Task) LoaderTaskbar.Remove(Task) Log($"[Taskbar] {Task.Name} 已移出任务列表") diff --git a/Plain Craft Launcher 2/Modules/Base/ModNet.vb b/Plain Craft Launcher 2/Modules/Base/ModNet.vb index f7d1b3c..ed60a3c 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModNet.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModNet.vb @@ -1,317 +1,70 @@ -Imports System.Drawing -Imports System.Net.Http -Imports System.Net.Http.Headers +Imports System.Net.Sockets +Imports System.Runtime.CompilerServices Imports System.Threading.Tasks -Imports Newtonsoft.Json Public Module ModNet - Public Const NetDownloadEnd As String = ".PCLDownloading" - Public ReadOnly HttpProxy As New HttpWebProxyFactory() - Private ClientFactory As New HttpClientFactory() - Private Request As New HttpRequest() - Public Class HttpRequest - Public Sub New() - End Sub - Public Function GetRequestMessage(RequestUrl As String, - Optional Method As String = "GET", - Optional Headers As Dictionary(Of String, String) = Nothing, - Optional Data As Byte() = Nothing, - Optional UseBrowserUA As Boolean = False, - Optional RequireHeaderSign As Boolean = False, - Optional RequireCdnSign As Boolean = False) As HttpRequestMessage - Dim RequestMethod As HttpMethod = GetHttpMethod(Method) - If RequireCdnSign Then RequestUrl = SecretCdnSign(RequestUrl) +#Region "网络请求" - Dim RequestMessage As New HttpRequestMessage(RequestMethod, RequestUrl) - '基本参数验证 - If Data IsNot Nothing AndAlso Not {HttpMethod.Get, HttpMethod.Head}.Contains(RequestMethod) Then - RequestMessage.Content = New ByteArrayContent(Data) - RequestMessage.Content.Headers.ContentLength = Data.Length - End If - - If Headers IsNot Nothing Then - For Each Header In Headers - If Header.Key.ContainsF("Content") AndAlso RequestMessage.Content IsNot Nothing Then - 'FixContentHeader 往下挪一行就 NullReference 了 -FixContentHeader: - If Data Is Nothing OrElse RequestMessage.Content Is Nothing Then Continue For - If RequestMessage.Content.Headers.Contains(Header.Key) Then Continue For - If Not RequestMessage.Content.Headers.Contains(Header.Key) Then - If Header.Key.ToLower() = "Content-Type" Then RequestMessage.Content.Headers.ContentType = New MediaTypeHeaderValue(Header.Value) - RequestMessage.Content.Headers.TryAddWithoutValidation(Header.Key, Header.Value) - End If - Else - '不知道为什么 Content-Type 标头会通过字符串验证然后加入不应该被加入的 HttpRequestMessage Headers - '这会导致 HttpRequestMessage 内部的标头验证失败，并抛出一个 Exception 导致网络请求失败 - If Header.Key.ContainsF("Content") Then GoTo FixContentHeader - If RequestMessage.Headers.Contains(Header.Key) Then Continue For - RequestMessage.Headers.Add(Header.Key, Header.Value) - End If - Next - End If - - If RequireHeaderSign Then - SecretHeadersSign(RequestUrl, requestMessage, UseBrowserUA) - End If - - Return RequestMessage - - End Function - - ' 发送请求 - Public Function SendRequest(Req As HttpRequestMessage, - Optional RequireDecode As Boolean = True, - Optional Encode As Encoding = Nothing, - Optional Timeout As Integer = 25000, - Optional RequireReturnRespObj As Boolean = False) - Using CTS As New CancellationTokenSource(Timeout) - Dim Client = ClientFactory.GetHttpClient() - Dim Resp As HttpResponseMessage = Client.SendAsync(Req, HttpCompletionOption.ResponseHeadersRead, CTS.Token).GetAwaiter().GetResult() - - If RequireReturnRespObj Then Return Resp - - Resp.EnsureSuccessStatusCode() - CTS.CancelAfter(Timeout) - Dim ResultStream = Resp.Content.ReadAsStreamAsync().GetAwaiter().GetResult() - Using DataStream As New MemoryStream() - ResultStream.CopyTo(DataStream) - Dim Bytes = DataStream.ToArray() - Resp.Dispose() - Req.Dispose() - - If RequireDecode Then - If Encode Is Nothing Then Encode = Encoding.UTF8 - Return Encode.GetString(Bytes) - Else - Return Bytes - End If - End Using - End Using - - - End Function - - ' 获取HttpMethod - Private Function GetHttpMethod(Method As String) As HttpMethod - Select Case Method?.Trim().ToUpperInvariant() - Case "HEAD" - Return HttpMethod.Head - Case "POST" - Return HttpMethod.Post - Case "PUT" - Return HttpMethod.Put - Case "DELETE" - Return HttpMethod.Delete - Case Else - Return HttpMethod.Get - End Select - End Function - - - End Class - - Public Class HttpWebProxyFactory - Implements IWebProxy - Public DisableHttpProxy As Boolean = True - Public ProxyAddress As String - Private CurrentProxy As WebProxy - Public RequiredReloadProxy As Boolean - Public RefreshSyncLock As New Object - Public SystemProxy As New WebProxy() - Public Sub New() - End Sub - - Public Property Credentials As ICredentials Implements IWebProxy.Credentials - Get - Return AuthCredentials - End Get - Set(value As ICredentials) - AuthCredentials = value - End Set - End Property - Private AuthCredentials As ICredentials - - Public Function GetProxy(destination As Uri) As Uri Implements IWebProxy.GetProxy - Return GetProxy(destination.AbsoluteUri).Address - End Function - Public Function GetProxy(destination As String) As WebProxy - If CurrentProxy IsNot Nothing AndAlso Not RequiredReloadProxy Then Return CurrentProxy - If RequiredReloadProxy OrElse CurrentProxy Is Nothing Then - If ProxyAddress IsNot Nothing OrElse - Not String.IsNullOrWhiteSpace(ProxyAddress) Then - SyncLock RefreshSyncLock - CurrentProxy = New WebProxy(ProxyAddress, True) - If AuthCredentials IsNot Nothing Then CurrentProxy.Credentials = AuthCredentials - Return CurrentProxy - End SyncLock - Else - SyncLock RefreshSyncLock - CurrentProxy = New WebProxy() - If AuthCredentials IsNot Nothing Then CurrentProxy.Credentials = AuthCredentials - Return CurrentProxy - End SyncLock + ''' + ''' 发送一次网络请求并获取返回内容。 + ''' + Public Function NetRequestByClient(Url As String, Optional Method As HttpMethod = Nothing, + Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", + Optional Timeout As Integer = 25000, Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False, Optional MakeLog As Boolean = True) As String + If Method Is Nothing Then Method = HttpMethod.Get + If MakeLog Then Log("[Net] 发起网络请求（" & Method.Method & "，" & Url & "），最大超时 " & Timeout) + Try + Dim HeaderDictionary = If(Headers, {}).ToDictionary + If ContentType IsNot Nothing Then HeaderDictionary("Content-Type") = ContentType + If Accept IsNot Nothing Then HeaderDictionary("Accept") = Accept + Dim Result = If(Encoding, Encoding.UTF8).GetString(SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, SimulateBrowserHeaders:=SimulateBrowserHeaders)) + '检查结果是否为完整 JSON（在 #6683 中可能返回空，在被 GFW 截断时可能不完整） + '在此处检查并报错，可以让 NetRequestByClientRetry 等方法进行重试 + If RequireJson Then + Result = Result.Trim((vbCrLf & " ").ToCharArray) 'Authlib-Injector 的结果会在末尾附带一个空行 + If Not (Result.StartsWithF("{") AndAlso Result.EndsWithF("}")) AndAlso + Not (Result.StartsWithF("[") AndAlso Result.EndsWithF("]")) Then + Throw New FormatException("返回结果并非 JSON 格式：" & + If(Result.Length > 2000, Result.Substring(0, 1000) & "..." & Result.Substring(Result.Length - 1000), Result)) End If End If - Return Nothing - End Function - Public Function IsBypassed(host As Uri) As Boolean Implements IWebProxy.IsBypassed - If DisableHttpProxy Then Return True - If CurrentProxy Is Nothing Then - SyncLock RefreshSyncLock - CurrentProxy = GetProxy(host.AbsoluteUri) - End SyncLock - End If - If CurrentProxy.IsBypassed(host) Then Return True - Return False - End Function - End Class - - Public Class HttpClientFactory - Private PreviousClient As HttpClient - Private CurrentClient As HttpClient - Private HttpClientLock As New Object - Public ClientHandler As New HttpClientHandler() With { - .UseProxy = True, - .Proxy = HttpProxy, - .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None - } - Public Sub New() - HttpClientReload() - End Sub - Public Function GetHttpClient(Optional Handler As HttpClientHandler = Nothing) As HttpClient - SyncLock HttpClientLock - If Handler IsNot Nothing Then - ClientHandler = Handler - CurrentClient.Dispose() - CurrentClient = New HttpClient(Handler) - Return CurrentClient - End If - If CurrentClient IsNot Nothing Then Return CurrentClient - CurrentClient = New HttpClient(ClientHandler) With {.Timeout = Timeout.InfiniteTimeSpan} - Return CurrentClient - End SyncLock - End Function - Public Sub HttpClientReload() - RunInNewThread( - Sub() - While True - Thread.Sleep(TimeSpan.FromHours(6)) - If PreviousClient IsNot Nothing Then PreviousClient.Dispose() - PreviousClient = CurrentClient - CurrentClient = GetHttpClient() - End While - End Sub - ) - End Sub - - End Class - - ''' - ''' 测试 Ping。失败则返回 -1。 - ''' - ''' - Public Function Ping(Ip As String, Optional Timeout As Integer = 10000, Optional MakeLog As Boolean = True) As Integer - Dim PingResult As NetworkInformation.PingReply - Try - PingResult = (New NetworkInformation.Ping).Send(Ip) + Return Result + Catch ex As FormatException + Throw + Catch ex As ThreadInterruptedException + Throw Catch ex As Exception - If MakeLog Then Log("[Net] Ping " & Ip & " 失败：" & ex.Message) - Return -1 - End Try - If PingResult.Status = NetworkInformation.IPStatus.Success Then - If MakeLog Then Log("[Net] Ping " & Ip & " 结束：" & PingResult.RoundtripTime & "ms") - Return PingResult.RoundtripTime - Else - If MakeLog Then Log("[Net] Ping " & Ip & " 失败") - Return -1 - End If - End Function - - ''' - ''' 以 WebClient 获取网页源代码。会进行至多 45 秒 3 次的尝试，允许最长 30s 的超时。 - ''' - ''' 网页的 Url。 - ''' 网页的编码，通常为 UTF-8。 - Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Optional Accept As String = "application/json, text/javascript, */*; q=0.01", Optional UseBrowserUserAgent As Boolean = False) As String - Dim RetryCount As Integer = 0 - Dim RetryException As Exception = Nothing - Dim StartTime As Long = GetTimeTick() - Try -Retry: - Select Case RetryCount - Case 0 '正常尝试 - Return NetGetCodeByClient(Url, Encoding, 10000, Accept, UseBrowserUserAgent) - Case 1 '慢速重试 - Thread.Sleep(500) - Return NetGetCodeByClient(Url, Encoding, 30000, Accept, UseBrowserUserAgent) - Case Else '快速重试 - If GetTimeTick() - StartTime > 5500 Then - '若前两次加载耗费 5 秒以上，才进行重试 - Thread.Sleep(500) - Return NetGetCodeByClient(Url, Encoding, 4000, Accept, UseBrowserUserAgent) - Else - Throw RetryException - End If - End Select - Catch ex As Exception - Select Case RetryCount - Case 0 - RetryException = ex - RetryCount += 1 - GoTo Retry - Case 1 - RetryCount += 1 - GoTo Retry - Case Else - Throw - End Select + If MakeLog Then Log(ex, "网络请求失败", LogLevel.Developer) + Throw End Try End Function - Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Timeout As Integer, Accept As String, Optional UseBrowserUserAgent As Boolean = False) As String - Log("[Net] 获取客户端网络结果：" & Url & "，最大超时 " & Timeout) - Try - Dim Headers As New Dictionary(Of String, String) From { - {"Accept", Accept} - } - Using Req As HttpRequestMessage = Request.GetRequestMessage(Url, Headers:=Headers, RequireHeaderSign:=True, RequireCdnSign:=True, UseBrowserUA:=UseBrowserUserAgent) - Req.Headers.AcceptLanguage.Add(New StringWithQualityHeaderValue("en-US,en;q=0.5")) - Req.Headers.TryAddWithoutValidation("X-Request-With","XMLHttpRequest") - Dim Resp As String = Request.SendRequest(Req, Encode:=Encoding, Timeout:=Timeout) - - Return Resp - End Using - Catch ex As TaskCanceledException - Throw New TaskCanceledException("连接服务器超时（" & Url & "）", ex) - Catch ex As Exception - Throw New WebException("获取结果失败，" & ex.Message & "（" & Url & "）", ex) - End Try - End Function - ''' - ''' 以 WebRequest 获取网页源代码或 Json。会进行至多 45 秒 3 次的尝试，允许最长 30s 的超时。 + ''' 发送网络请求并获取返回内容。 + ''' 会进行至多 45 秒 3 次的尝试，允许最长 30s 的超时。 ''' - ''' 网页的 Url。 - ''' 网页的编码，通常为 UTF-8。 ''' 如果第一次尝试失败，换用的备用 URL。 - Public Function NetGetCodeByRequestRetry(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", - Optional IsJson As Boolean = False, Optional BackupUrl As String = Nothing, Optional UseBrowserUserAgent As Boolean = False) + Public Function NetRequestByClientRetry(Url As String, Optional Method As HttpMethod = Nothing, Optional BackupUrl As String = Nothing, + Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", + Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False) As String Dim RetryCount As Integer = 0 Dim RetryException As Exception = Nothing - Dim StartTime As Long = GetTimeTick() + Dim StartTime As Long = GetTimeMs() Try Retry: Select Case RetryCount Case 0 '正常尝试 - Return NetGetCodeByRequestOnce(Url, Encode, 10000, IsJson, Accept, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 10000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Case 1 '慢速重试 Thread.Sleep(500) - Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 30000, IsJson, Accept, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 30000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Case Else '快速重试 - If GetTimeTick() - StartTime > 5500 Then + If GetTimeMs() - StartTime > 5500 Then '若前两次加载耗费 5 秒以上，才进行重试 Thread.Sleep(500) - Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 4000, IsJson, Accept, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 4000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Else Throw RetryException End If @@ -319,6 +72,11 @@ Retry: Catch ex As ThreadInterruptedException Throw Catch ex As Exception + If TypeOf ex Is ResponsedWebException Then + If CType(ex, ResponsedWebException).StatusCode = HttpStatusCode.Forbidden Then Throw + If CType(ex, ResponsedWebException).StatusCode = 429 Then Thread.Sleep(10000) 'Too Many Requests + End If + '重试 Select Case RetryCount Case 0 RetryException = ex @@ -333,20 +91,22 @@ Retry: End Try End Function ''' - ''' 以 WebRequest 获取网页源代码或 Json。会逐渐生成 4 个尝试线程，并在 60s 后超时。 + ''' 生成数个线程，同时发送网络请求并获取返回内容。 + ''' 每个线程开始之前会略有延迟。 ''' - ''' 网页的 Url。 - ''' 网页的编码，通常为 UTF-8。 - Public Function NetGetCodeByRequestMultiple(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False) + Public Function NetRequestByClientMultiple(Url As String, Optional Method As HttpMethod = Nothing, Optional ThreadCount As Integer = 3, + Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", + Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, Optional Timeout As Integer = 25000, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False) As String Dim Threads As New List(Of Thread) Dim RequestResult = Nothing Dim RequestEx As Exception = Nothing Dim FailCount As Integer = 0 - For i = 1 To 4 + For i = 1 To ThreadCount Dim th As New Thread( Sub() Try - RequestResult = NetGetCodeByRequestOnce(Url, Encode, 30000, IsJson, Accept) + RequestResult = NetRequestByClient(Url, Method, Content, ContentType, Accept, Timeout, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Catch ex As Exception FailCount += 1 RequestEx = ex @@ -367,7 +127,7 @@ RequestFinished: Catch End Try Return RequestResult - ElseIf FailCount = 4 Then + ElseIf FailCount = ThreadCount Then Try For Each th In Threads If th.IsAlive Then th.Interrupt() @@ -378,259 +138,285 @@ RequestFinished: End If Thread.Sleep(20) Loop - Throw New Exception("未知错误") - End Function - Public Function NetGetCodeByRequestOnce(Url As String, Optional Encode As Encoding = Nothing, Optional Timeout As Integer = 30000, Optional IsJson As Boolean = False, Optional Accept As String = "", Optional UseBrowserUserAgent As Boolean = False) - If RunInUi() AndAlso Not Url.Contains("//127.") Then Throw New Exception("在 UI 线程执行了网络请求") - Log($"[Net] 获取网络结果：{Url}，超时 {Timeout}ms{If(IsJson, "，要求 json", "")}") - Try - Dim Headers As New Dictionary(Of String, String) From { - {"Accept", If(Accept = "", "*/*", Accept)} - } - Using Req As HttpRequestMessage = Request.GetRequestMessage(Url, Headers:=Headers, UseBrowserUA:=UseBrowserUserAgent, RequireHeaderSign:=True, RequireCdnSign:=True) - Dim Resp As String = Request.SendRequest(Req, Encode:=Encode, Timeout:=Timeout) - Return If(IsJson, GetJson(Resp), Resp) - End Using - - Catch ex As ThreadInterruptedException - Throw - - Catch ex As TaskCanceledException - Throw New TimeoutException($"获取结果失败（{ex.Message}，{Url}）", ex) - Catch ex As HttpRequestException - Throw New WebException($"获取结果失败（{ex.Message}，{Url}）", ex) - End Try + Return Nothing End Function ''' - ''' 以多线程下载网页文件的方式获取网页源代码。 + ''' 以多线程下载网页文件的方式获取内容。 + ''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。 ''' - ''' 网页的 Url。 - Public Function NetGetCodeByLoader(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String - Dim Temp As String = RequestTaskTempFolder() & "download.txt" - Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile({Url}, Temp, New FileChecker With {.IsJson = IsJson}, UseBrowserUserAgent)}) - Try - NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时（" & Url & "）") - NetGetCodeByLoader = ReadFile(Temp) - File.Delete(Temp) - Finally - NewTask.Abort() - End Try + Public Function NetRequestByLoader(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional SimulateBrowserHeaders As Boolean = False) As String + Return NetRequestByLoader({Url}, Timeout, IsJson, SimulateBrowserHeaders) End Function ''' - ''' 以多线程下载网页文件的方式获取网页源代码。 + ''' 以多线程下载网页文件的方式获取内容。 + ''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。 ''' - ''' 网页的 Url 列表。 - Public Function NetGetCodeByLoader(Urls As IEnumerable(Of String), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String + Public Function NetRequestByLoader(Urls As IEnumerable(Of String), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional SimulateBrowserHeaders As Boolean = False) As String Dim Temp As String = RequestTaskTempFolder() & "download.txt" - Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, UseBrowserUserAgent)}) + Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, SimulateBrowserHeaders)}) Try NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时（第一下载源：" & Urls.First & "）") - NetGetCodeByLoader = ReadFile(Temp) + NetRequestByLoader = ReadFile(Temp) File.Delete(Temp) Finally - NewTask.Abort() + NewTask.Interrupt() End Try End Function +#End Region + +#Region "文件下载" + ''' - ''' 使用 WebClient 从网络中下载文件。这不能下载 CDN 中的文件。 + ''' 通过网络请求直接下载小文件，若文件已存在将被覆盖。 + ''' 不建议用于下载大文件。 ''' - ''' 网络 Url。 - ''' 下载的本地地址。 - Public Sub NetDownloadByClient(Url As String, LocalFile As String, Optional UseBrowserUserAgent As Boolean = False) - Log("[Net] 直接下载文件：" & Url) - '初始化 + Public Sub NetDownloadByClient(Url As String, LocalPath As String, Optional SimulateBrowserHeaders As Boolean = False) + Log($"[Net] 通过网络请求直接下载小文件：{Url} → {LocalPath}") + '初始化文件路径 Try - '建立目录 - Directory.CreateDirectory(GetPathFromFullPath(LocalFile)) - '尝试删除原文件 - File.Delete(LocalFile) + Directory.CreateDirectory(GetPathFromFullPath(LocalPath)) + File.Delete(LocalPath) Catch ex As Exception - Throw New WebException($"预处理下载文件路径失败（{LocalFile}）", ex) + Throw New Exception($"预处理下载文件路径失败（{LocalPath}）", ex) End Try '下载 - Using Client As New WebClient - Try - 'SecretHeadersSign(Url, Client, UseBrowserUserAgent) - Client.DownloadFile(Url, LocalFile) - Catch ex As Exception - File.Delete(LocalFile) - Throw New WebException($"直接下载文件失败（{Url}）", ex) - End Try - End Using - End Sub - - ''' - ''' 简单的多线程下载文件。可以下载 CDN 中的文件。 - ''' - ''' 文件的 Url。 - ''' 下载的本地地址。 - Public Sub NetDownloadByLoader(Url As String, LocalFile As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) - Dim NewTask As New LoaderDownload("文件下载 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile({Url}, LocalFile, Check, UseBrowserUserAgent)}) + Dim RetryCount As Integer = 0 +Retry: Try - NewTask.WaitForExit(LoaderToSyncProgress:=LoaderToSyncProgress) + File.WriteAllBytes(LocalPath, SendRequest(Url, HttpMethod.Get, SimulateBrowserHeaders:=SimulateBrowserHeaders)) + Catch ex As ThreadInterruptedException + File.Delete(LocalPath) + Throw Catch ex As Exception - Throw New WebException($"多线程直接下载文件失败（{Url}）", ex) - Finally - NewTask.Abort() + File.Delete(LocalPath) + If RetryCount < 2 Then + RetryCount += 1 + GoTo Retry + End If + Throw New WebException($"通过网络请求直接下载小文件失败（{LocalPath}）", ex) End Try End Sub ''' - ''' 简单的多线程下载文件。可以下载 CDN 中的文件。 + ''' 通过多线程下载引擎下载文件。 + ''' + Public Sub NetDownloadByLoader(Url As String, LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) + NetDownloadByLoader({Url}, LocalPath, LoaderToSyncProgress, Check, SimulateBrowserHeaders) + End Sub + ''' + ''' 通过多线程下载引擎下载文件。 ''' ''' 文件的 Url 列表。 - ''' 下载的本地地址。 - Public Sub NetDownloadByLoader(Urls As IEnumerable(Of String), LocalFile As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) - Dim NewTask As New LoaderDownload("文件下载 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, LocalFile, Check, UseBrowserUserAgent)}) + ''' 下载的本地地址。 + Public Sub NetDownloadByLoader(Urls As IEnumerable(Of String), LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) + Dim NewTask As New LoaderDownload($"文件下载 {GetUuid()}#", New List(Of NetFile) From {New NetFile(Urls, LocalPath, Check, SimulateBrowserHeaders)}) Try NewTask.WaitForExit(LoaderToSyncProgress:=LoaderToSyncProgress) Catch ex As Exception Throw New WebException($"多线程直接下载文件失败（第一下载源：" & Urls.First() & "）", ex) Finally - NewTask.Abort() + NewTask.Interrupt() End Try End Sub - ''' - ''' 发送一个网络请求并获取返回内容，会重试三次并在最长 45s 后超时。 - ''' - ''' 请求的服务器地址。 - ''' 请求方式（POST 或 GET）。 - ''' 请求的内容。 - ''' 请求的套接字类型。 - ''' 当返回 40x 时不重试。 - Public Function NetRequestRetry(Url As String, Method As String, Data As Object, ContentType As String, Optional DontRetryOnRefused As Boolean = True, Optional Headers As Dictionary(Of String, String) = Nothing, Optional RequireReturnRespObj As Boolean = False) As String - Dim RetryCount As Integer = 0 - Dim RetryException As Exception = Nothing - Dim StartTime As Long = GetTimeTick() - Try -Retry: - Select Case RetryCount - Case 0 '正常尝试 - Return NetRequestOnce(Url, Method, Data, ContentType, 15000, Headers, RequiredReturnRespObj:=RequireReturnRespObj) - Case 1 '慢速重试 - Thread.Sleep(500) - Return NetRequestOnce(Url, Method, Data, ContentType, 25000, Headers, RequiredReturnRespObj:=RequireReturnRespObj) - Case Else '快速重试 - If GetTimeTick() - StartTime > 5500 Then - '若前两次加载耗费 5 秒以上，才进行重试 - Thread.Sleep(500) - Return NetRequestOnce(Url, Method, Data, ContentType, 4000, Headers,RequiredReturnRespObj:=RequireReturnRespObj) - Else - Throw RetryException - End If - End Select - Catch ex As ThreadInterruptedException - Throw - Catch ex As Exception - 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 & "）") - RetryException = ex - RetryCount += 1 - GoTo Retry - Case 1 - If ModeDebug Then Log(ex, "[Net] 网络请求第二次失败（" & Url & "）") - RetryCount += 1 - GoTo Retry - Case Else - Throw - End Select - End Try - End Function - ''' - ''' 同时发送多个网络请求并要求返回内容。 - ''' - Public Function NetRequestMultiple(Url As String, Method As String, Data As Object, ContentType As String, Optional RequestCount As Integer = 4, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True) - Dim Threads As New List(Of Thread) - Dim RequestResult = Nothing - Dim RequestEx As Exception = Nothing - Dim FailCount As Integer = 0 - For i = 1 To RequestCount - Dim th As New Thread( - Sub() - Try - RequestResult = NetRequestOnce(Url, Method, Data, ContentType, 30000, Headers, MakeLog) - Catch ex As Exception - FailCount += 1 - RequestEx = ex - End Try - End Sub) - th.Start() - Threads.Add(th) - Thread.Sleep(i * 250) - If RequestResult IsNot Nothing Then GoTo RequestFinished - Next - Do While True - If RequestResult IsNot Nothing Then -RequestFinished: - For Each th In Threads - If th.IsAlive Then th.Interrupt() - Next - Return RequestResult - ElseIf FailCount = RequestCount Then - For Each th In Threads - If th.IsAlive Then th.Interrupt() - Next - Throw RequestEx - End If - Thread.Sleep(20) - Loop - Throw New Exception("未知错误") - End Function - ''' - ''' 发送一次网络请求并获取返回内容。 - ''' - Public Function NetRequestOnce(Url As String, Method As String, Data As Object, ContentType As String, Optional Timeout As Integer = 25000, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True, Optional UseBrowserUserAgent As Boolean = False, Optional RequiredReturnRespObj As Boolean = False) As Object +#End Region + +#Region "基础请求引擎" + + '基础请求函数 + Private Function SendRequest(Url As String, Method As HttpMethod, + Optional Content As Object = Nothing, Optional Headers As Dictionary(Of String, String) = Nothing, + Optional SimulateBrowserHeaders As Boolean = False, Optional Timeout As Integer = 25000, Optional Encoding As Encoding = Nothing) As Byte() If RunInUi() AndAlso Not Url.Contains("//127.") Then Throw New Exception("在 UI 线程执行了网络请求") - If MakeLog Then Log("[Net] 发起网络请求（" & Method & "，" & Url & "），最大超时 " & Timeout) + Dim Request As HttpRequestMessage = Nothing, CancelToken As CancellationTokenSource = Nothing, + Response As HttpResponseMessage = Nothing, HostIp As String = Nothing Try - Dim ReqHeaders As New Dictionary(Of String, String) - If ContentType IsNot Nothing AndAlso Data IsNot Nothing Then - ' 可能指定了 Content-Type 但是 Headers 是 Nothing - If Headers IsNot Nothing Then - If Not Headers.ContainsKey("Content-Type") Then Headers.Add("Content-Type", ContentType) - Else - If Not ReqHeaders.ContainsKey("Content-Type") Then ReqHeaders.Add("Content-Type", ContentType) + Url = SecretCdnSign(Url) + Request = New HttpRequestMessage(Method, Url) + '写入 Content + If Content IsNot Nothing AndAlso Request.Method <> HttpMethod.Get AndAlso Request.Method <> HttpMethod.Head Then + If TypeOf Content Is HttpContent Then + Request.Content = DirectCast(Content, HttpContent) + ElseIf TypeOf Content Is Byte() Then + Request.Content = New ByteArrayContent(DirectCast(Content, Byte())) + ElseIf Content IsNot Nothing Then + Request.Content = New ByteArrayContent(If(Encoding, Encoding.UTF8).GetBytes(Content.ToString())) End If End If - Dim ReqData As Byte() = If(TypeOf Data Is String, Encoding.UTF8.GetBytes(Data), Data) - - - Dim Req As HttpRequestMessage = Request.GetRequestMessage(Url, Method, If(Headers, ReqHeaders), If(Data IsNot Nothing, ReqData, Nothing), UseBrowserUserAgent, True, True) - Return Request.SendRequest(Req, If(RequiredReturnRespObj, False, True), Timeout:=Timeout, RequireReturnRespObj:=RequiredReturnRespObj) + '写入 Headers + For Each Header In If(Headers, New Dictionary(Of String, String)) + If Header.Key.Lower = "content-type" Then + Request.Content?.Headers.TryAddWithoutValidation(Header.Key, Header.Value) + Else + Request.Headers.TryAddWithoutValidation(Header.Key, Header.Value) + End If + Next + SecretHeadersSign(Url, Request, SimulateBrowserHeaders) + 'DNS 解析 + CancelToken = New CancellationTokenSource(Timeout) + HostIp = DNSLookup(Request, CancelToken.Token) + If HostIp IsNot Nothing AndAlso Not IPReliability.ContainsKey(HostIp) Then + IPReliability(HostIp) = -0.01 '预先降低一点，这样快速的重复请求会使用不同的 IP 以提高成功率 + End If + '发送请求 + SyncLock RequestClientLock + If RequestClient Is Nothing Then '延迟初始化，以避免在程序启动前加载 CacheCow 导致 DLL 加载失败 + RequestClient = CacheCow.Client.ClientExtensions.CreateClient(New CacheCow.Client.FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With { + .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip, + .UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies + }) + End If + End SyncLock + Response = RequestClient.SendAsync(Request, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + Dim ResponseBytes As Byte() + Using ResponseStream = Response.Content.ReadAsStreamAsync().GetResultWithTimeout(CancelToken, Timeout) + Using Stream As New MemoryStream + ResponseStream.CopyToAsync(Stream, 81920, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + ResponseBytes = Stream.ToArray() + End Using + End Using + '输出 + If Response.IsSuccessStatusCode Then + RecordIPReliability(HostIp, 0.5) + Return ResponseBytes + Else + RecordIPReliability(HostIp, -0.7) + Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes) + Throw New ResponsedWebException( + $"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}，{HostIp}" & + If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), Response.StatusCode, ResponseMessage) + End If Catch ex As ThreadInterruptedException - Throw - Catch ex As TaskCanceledException - Return New WebException($"连接服务器超时，请检查你的网络环境是否良好（{ex.Message}，{Url}）", ex) - Catch ex As HttpRequestException - If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer) - Throw New WebException(ex.Message, ex) - Catch ex As Exception - ex = New WebException("网络请求失败（" & Url & "）", ex) - If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer) - Throw ex + Throw + Catch ex As ResponsedWebException + Throw + Catch ex As FileNotFoundException + '由于 CacheCow 读取缓存失败，然后系统调用不存在的 System.Net.Http.Formatting.resources 抛出（#8150） + Throw New Exception($"网络请求时读取缓存失败", ex) + Catch ex As Exception + RecordIPReliability(HostIp, -1) + If TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException Then 'CancellationToken 超时 + Throw New WebException($"连接服务器超时，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout) + ElseIf ex.IsNetworkRelated Then + Throw New WebException($"网络请求失败，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout) + Else + Throw New Exception($"网络请求出现意外异常（{Method}, {Url}，{HostIp}）", ex) + End If + Finally + Request?.Dispose() + CancelToken?.Dispose() + Response?.Dispose() End Try End Function + Private RequestClient As HttpClient = Nothing + Private RequestClientLock As New Object + + ''' + ''' 进行 DNS 解析。它仅在选择的 IP 与系统默认的不一致时才对 URL 中的 Host 进行替换。 + ''' 返回请求时应使用的 IP。若解析失败，则返回 Nothing。 + ''' + Private Function DNSLookup(Request As HttpRequestMessage, CancelToken As CancellationToken) As String + Dim Host = Request.RequestUri.Host + '不对部分有严格 SNI 限制的域名进行 DNS 解析（#8295） + If {"mojang.com", "minecraft.net", "minecraftservices.com"}.Any(Function(h) Host.ContainsF(h, True)) Then Return Nothing + '若一分钟内已失败过，则不再重复尝试解析，以减少断网时的 Exception 数量 + SyncLock DNSFailureRecord.SyncRoot + If DNSFailureRecord.ContainsKey(Host) Then + If Date.Now - DNSFailureRecord(Host) < New TimeSpan(0, 1, 0) Then + Return Nothing + Else + DNSFailureRecord.Remove(Host) + End If + End If + End SyncLock + '初步 DNS 解析 + Dim Candidates As IPAddress() + Try + Dim AsyncResult = Dns.BeginGetHostAddresses(Host, Nothing, Nothing) + If WaitHandle.WaitAny(New WaitHandle() {AsyncResult.AsyncWaitHandle, CancelToken.WaitHandle}) Then Throw New TimeoutException("DNS 解析超时") + Candidates = Dns.EndGetHostAddresses(AsyncResult).Distinct.ToArray + Catch ex As Exception + Log(ex, $"DNS 解析失败（{Host}）") + DNSFailureRecord(Host) = Date.Now + Return Nothing + End Try + If Not Candidates.Any Then + Log($"[Net] DNS 解析无结果（{Host}）") + Return Nothing + End If + '若同时存在 IPv4 和 IPv6 地址，仅选择其中一类（因为 GFW 可能只屏蔽了 IPv4 或 IPv6） + Dim Reliabilities = Candidates.ToDictionary(Function(i) i, Function(i) IPReliability.GetOrDefault(i.ToString, 0)) + Dim IPv4Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetwork).ToArray + Dim IPv6Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetworkV6).ToArray + If IPv4Targets.Any AndAlso IPv6Targets.Any Then + Dim IPv4Reliability = IPv4Targets.Max(Function(i) Reliabilities(i)) + Dim IPv6Reliability = IPv6Targets.Max(Function(i) Reliabilities(i)) + If Host = "api.modrinth.com" Then IPv6Reliability -= 0.1 '让 Modrinth 优先使用 IPv4 地址（#6887） + If ModeDebug Then Log($"[Net] DNS IPv4/IPv6 选择（{Host}），IPv4 {IPv4Reliability:0.000}，IPv6 {IPv6Reliability:0.000}") + Candidates = If(IPv4Reliability >= IPv6Reliability, IPv4Targets, IPv6Targets) + End If + '选择可靠度最高的 IP + Dim Target As IPAddress = Candidates.MaxBy(Function(i) Reliabilities(i)) + Request.Headers.Host = Request.RequestUri.Authority + Request.RequestUri = (New UriBuilder(Request.RequestUri) With {.Host = If(Target.AddressFamily = AddressFamily.InterNetworkV6, $"[{Target}]", Target.ToString)}).Uri + Return Target.ToString + End Function + Private DNSFailureRecord As New SafeDictionary(Of String, Date) + ''' + ''' 记录每个 IP 地址的请求可靠度。 + ''' 通常取值 -1 ~ +0.5，越高越好。未尝试过的 IP 应视为 0。 + ''' + Private IPReliability As New SafeDictionary(Of String, Double) + ''' + ''' 根据请求结果，记录 IP 地址的可靠度。 + ''' + Private Sub RecordIPReliability(IP As String, Result As Double) + If IP Is Nothing Then Return + SyncLock IPReliability.SyncRoot + If Not IPReliability.ContainsKey(IP) Then IPReliability(IP) = 0 + IPReliability(IP) = (IPReliability(IP) + Result) / 2 + End SyncLock + End Sub + + ''' + ''' 当 HTTP 状态码不指示成功时引发的异常。 + ''' 附带额外属性，可用于获取远程服务器给予的回复以及 HTTP 状态码。 + ''' Public Class ResponsedWebException Inherits WebException ''' + ''' HTTP 状态码。 + ''' + Public StatusCode As HttpStatusCode + ''' ''' 远程服务器给予的回复。 ''' Public Overloads Property Response As String - Public Sub New(Message As String, Response As String, InnerException As Exception) - MyBase.New(Message, InnerException) + Public Sub New(Message As String, StatusCode As HttpStatusCode, Response As String) + MyBase.New(Message) + Me.StatusCode = StatusCode Me.Response = Response End Sub End Class +#End Region + +#Region "多线程下载引擎" + + Private ThreadClient As New HttpClient(New HttpClientHandler With { + .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip + }) + ''' ''' 最大线程数。 ''' - Public NetTaskThreadLimit As Integer + Public ReadOnly Property NetTaskThreadLimit As Integer + Get + Return Settings.Get("ToolDownloadThread") + 1 + End Get + End Property ''' ''' 速度下限。 ''' @@ -638,18 +424,35 @@ RequestFinished: ''' ''' 速度上限。若无限制则为 -1。 ''' - Public NetTaskSpeedLimitHigh As Long = -1 + Public ReadOnly Property NetTaskSpeedLimitHigh As Long + Get + If _NetTaskSpeedLimitHigh Is Nothing Then + Dim Setting As Integer = Settings.Get("ToolDownloadSpeed") + If Setting <= 14 Then + _NetTaskSpeedLimitHigh = (Setting + 1) * 0.1 * 1024 * 1024L + ElseIf Setting <= 31 Then + _NetTaskSpeedLimitHigh = (Setting - 11) * 0.5 * 1024 * 1024L + ElseIf Setting <= 41 Then + _NetTaskSpeedLimitHigh = (Setting - 21) * 1024 * 1024L + Else + _NetTaskSpeedLimitHigh = -1 + End If + End If + Return _NetTaskSpeedLimitHigh.Value + End Get + End Property + Private _NetTaskSpeedLimitHigh As Long? = Nothing + Public Sub UpdateNetTaskSpeedLimitHigh(Value As Integer) + _NetTaskSpeedLimitHigh = Nothing + End Sub ''' ''' 基于限速，当前可以下载的剩余量。 ''' Public NetTaskSpeedLimitLeft As Long = -1 - Private ReadOnly NetTaskSpeedLimitLeftLock As New Object - Private NetTaskSpeedLimitLeftLast As Long ''' ''' 正在运行中的线程数。 ''' Public NetTaskThreadCount As Integer = 0 - Private ReadOnly NetTaskThreadCountLock As New Object ''' ''' 下载源。 @@ -659,7 +462,10 @@ RequestFinished: Public Url As String Public FailCount As Integer Public Ex As Exception - Public Thread As NetThread + ''' + ''' 若该下载源正在进行强制单线程下载，标记这个唯一的线程。 + ''' + Public SingleThread As NetThread Public IsFailed As Boolean Public Overrides Function ToString() As String Return Url @@ -672,39 +478,35 @@ RequestFinished: ''' ''' 尚未进行已存在检查。 ''' - WaitForCheck = -1 + WaitingToCheck = -1 ''' ''' 尚未开始。 ''' - WaitForDownload = 0 + WaitingToDownload = 0 ''' ''' 正在连接，尚未获取文件大小。 ''' - Connect = 1 + Connecting = 1 ''' - ''' 已获取文件大小，尚未有有效下载。 + ''' 已连接，正在尝试接收首个下载数据包。 ''' - [Get] = 2 + Reading = 2 ''' ''' 正在下载。 ''' - Download = 3 + Downloading = 3 ''' ''' 正在合并文件。 ''' - Merge = 4 - ''' - ''' 不进行下载，因为已发现现存的文件。 - ''' - WaitForCopy = 5 + Merging = 4 ''' ''' 已完成。 ''' - Finish = 6 + Finished = 5 ''' ''' 已失败或中断。 ''' - [Error] = 7 + Interrupted = 6 End Enum ''' ''' 预下载检查行为。 @@ -728,7 +530,7 @@ RequestFinished: ''' 下载线程。 ''' Public Class NetThread - Implements IEnumerable(Of NetThread) + Implements IEnumerable(Of NetThread), IEquatable(Of NetThread) ''' ''' 对应的下载任务。 @@ -787,7 +589,7 @@ RequestFinished: SyncLock Task.LockChain If NextThread Is Nothing Then If Task.IsUnknownSize Then - Return 5 * 1024 * 1024 * 1024L '5G + Return 1000 * 1000 * 1000 * 1000L '约 1T Else Return Task.FileSize - 1 End If @@ -813,7 +615,7 @@ RequestFinished: ''' ''' 上次记速时的时间。 ''' - Private SpeedLastTime As Long = GetTimeTick() + Private SpeedLastTime As Long = GetTimeMs() ''' ''' 上次记速时的已下载大小。 ''' @@ -823,8 +625,8 @@ RequestFinished: ''' Public ReadOnly Property Speed As Long Get - If GetTimeTick() - SpeedLastTime > 200 Then - Dim DeltaTime As Long = GetTimeTick() - SpeedLastTime + If GetTimeMs() - SpeedLastTime > 200 Then + Dim DeltaTime As Long = GetTimeMs() - SpeedLastTime _Speed = (DownloadDone - SpeedLastDone) / (DeltaTime / 1000) SpeedLastDone = DownloadDone SpeedLastTime += DeltaTime @@ -837,7 +639,7 @@ RequestFinished: ''' ''' 线程初始化时的时间。 ''' - Public InitTime As Long = GetTimeTick() + Public InitTime As Long = GetTimeMs() ''' ''' 上次接受到有效数据的时间，-1 表示尚未有有效数据。 ''' @@ -846,13 +648,13 @@ RequestFinished: ''' ''' 当前线程的状态。 ''' - Public State As NetState = NetState.WaitForDownload + Public State As NetState = NetState.WaitingToDownload ''' ''' 是否已经结束。 ''' Public ReadOnly Property IsEnded As Boolean Get - Return State = NetState.Finish OrElse State = NetState.Error + Return State = NetState.Finished OrElse State = NetState.Interrupted End Get End Property @@ -861,6 +663,19 @@ RequestFinished: ''' Public Source As NetSource + '允许进行 UUID 比较 + Public Overloads Function Equals(other As NetThread) As Boolean Implements IEquatable(Of NetThread).Equals + Return other IsNot Nothing AndAlso Uuid = other.Uuid + End Function + Public Overrides Function Equals(obj As Object) As Boolean + Return Equals(TryCast(obj, NetThread)) + End Function + Public Shared Operator =(left As NetThread, right As NetThread) As Boolean + Return EqualityComparer(Of NetThread).Default.Equals(left, right) + End Operator + Public Shared Operator <>(left As NetThread, right As NetThread) As Boolean + Return Not left = right + End Operator End Class ''' ''' 下载单个文件。 @@ -886,12 +701,17 @@ RequestFinished: ''' Public SourcesOnce As New SafeList(Of NetSource) ''' + ''' 仅当合并失败或首次下载失败时，会将所有下载源重新标记为不允许断点续传的下载源，逐个重新尝试下载。 + ''' 这一策略可以兼容多个下载源中的一部分返回错误的文件的情况，以及部分在多线程下载时会抽风的源。 + ''' + Private Retried As Boolean = False + ''' ''' 获取从某个源开始，第一个可用的源。 ''' Private Function GetSource(Optional Id As Integer = 0) As NetSource If Id >= Sources.Count OrElse Id < 0 Then Id = 0 SyncLock LockSource - If Not IsSourceFailed(False) Then + If HasAvailableSource(False) Then '存在多线程可用源 Dim CurrentSource As NetSource = Sources(Id) While CurrentSource.IsFailed @@ -902,7 +722,7 @@ RequestFinished: Return CurrentSource ElseIf SourcesOnce.Any Then '仅存在单线程可用源 - Return SourcesOnce(0) + Return SourcesOnce.First Else '没有可用源 Return Nothing @@ -910,16 +730,14 @@ RequestFinished: End SyncLock End Function ''' - ''' 是否已经没有可用源了。 + ''' 是否存在可用源。 ''' - Public Function IsSourceFailed(Optional AllowOnceSource As Boolean = True) As Boolean - If AllowOnceSource AndAlso SourcesOnce.Any Then Return False + Public Function HasAvailableSource(Optional AllowOnceSource As Boolean = True) As Boolean SyncLock LockSource - For Each Source As NetSource In Sources - If Not Source.IsFailed Then Return False - Next + If Sources.Any(Function(s) Not s.IsFailed) Then Return True '存在多线程可用源 + If AllowOnceSource AndAlso SourcesOnce.Any Then Return True '存在单线程可用源 End SyncLock - Return True + Return False End Function ''' @@ -934,7 +752,7 @@ RequestFinished: ''' ''' 当前的下载状态。 ''' - Public State As NetState = NetState.WaitForCheck + Public State As NetState = NetState.WaitingToCheck ''' ''' 导致下载失败的原因。 ''' @@ -959,33 +777,31 @@ RequestFinished: ''' Public ReadOnly Property IsNoSplit As Boolean Get - Return IsUnknownSize OrElse FileSize < FilePieceLimit + Return IsUnknownSize OrElse FileSize < 1024 * 1024 '小于 1MB 的文件不分割 End Get - End Property ''' - ''' 为不需要分割的小文件进行临时存储。 + ''' 为不需要分割的小文件在内存中提供临时存储。 ''' - Private SmailFileCache As Queue(Of Byte) + Private Cache As MemoryStream ''' ''' 文件的已下载大小。 ''' Public DownloadDone As Long = 0 - Private ReadOnly LockDone As New Object ''' ''' 文件的校验规则。 ''' Public Check As FileChecker ''' - ''' 下载时是否添加浏览器 UA。 + ''' 是否模拟浏览器的 UserAgent 和 Referer。 ''' - Public UseBrowserUserAgent As Boolean + Public SimulateBrowserHeaders As Boolean ''' ''' 上次记速时的时间。 ''' - Private SpeedLastTime As Long = GetTimeTick() + Private SpeedLastTime As Long = GetTimeMs() ''' ''' 上次记速时的已下载大小。 ''' @@ -995,8 +811,8 @@ RequestFinished: ''' Public ReadOnly Property Speed As Long Get - If GetTimeTick() - SpeedLastTime > 200 Then - Dim DeltaTime As Long = GetTimeTick() - SpeedLastTime + If GetTimeMs() - SpeedLastTime > 200 Then + Dim DeltaTime As Long = GetTimeMs() - SpeedLastTime _Speed = (DownloadDone - SpeedLastDone) / (DeltaTime / 1000) SpeedLastDone = DownloadDone SpeedLastTime += DeltaTime @@ -1016,24 +832,22 @@ RequestFinished: Public ReadOnly Property Progress As Double Get Select Case State - Case NetState.WaitForCheck + Case NetState.WaitingToCheck Return 0 - Case NetState.WaitForCopy - Return 0.2 - Case NetState.WaitForDownload + Case NetState.WaitingToDownload Return 0.01 - Case NetState.Connect + Case NetState.Connecting Return 0.02 - Case NetState.Get + Case NetState.Reading Return 0.04 - Case NetState.Download + Case NetState.Downloading '正在下载中，对应 5% ~ 98% Dim OriginalProgress As Double = If(IsUnknownSize, 0.5, DownloadDone / Math.Max(FileSize, 1)) OriginalProgress = 1 - (1 - OriginalProgress) ^ 0.9 Return OriginalProgress * 0.93 + 0.05 - Case NetState.Merge + Case NetState.Merging Return 0.99 - Case NetState.Finish, NetState.Error + Case NetState.Finished, NetState.Interrupted Return 1 Case Else Throw New ArgumentOutOfRangeException("文件状态未知：" & State) @@ -1054,14 +868,12 @@ RequestFinished: ''' Private ReadOnly Property ConnectAverage As Integer Get - SyncLock LockCount - Return If(ConnectCount = 0, -1, ConnectTime / ConnectCount) - End SyncLock + Dim CurrentConnectCount As Integer = ConnectCount '防止竞态条件 + Return If(CurrentConnectCount = 0, -1, ConnectTime / CurrentConnectCount) End Get End Property Private Const FilePieceLimit As Long = 256 * 1024 - Public ReadOnly LockCount As New Object Public ReadOnly LockState As New Object Public ReadOnly LockChain As New Object Public ReadOnly LockSource As New Object @@ -1078,7 +890,7 @@ RequestFinished: ''' 新建一个需要下载的文件。 ''' ''' 包含文件名的本地地址。 - Public Sub New(Urls As IEnumerable(Of String), LocalPath As String, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) + Public Sub New(Urls As IEnumerable(Of String), LocalPath As String, Optional Checker As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) Dim Sources As New List(Of NetSource) Dim Count As Integer = 0 Urls = Urls.Distinct.ToArray @@ -1088,8 +900,8 @@ RequestFinished: Next Me.Sources = Sources Me.LocalPath = LocalPath - Me.Check = Check - Me.UseBrowserUserAgent = UseBrowserUserAgent + Me.Check = Checker + Me.SimulateBrowserHeaders = SimulateBrowserHeaders Me.LocalName = GetFileNameFromPath(LocalPath) End Sub @@ -1100,35 +912,29 @@ RequestFinished: Public Function TryBeginThread() As NetThread Try - '条件检测 - If NetTaskThreadCount >= NetTaskThreadLimit OrElse IsSourceFailed() OrElse - (IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Error) Then Return Nothing - If State >= NetState.Merge OrElse State = NetState.WaitForCheck Then Return Nothing - SyncLock LockState - If State < NetState.Connect Then State = NetState.Connect - End SyncLock - '初始化参数 Dim StartPosition As Long, StartSource As NetSource = Nothing Dim Th As Thread, ThreadInfo As NetThread - SyncLock LockChain + '条件检测 + SyncLock LockSource + If NetTaskThreadCount >= NetTaskThreadLimit OrElse Not HasAvailableSource() OrElse + (IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Interrupted) Then Return Nothing + If State >= NetState.Merging OrElse State = NetState.WaitingToCheck Then Return Nothing + SyncLock LockState + If State < NetState.Connecting Then State = NetState.Connecting + End SyncLock + '初始化参数 '获取线程起点与下载源 '不分割 - If IsNoSplit Then GoTo Capture - '单线程 - If IsSourceFailed(False) Then - '确认没有其他线程正使用此点 - If SourcesOnce(0).Thread IsNot Nothing AndAlso SourcesOnce(0).Thread.State <> NetState.Error Then Return Nothing - '占用此点 -Capture: - SmailFileCache = Nothing - Threads = Nothing - NetManager.DownloadDone -= DownloadDone - SyncLock LockDone - DownloadDone = 0 - End SyncLock - SpeedLastDone = 0 - State = NetState.Get + If IsNoSplit Then GoTo StartSingleThreadDownload + '只剩下单线程可用点 + If Not HasAvailableSource(False) Then + If SourcesOnce.First.SingleThread IsNot Nothing AndAlso SourcesOnce.First.SingleThread.State <> NetState.Interrupted Then Return Nothing +StartSingleThreadDownload: + Reset() + State = NetState.Reading End If + End SyncLock + SyncLock LockChain '首个开始点 If Threads Is Nothing Then StartPosition = 0 @@ -1138,16 +944,18 @@ Capture: End If '寻找失败点 For Each Thread As NetThread In Threads - If Thread.State = NetState.Error AndAlso Thread.DownloadUndone > 0 Then + If Thread.State = NetState.Interrupted AndAlso Thread.DownloadUndone > 0 Then StartPosition = Thread.DownloadStart + Thread.DownloadDone StartSource = GetSource(Thread.Source.Id + 1) GoTo StartThread End If Next '是否禁用多线程，以及规定碎片大小 - Dim TargetUrl As String = GetSource().Url - If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("bmclapi") OrElse TargetUrl.Contains("github.com") OrElse - TargetUrl.Contains("optifine.net") OrElse TargetUrl.Contains("modrinth") Then Return Nothing + Dim Source As NetSource = GetSource() + If Source Is Nothing Then Return Nothing + Dim TargetUrl As String = Source.Url + If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("meloong.com") OrElse TargetUrl.Contains("bmclapi") OrElse TargetUrl.Contains("github.com") OrElse + TargetUrl.Contains("optifine.net") OrElse TargetUrl.Contains("momot.rs") Then Return Nothing '寻找最大碎片 'FUTURE: 下载引擎重做，计算下载源平均链接时间和线程下载速度，按最高时间节省来开启多线程 Dim FilePieceMax As NetThread = Threads @@ -1164,8 +972,8 @@ StartThread: '构建线程 Dim ThreadUuid As Integer = GetUuid() 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} + Th = New Thread(AddressOf Thread) With {.Name = $"下载 {Tasks(0).Uuid}/{Uuid}/{ThreadUuid}#", .Priority = ThreadPriority.BelowNormal} + ThreadInfo = New NetThread With {.Uuid = ThreadUuid, .DownloadStart = StartPosition, .Thread = Th, .Source = StartSource, .Task = Me, .State = NetState.WaitingToDownload} '链表处理 If ThreadInfo.IsFirstThread OrElse Threads Is Nothing Then Threads = ThreadInfo @@ -1180,336 +988,303 @@ StartThread: End SyncLock '开始线程 - SyncLock NetTaskThreadCountLock - NetTaskThreadCount += 1 - End SyncLock + Interlocked.Increment(NetTaskThreadCount) SyncLock LockSource - If IsSourceFailed(False) Then SourcesOnce(0).Thread = ThreadInfo + If Not HasAvailableSource(False) Then SourcesOnce.First.SingleThread = ThreadInfo End SyncLock Th.Start(ThreadInfo) Return ThreadInfo Catch ex As Exception - Log(ex, "尝试开始下载线程失败（" & If(LocalName, "Nothing") & "）", LogLevel.Hint) + Fail(New Exception($"尝试开始下载线程失败（{LocalName}）", ex)) Return Nothing End Try End Function ''' ''' 每个下载线程执行的代码。 ''' - Private Sub Thread(Info As NetThread) - If ModeDebug OrElse Info.DownloadStart = 0 Then Log("[Download] " & LocalName & " " & Info.Uuid & "#：开始，起始点 " & Info.DownloadStart & "，" & Info.Source.Url) - Dim HttpRequest As HttpRequestMessage - Dim ResultStream As Stream = Nothing - Dim HttpResponse As HttpResponseMessage + Private Sub Thread(Th As NetThread) + If ModeDebug OrElse Th.DownloadStart = 0 Then Log($"[Download] {LocalName}：开始，起始点 {Th.DownloadStart}，{Th.Source.Url}") + Dim ResultStream As Stream = Nothing, HttpRequest As HttpRequestMessage = Nothing, + Response As HttpResponseMessage = Nothing, ResponseStream As Stream = Nothing, + CancelToken As CancellationTokenSource = Nothing, HostIp As String = Nothing '部分下载源真的特别慢，并且只需要一个请求，例如 Ping 为 20s，如果增长太慢，就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟 '延迟过长会导致某些特别慢的链接迟迟不被掐死 - Dim Timeout As Integer = Math.Min(Math.Max(ConnectAverage, 6000) * (1 + Info.Source.FailCount), 30000) - Info.State = NetState.Connect + Dim Timeout As Integer = Math.Min(Math.Max(ConnectAverage, 15000) * (1 + Th.Source.FailCount), 30000) + Th.State = NetState.Connecting Try Dim HttpDataCount As Integer = 0 - If SourcesOnce.Contains(Info.Source) AndAlso Not Info.Equals(Info.Source.Thread) Then GoTo SourceBreak - HttpRequest = Request.GetRequestMessage(Info.Source.Url, - RequireHeaderSign:=True) - '可能出现结束减去起始等于或者小于 0 的情况，导致下载抛出 ArgumentOutOfRangeException - If Not Info.IsFirstThread Then HttpRequest.Headers.Range = New RangeHeaderValue(Info.DownloadStart, Nothing) - HttpResponse = Request.SendRequest(HttpRequest, False, Timeout:=Timeout, RequireReturnRespObj:=True) + If SourcesOnce.Contains(Th.Source) AndAlso Th <> Th.Source.SingleThread Then GoTo SourceBreak + HttpRequest = New HttpRequestMessage(HttpMethod.Get, Th.Source.Url) + SecretHeadersSign(Th.Source.Url, HttpRequest, SimulateBrowserHeaders) + CancelToken = New CancellationTokenSource(Timeout) + HostIp = DNSLookup(HttpRequest, CancelToken.Token) 'DNS 预解析 + If Not Th.IsFirstThread Then HttpRequest.Headers.Range = New Headers.RangeHeaderValue(Th.DownloadStart, Nothing) Dim ContentLength As Long = 0 - Using HttpResponse - If State = NetState.Error Then GoTo SourceBreak '快速中断 - If ModeDebug AndAlso HttpResponse.RequestMessage.RequestUri.ToString <> Info.Source.Url Then - Log($"[Download] {LocalName} {Info.Uuid}#：重定向至 {HttpResponse.RequestMessage.RequestUri.ToString}") - End If - ''从响应头获取文件名 - 'If Info.IsFirstThread Then - ' Dim FileName As String = GetFileNameFromResponse(HttpResponse) - ' If ModeDebug Then Log($"[Download] {LocalName} {Info.Uuid}#：远程文件名：{If(FileName, "未提供")}") - ' If FileName IsNot Nothing AndAlso LocalName = "待定" Then - ' LocalName = FileName - ' Log($"[Download] {LocalName} {Info.Uuid}#：从响应头获取到文件名") - ' End If - 'End If - '文件大小校验 - ContentLength = HttpResponse.Content.Headers.ContentLength.GetValueOrDefault(-1) - - If ContentLength = -1 Then - If FileSize > 1 Then - If Info.DownloadStart = 0 Then - Log($"[Download] {LocalName} {Info.Uuid}#：文件大小未知，但已从其他下载源获取，不作处理") - Else - Log($"[Download] {LocalName} {Info.Uuid}#：ContentLength 返回了 -1，无法确定是否支持分段下载，视作不支持") - GoTo NotSupportRange - End If + Response = ThreadClient.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + If Not Response.IsSuccessStatusCode Then Throw New Exception($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Th.Source.Url}") '状态码检查 + If State = NetState.Interrupted Then GoTo SourceBreak '快速中断 + If ModeDebug AndAlso Response.RequestMessage.RequestUri.ToString <> Th.Source.Url Then Log($"[Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri}") + '文件大小校验 + ContentLength = Response.Content.Headers.ContentLength.GetValueOrDefault(-1) + If ContentLength < 0 Then + If FileSize > 1 Then + If Th.DownloadStart = 0 Then + Log($"[Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理") Else - FileSize = -1 : IsUnknownSize = True - Log($"[Download] {LocalName} {Info.Uuid}#：文件大小未知") + Log($"[Download] {LocalName}：ContentLength 返回了 {ContentLength}，无法确定是否支持分段下载，视作不支持") + GoTo NotSupportRange End If - ElseIf ContentLength < 0 Then - Throw New Exception("获取片大小失败，结果为 " & ContentLength & "。") - ElseIf Info.IsFirstThread Then - If Check IsNot Nothing Then - If ContentLength < Check.MinSize AndAlso Check.MinSize > 0 Then - Throw New Exception($"文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。") - End If - If ContentLength <> Check.ActualSize AndAlso Check.ActualSize > 0 Then - Throw New Exception($"文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。") - End If - End If - FileSize = ContentLength : IsUnknownSize = False - Log($"[Download] {LocalName} {Info.Uuid}#：文件大小 {ContentLength}（{GetString(ContentLength)}）") - '若文件大小大于 50 M，进行剩余磁盘空间校验 - If ContentLength > 50 * 1024 * 1024 Then - For Each Drive As DriveInfo In DriveInfo.GetDrives - Dim DriveName As String = Drive.Name.First.ToString - Dim RequiredSpace = If(PathTemp.StartsWithF(DriveName), ContentLength * 1.1, 0) + - If(LocalPath.StartsWithF(DriveName), ContentLength + 5 * 1024 * 1024, 0) - If Drive.TotalFreeSpace < RequiredSpace Then - Throw New Exception(DriveName & " 盘空间不足，无法进行下载。" & vbCrLf & "需要至少 " & GetString(RequiredSpace) & " 空间，但当前仅剩余 " & GetString(Drive.TotalFreeSpace) & "。" & - If(PathTemp.StartsWithF(DriveName), vbCrLf & vbCrLf & "下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。", "")) - End If - Next - End If - ElseIf FileSize < 0 Then - Throw New Exception("非首线程运行时，尚未获取文件大小") - ElseIf Info.DownloadStart > 0 AndAlso ContentLength = FileSize Then -NotSupportRange: - SyncLock LockSource - If SourcesOnce.Contains(Info.Source) Then - GoTo SourceBreak - Else - SourcesOnce.Add(Info.Source) - End If - End SyncLock - - Throw New WebException($"该下载源不支持分段下载：Range 起始于 {Info.DownloadStart}，预期 ContentLength 为 {FileSize - Info.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") - ElseIf Not FileSize - Info.DownloadStart = ContentLength Then - Throw New WebException($"获取到的分段大小不一致：Range 起始于 {Info.DownloadStart}，预期 ContentLength 为 {FileSize - Info.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") - End If - Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，ContentLength {ContentLength}") - Info.State = NetState.Get - SyncLock LockState - If State < NetState.Get Then State = NetState.Get - End SyncLock - '创建缓存文件 - If IsNoSplit Then - Info.Temp = Nothing - SmailFileCache = New Queue(Of Byte) Else - Info.Temp = $"{PathTemp}Download\{Uuid}_{Info.Uuid}_{RandomInteger(0, 999999)}.tmp" - ResultStream = New FileStream(Info.Temp, FileMode.Create, FileAccess.Write, FileShare.Read) + FileSize = -1 : IsUnknownSize = True + Log($"[Download] {LocalName}：文件大小未知") End If - '开始下载 - Using HttpStream = HttpResponse.Content.ReadAsStreamAsync().GetAwaiter().GetResult() - If Setup.Get("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000)) - Dim HttpData As Byte() = New Byte(16384) {} - HttpDataCount = HttpStream.Read(HttpData, 0, 16384) - While (IsUnknownSize OrElse Info.DownloadUndone > 0) AndAlso '判断是否下载完成 - HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState.Merge AndAlso (Not Info.Source.IsFailed OrElse Info.Equals(Info.Source.Thread)) - '限速 - While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0 - Threading.Thread.Sleep(16) - End While - Dim RealDataCount As Integer = If(IsUnknownSize, HttpDataCount, Math.Min(HttpDataCount, Info.DownloadUndone)) - SyncLock NetTaskSpeedLimitLeftLock - If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount - End SyncLock - Dim DeltaTime = GetTimeTick() - Info.LastReceiveTime - If DeltaTime > 1000000 Then DeltaTime = 1 '时间刻反转导致出现极大值 - If RealDataCount > 0 Then - '有数据 - If Info.DownloadDone = 0 Then - '第一次接受到数据 - Info.State = NetState.Download - SyncLock LockState - If State < NetState.Download Then State = NetState.Download - End SyncLock - SyncLock LockCount - ConnectCount += 1 - ConnectTime += GetTimeTick() - Info.InitTime - End SyncLock - End If - SyncLock LockCount - Info.Source.FailCount = 0 - For Each Task In Tasks - Task.FailCount = 0 - Next - End SyncLock - NetManager.DownloadDone += RealDataCount - SyncLock LockDone - DownloadDone += RealDataCount - End SyncLock - Info.DownloadDone += RealDataCount - If IsNoSplit Then - If HttpData.Count = RealDataCount Then - 'SmailFileCache.AddRange(HttpData) - For Each B In HttpData - SmailFileCache.Enqueue(B) - Next - Else - 'SmailFileCache.AddRange(HttpData.ToList.GetRange(0, RealDataCount)) - For i = 0 To RealDataCount - 1 - SmailFileCache.Enqueue(HttpData(i)) - Next - End If - Else - ResultStream.Write(HttpData, 0, RealDataCount) - End If - '检查速度是否过慢 - If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount Then '数据包间隔大于 1.5s，且速度小于 1.5K/s - Throw New TimeoutException("由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。") - End If - Info.LastReceiveTime = GetTimeTick() - '已完成 - If Info.DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While - ElseIf Info.LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then - '无数据，且已超时 - Throw New TimeoutException("操作超时，无数据。") + ElseIf Th.IsFirstThread Then + If Check IsNot Nothing Then + If ContentLength < Check.MinSize AndAlso Check.MinSize > 0 Then + Throw New Exception($"文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。") + End If + If ContentLength <> Check.ActualSize AndAlso Check.ActualSize > 0 Then + Throw New Exception($"文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。") + End If + End If + FileSize = ContentLength : IsUnknownSize = False + Log($"[Download] {LocalName}：文件大小 {ContentLength}（{GetString(ContentLength)}）") + '若文件大小大于 50 M，进行剩余磁盘空间校验 + If ContentLength > 50 * 1024 * 1024 Then + For Each Drive As DriveInfo In DriveInfo.GetDrives + Dim DriveName As String = Drive.Name.First.ToString + Dim RequiredSpace = If(PathTemp.StartsWithF(DriveName), ContentLength * 1.1, 0) + + If(LocalPath.StartsWithF(DriveName), ContentLength + 5 * 1024 * 1024, 0) + If RequiredSpace > 0 AndAlso Drive.TotalFreeSpace < RequiredSpace Then + Throw New Exception(DriveName & " 盘空间不足，无法进行下载。" & vbCrLf & "需要至少 " & GetString(RequiredSpace) & " 空间，但当前仅剩余 " & GetString(Drive.TotalFreeSpace) & "。" & + If(PathTemp.StartsWithF(DriveName), vbCrLf & vbCrLf & "下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。", "")) End If - HttpDataCount = HttpStream.Read(HttpData, 0, 16384) - End While - End Using - End Using + Next + End If + ElseIf FileSize < 0 Then + Throw New Exception("非首线程运行时，尚未获取文件大小") + ElseIf Th.DownloadStart > 0 AndAlso ContentLength >= FileSize Then +NotSupportRange: + SyncLock LockSource + If SourcesOnce.Contains(Th.Source) Then GoTo SourceBreak + End SyncLock + Throw New RangeNotSupportedException($"该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") + ElseIf Not FileSize - Th.DownloadStart = ContentLength Then + Throw New RangeNotSupportedException($"获取到的分段大小不一致：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") + End If + 'Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，ContentLength {ContentLength}") + Th.State = NetState.Reading + SyncLock LockState + If State < NetState.Reading Then State = NetState.Reading + End SyncLock + '创建缓存文件 + If IsNoSplit Then + Th.Temp = Nothing + Cache = New MemoryStream + ResultStream = Cache + Else + Directory.CreateDirectory(PathTemp & "Download") + Th.Temp = $"{PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp" + ResultStream = New FileStream(Th.Temp, FileMode.Create, FileAccess.Write, FileShare.Read) + End If + '开始下载 + ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult() + If Settings.Get("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000)) + Dim ResponseBytes As Byte() = New Byte(16384) {} + HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + While (IsUnknownSize OrElse Th.DownloadUndone > 0) AndAlso '判断是否下载完成 + HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState.Merging AndAlso (Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th) + '限速 + While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0 + Threading.Thread.Sleep(16) + End While + Dim RealDataCount As Integer = If(IsUnknownSize, HttpDataCount, Math.Min(HttpDataCount, Th.DownloadUndone)) + If NetTaskSpeedLimitHigh > 0 Then Interlocked.Add(NetTaskSpeedLimitLeft, -RealDataCount) + Dim DeltaTime = GetTimeMs() - Th.LastReceiveTime + If DeltaTime > 100000000 Then DeltaTime = 1 '避免时间刻反转导致出现极大值 + If RealDataCount > 0 Then + '有数据 + If Th.DownloadDone = 0 Then + '第一次接受到数据 + Th.State = NetState.Downloading + SyncLock LockState + If State < NetState.Downloading Then State = NetState.Downloading + End SyncLock + Interlocked.Increment(ConnectCount) + Interlocked.Add(ConnectTime, GetTimeMs() - Th.InitTime) + End If + Th.Source.FailCount = 0 + For Each Task In Tasks + Task.FailCount = 0 + Next + Interlocked.Add(NetManager.DownloadDone, RealDataCount) + Interlocked.Add(DownloadDone, RealDataCount) + Th.DownloadDone += RealDataCount + ResultStream.Write(ResponseBytes, 0, RealDataCount) + '已完成 + If Th.DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While + '检查速度是否过慢 + If Th.LastReceiveTime > 0 AndAlso DeltaTime > 5000 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 5s，且速度小于 1K/s + Th.Source.SingleThread Is Nothing Then '且并非单线程下载 + Throw New TimeoutException("由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。") + End If + Th.LastReceiveTime = GetTimeMs() + ElseIf Th.LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then + '无数据，且已超时 + Throw New TimeoutException("操作超时，无数据。") + End If + HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + End While SourceBreak: - If State = NetState.Error OrElse Info.Source.IsFailed OrElse (Info.DownloadUndone > 0 AndAlso Not IsUnknownSize) Then + If State = NetState.Interrupted OrElse (Th.Source.IsFailed AndAlso Th.Source.SingleThread <> Th) OrElse (Th.DownloadUndone > 0 AndAlso Not IsUnknownSize) Then '被外部中断 - Info.State = NetState.Error - Log($"[Download] {LocalName} {Info.Uuid}#：中断") - ElseIf HttpDataCount = 0 AndAlso Info.DownloadUndone > 0 AndAlso Not IsUnknownSize Then + Th.State = NetState.Interrupted + Log($"[Download] {LocalName}：中断") + ElseIf HttpDataCount = 0 AndAlso Th.DownloadUndone > 0 AndAlso Not IsUnknownSize Then '服务器无返回数据 - Throw New Exception($"返回的 ContentLength 过多：ContentLength 为 {ContentLength}，但获取到的总数据量仅为 {Info.DownloadDone}（全文件总数据量 {DownloadDone}）") + Throw New Exception($"返回的 ContentLength 过多：ContentLength 为 {ContentLength}，但获取到的总数据量仅为 {Th.DownloadDone}（全文件总数据量 {DownloadDone}）") Else '本线程完成 - Info.State = NetState.Finish - If ModeDebug Then Log($"[Download] {LocalName} {Info.Uuid}#：完成，已下载 {Info.DownloadDone}") + Th.State = NetState.Finished + If ModeDebug Then Log($"[Download] {LocalName}：完成，已下载 {Th.DownloadDone}（{Th.DownloadStart}~{Th.DownloadEnd}）") + RecordIPReliability(HostIp, 0.5) End If Catch ex As Exception - '状态变更 - SyncLock LockCount - Info.Source.FailCount += 1 - 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 - IsTimeoutString.Contains("超时") OrElse IsTimeoutString.Contains("timeout") OrElse IsTimeoutString.Contains("timedout") - Log("[Download] " & LocalName & " " & Info.Uuid & If(IsTimeout, "#：超时（" & (Timeout * 0.001) & "s）", "#：出错，" & GetExceptionDetail(ex))) - Info.State = NetState.Error - ''使用该下载源的线程是否没有速度 - ''下载超时也会导致没有速度，容易误判下载失败，所以已弃用此方法 - 'Dim IsNoSpeed As Boolean = True - 'SyncLock LockChain - ' If Threads IsNot Nothing Then - ' For Each Thread As NetThread In Threads - ' If Thread.Source.Id = Info.Source.Id AndAlso Thread.Speed > 0 Then - ' IsNoSpeed = False - ' Exit For - ' End If - ' Next - ' End If - 'End SyncLock - Info.Source.Ex = ex - '根据情况判断，是否在多线程下禁用下载源（连续错误过多，或不支持断点续传） - If ex.Message.Contains("该下载源不支持") OrElse ex.Message.Contains("未能解析") OrElse ex.Message.Contains("(404)") OrElse - ex.Message.Contains("(502)") OrElse ex.Message.Contains("无返回数据") OrElse ex.Message.Contains("空间不足") OrElse ex.Message.Contains("获取到的分段大小不一致") OrElse - (ex.Message.Contains("(403)") AndAlso Not Info.Source.Url.ContainsF("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403，所以不应因此禁用下载源 - (Info.Source.FailCount >= MathClamp(NetTaskThreadLimit, 5, 30) AndAlso DownloadDone < 1) OrElse - Info.Source.FailCount > NetTaskThreadLimit + 2 Then - Dim IsThisFail As Boolean = False - SyncLock LockSource - If Info.Source.Thread IsNot Nothing AndAlso Info.Source.Thread.Equals(Info) Then - '单线程下，本线程出错 - SourcesOnce.RemoveAt(0) - GoTo Wrong - ElseIf Not Info.Source.IsFailed Then - '多线程下，本线程出错 -Wrong: - Info.Source.IsFailed = True - IsThisFail = True - End If - End SyncLock - '本线程引发下载源被禁用 - If IsThisFail Then - Log($"[Download] {LocalName} {Info.Uuid}#：下载源被禁用（{Info.Source.Id}）：{Info.Source.Url}") - Log(ex, "下载源 " & Info.Source.Id & " 已被禁用", If(ex.Message.Contains("不支持分段下载") OrElse ex.Message.Contains("(404)") OrElse ex.Message.Contains("(416)"), LogLevel.Developer, LogLevel.Debug)) - If IsSourceFailed() Then - '没有可用源 - Log("[Download] 文件 " & LocalName & " 已无可用下载源") - Dim ExampleEx As Exception = Nothing - SyncLock LockSource - For Each Source As NetSource In Sources - Log("[Download] 已禁用的下载源：" & Source.Url) - If Source.Ex IsNot Nothing Then - ExampleEx = Source.Ex - Log(Source.Ex, "下载源禁用原因", LogLevel.Developer) - End If - Next - End SyncLock - Fail(ExampleEx) - ElseIf ex.Message.Contains("空间不足") Then - '没有空间 - Fail(ex) - End If - End If - End If - '首线程错误 - If FileSize = -2 Then - SyncLock LockChain - Threads = Nothing - End SyncLock - End If + Log($"[Download] {LocalName}：出错，{If(TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException, + $"已超时（{Timeout}ms）", ex.GetDetail())}，IP：{HostIp}") + RecordIPReliability(HostIp, -0.7) + SourceFail(Th, ex, False) Finally - If ResultStream IsNot Nothing Then ResultStream.Dispose() - SyncLock NetTaskThreadCountLock - NetTaskThreadCount -= 1 - End SyncLock - '可能在没有下载完的时候开始合并文件了，这造成了大多数合并失败 - If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso State < NetState.Merge Then Merge() + '释放资源 + HttpRequest?.Dispose() + Response?.Dispose() + ResponseStream?.Dispose() + CancelToken?.Dispose() + If Not IsNoSplit Then ResultStream?.Dispose() + '改变计数 + Interlocked.Decrement(NetTaskThreadCount) + '合并 + If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso + State < NetState.Merging AndAlso Th.State <> NetState.Interrupted Then Merge(Th) End Try End Sub - ''' - ''' 从 HTTP 响应头中获取文件名。 - ''' 如果没有，返回 Nothing。 - ''' - Private Function GetFileNameFromResponse(response As HttpWebResponse) As String - Dim header As String = response.Headers("Content-Disposition") - If String.IsNullOrEmpty(header) Then Return Nothing - 'attachment; filename="filename.ext" - If Not header.Contains("filename=") Then Return Nothing - Return header.AfterLast("filename=").Trim(""""c, " "c).BeforeFirst(";") - End Function + Private Sub SourceFail(Th As NetThread, ex As Exception, IsMergeFailure As Boolean) + '状态变更 + Interlocked.Increment(Th.Source.FailCount) + For Each Task In Tasks + Interlocked.Increment(Task.FailCount) + Next + Th.State = NetState.Interrupted + Th.Source.Ex = ex + '根据情况判断，是否在多线程下禁用下载源（连续错误过多，或不支持断点续传） + Dim IsRangeNotSupported As Boolean = TypeOf ex Is RangeNotSupportedException OrElse ex.Message.Contains("(416)") + If IsMergeFailure OrElse IsRangeNotSupported OrElse + ex.Message.Contains("(502)") OrElse ex.Message.Contains("(404)") OrElse + ex.Message.Contains("未能解析") OrElse ex.Message.Contains("无返回数据") OrElse ex.Message.Contains("空间不足") OrElse + ((ex.Message.Contains("(403)") OrElse ex.Message.Contains("(429)")) AndAlso Not Th.Source.Url.Contains("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403/429，所以不应因此禁用下载源 + (Th.Source.FailCount >= MathClamp(NetTaskThreadLimit, 5, 30) AndAlso DownloadDone < 1) OrElse Th.Source.FailCount > NetTaskThreadLimit + 2 Then + '当一个下载源有多个线程在下载时，只选择其中一个线程进行后续处理 + Dim IsThisFail As Boolean = False + SyncLock LockSource + If Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th Then + IsThisFail = True + Th.Source.IsFailed = True + End If + End SyncLock + '……后续处理 + If IsThisFail Then + Log($"[Download] {LocalName}：下载源被禁用（{Th.Source.Id}，Range 问题：{IsRangeNotSupported}）：{Th.Source.Url}") + Log(ex, $"{If(SourcesOnce.FirstOrDefault?.SingleThread Is Nothing, "", "单线程")}下载源 {Th.Source.Id} 已被禁用", + If(IsRangeNotSupported OrElse ex.Message.Contains("(404)"), LogLevel.Developer, LogLevel.Debug)) + SyncLock LockSource + SourcesOnce.Remove(Th.Source) + End SyncLock + If ex.Message.Contains("空间不足") Then + '硬盘空间不足：强制失败 + Fail(ex) + ElseIf HasAvailableSource() AndAlso Not IsMergeFailure Then + '当前源失败，但还有下载源：正常地继续执行 + ElseIf Not Retried Then + '合并失败或首次下载失败，未重试：将所有下载源重新标记为不允许断点续传的下载源，逐个重新尝试下载 + '若所有源均不支持 Range，也会走到这里重试 + If Not IsRangeNotSupported Then Log($"[Download] {LocalName}：文件下载失败，正在自动重试……", LogLevel.Debug) + Retried = True + SyncLock LockSource + SourcesOnce.Clear() + For Each Source In Sources + SourcesOnce.Add(Source) + Source.IsFailed = True + Next + End SyncLock + Reset() + SyncLock LockState + State = NetState.WaitingToDownload + End SyncLock + ElseIf HasAvailableSource() AndAlso IsMergeFailure Then + '合并失败且单个源失败：继续下一个源 + Reset() + SyncLock LockState + State = NetState.WaitingToDownload + End SyncLock + Else + '失败 + Log($"[Download] {LocalName}：已无可用下载源，下载失败") + Dim ExampleEx As Exception = Nothing + SyncLock LockSource + For Each Source As NetSource In Sources + Log("[Download] 已禁用的下载源：" & Source.Url) + If Source.Ex IsNot Nothing Then + ExampleEx = Source.Ex + Log(Source.Ex, "下载源禁用原因", LogLevel.Developer) + End If + Next + End SyncLock + Fail(ExampleEx) + End If + End If + End If + '清理当前已下载的内容 + If FileSize = -2 Then Reset() + End Sub + Private Sub Reset() + FileSize = -2 + Cache?.Dispose() : Cache = Nothing + SyncLock LockChain + Threads = Nothing + End SyncLock + Interlocked.Add(NetManager.DownloadDone, -DownloadDone) + DownloadDone = 0 + SpeedLastDone = 0 + End Sub + + '最终收束事件 - '下载文件的最终收束事件 ''' ''' 下载完成。合并文件。 ''' - Private Sub Merge() + Private Sub Merge(Th As NetThread) '状态判断 SyncLock LockState - If State < NetState.Merge Then - State = NetState.Merge + If State < NetState.Merging Then + State = NetState.Merging Else - Exit Sub + Return End If End SyncLock Dim RetryCount As Integer = 0 - Dim MergeFile As Stream = Nothing, AddWriter As BinaryWriter = Nothing Try Retry: + '创建文件夹 + If File.Exists(LocalPath) Then File.Delete(LocalPath) + Directory.CreateDirectory(GetPathFromFullPath(LocalPath)) SyncLock LockChain - '创建文件夹 - If File.Exists(LocalPath) Then File.Delete(LocalPath) - Dim Info As New FileInfo(LocalPath) - Info.Directory.Create() '合并文件 If IsNoSplit Then - '仅有一个线程，从缓存中输出 - If ModeDebug Then Log($"[Download] {LocalName}：下载结束，从缓存输出文件，长度：" & SmailFileCache.Count) - MergeFile = New FileStream(LocalPath, FileMode.Create) - AddWriter = New BinaryWriter(MergeFile) - AddWriter.Write(SmailFileCache.ToArray) - AddWriter.Dispose() : AddWriter = Nothing - MergeFile.Dispose() : MergeFile = Nothing + '仅有一个线程，从内存中输出 + If ModeDebug Then Log($"[Download] {LocalName}：下载结束，从内存输出文件") + Cache.Position = 0 + WriteFile(LocalPath, Cache) ElseIf Threads.DownloadDone = DownloadDone AndAlso Threads.Temp IsNot Nothing Then '仅有一个文件，直接复制 If ModeDebug Then Log($"[Download] {LocalName}：下载结束，仅有一个文件，无需合并") @@ -1517,40 +1292,37 @@ Retry: Else '有多个线程，合并 If ModeDebug Then Log($"[Download] {LocalName}：下载结束，开始合并文件") - MergeFile = New FileStream(LocalPath, FileMode.Create) - AddWriter = New BinaryWriter(MergeFile) - For Each Thread As NetThread In Threads - If Thread.DownloadDone = 0 OrElse Thread.Temp Is Nothing Then Continue For - Using fs As New FileStream(Thread.Temp, FileMode.Open, FileAccess.Read, FileShare.Read) - Using TempReader As New BinaryReader(fs) - AddWriter.Write(TempReader.ReadBytes(Thread.DownloadDone)) - End Using + Using MergeFile As New FileStream(LocalPath, FileMode.Create) + Using AddWriter As New BinaryWriter(MergeFile) + For Each Thread As NetThread In Threads + If Thread.DownloadDone = 0 OrElse Thread.Temp Is Nothing Then Continue For + Using fs As New FileStream(Thread.Temp, FileMode.Open, FileAccess.Read, FileShare.Read) + Using TempReader As New BinaryReader(fs) + AddWriter.Write(TempReader.ReadBytes(Thread.DownloadDone)) + End Using + End Using + Next End Using - Next - AddWriter.Dispose() : AddWriter = Nothing - MergeFile.Dispose() : MergeFile = Nothing - End If - '写入大小要求 - If Not IsUnknownSize AndAlso Check IsNot Nothing Then - If Check.ActualSize = -1 Then - Check.ActualSize = FileSize - ElseIf Check.ActualSize <> FileSize Then - Throw New Exception($"文件大小不一致：任务要求为 {Check.ActualSize} B，网络获取结果为 {FileSize}B") - End If + End Using End If '检查文件 Dim CheckResult As String = Check?.Check(LocalPath) + If CheckResult Is Nothing AndAlso Not IsUnknownSize AndAlso Check IsNot Nothing Then + If Check.ActualSize = -1 Then + CheckResult = (New FileChecker With {.ActualSize = FileSize}).Check(LocalPath) '不修改原始的 Checker，以免污染原始实例 + ElseIf Check.ActualSize <> FileSize Then + CheckResult = $"文件大小不一致：任务校验要求为 {Check.ActualSize}，请求结果为 {FileSize}" + End If + End If If CheckResult IsNot Nothing Then 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}") + For Each T As NetThread In Threads + Log($"[Download] - {T.Uuid}#，状态 {GetStringFromEnum(T.State)}，范围 {T.DownloadStart}~{T.DownloadEnd}，已下载 {T.DownloadDone}，未下载 {T.DownloadUndone}") Next Throw New Exception(CheckResult) End If '后处理 - If IsNoSplit Then - SmailFileCache = Nothing - Else + If Not IsNoSplit Then For Each Thread As NetThread In Threads If Thread.Temp IsNot Nothing Then File.Delete(Thread.Temp) Next @@ -1558,20 +1330,23 @@ Retry: Finish() End SyncLock Catch ex As Exception - Log(ex, "合并文件出错（" & LocalName & "）") - If MergeFile IsNot Nothing Then - MergeFile.Dispose() : MergeFile = Nothing - End If - If AddWriter IsNot Nothing Then - AddWriter.Dispose() : AddWriter = Nothing - End If - '重试 - If RetryCount <= 3 Then - Threading.Thread.Sleep(RandomInteger(500, 1000)) - RetryCount += 1 + RetryCount += 1 + If State > NetState.Merging Then Return '通常是因为在合并时被中断了 + Log(ex, $"合并文件出错，第 {RetryCount} 次尝试（{LocalName}）") + '重新尝试合并 + If RetryCount < 3 Then + Threading.Thread.Sleep(500 * RetryCount) GoTo Retry End If - Fail(ex) + '失败，禁用当前下载源并重启下载 + Try + If File.Exists(LocalPath) Then File.Delete(LocalPath) + Catch exx As Exception + Log(ex, $"删除合并失败的文件出错（{LocalPath}）") + End Try + SourceFail(Th, ex, True) + Finally + Cache?.Dispose() End Try End Sub ''' @@ -1579,12 +1354,13 @@ Retry: ''' Private Sub Fail(Optional RaiseEx As Exception = Nothing) SyncLock LockState - If State >= NetState.Finish Then Exit Sub + If State >= NetState.Finished Then Return If RaiseEx IsNot Nothing Then Ex.Add(RaiseEx) '凉凉 - State = NetState.Error + Log($"[Download] {LocalName}：已失败，当前状态 {State}") + State = NetState.Interrupted End SyncLock - InterruptAndDelete() + InterruptInternal() For Each Task In Tasks Task.OnFileFail(Me) Next @@ -1592,24 +1368,22 @@ Retry: ''' ''' 下载中断。 ''' - Public Sub Abort(CausedByTask As LoaderDownload) + Public Sub Interrupt(InterruptedTask As LoaderDownload) '从特定任务中移除，如果它还属于其他任务，则继续下载 - Tasks.Remove(CausedByTask) - If Tasks.Any Then Exit Sub + Tasks.Remove(InterruptedTask) + If Tasks.Any Then Return '确认中断 SyncLock LockState - If State >= NetState.Finish Then Exit Sub - State = NetState.Error + If State >= NetState.Finished Then Return + Log($"[Download] {LocalName}：已中断，当前状态 {State}") + State = NetState.Interrupted End SyncLock - InterruptAndDelete() + InterruptInternal() End Sub - Private Sub InterruptAndDelete() + Private Sub InterruptInternal() On Error Resume Next - If File.Exists(LocalPath) Then File.Delete(LocalPath) - SyncLock NetManager.LockRemain - NetManager.FileRemain -= 1 - Log($"[Download] {LocalName}：状态 {State}，剩余文件 {NetManager.FileRemain}") - End SyncLock + Reset() + Interlocked.Decrement(NetManager.FileRemain) End Sub '状态改变接口 @@ -1618,19 +1392,23 @@ Retry: ''' Public Sub Finish(Optional PrintLog As Boolean = True) SyncLock LockState - If State >= NetState.Finish Then Exit Sub - State = NetState.Finish - End SyncLock - SyncLock NetManager.LockRemain - NetManager.FileRemain -= 1 - If PrintLog Then Log("[Download] " & LocalName & "：已完成，剩余文件 " & NetManager.FileRemain) + If State >= NetState.Finished Then Return + State = NetState.Finished End SyncLock + Interlocked.Decrement(NetManager.FileRemain) + If PrintLog Then Log($"[Download] {LocalName}：已完成") For Each Task In Tasks Task.OnFileFinish(Me) Next End Sub End Class + Private Class RangeNotSupportedException + Inherits WebException + Public Sub New(Message As String) + MyBase.New(Message) + End Sub + End Class ''' ''' 下载一系列文件的加载器。 ''' @@ -1722,20 +1500,10 @@ FinishExCatch: Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False) If Input IsNot Nothing Then Files = New SafeList(Of NetFile)(Input) '去重 - Dim ResultArray As New SafeList(Of NetFile) - For i = 0 To Files.Count - 1 - For ii = i + 1 To Files.Count - 1 - If Files(i).LocalPath = Files(ii).LocalPath Then GoTo NextElement - Next - ResultArray.Add(Files(i)) -NextElement: - Next - Files = ResultArray + Files = New SafeList(Of NetFile)(Files.Distinct(Function(a, b) a.LocalPath = b.LocalPath)) '设置剩余文件数 SyncLock FileRemainLock - For Each File In Files - If File.State <> NetState.Finish Then FileRemain += 1 - Next + FileRemain += Files.Where(Function(f) f.State <> NetState.Finished).Count End SyncLock State = LoadState.Loading '开始执行 @@ -1745,132 +1513,188 @@ NextElement: '输入检测 If Not Files.Any() Then OnFinish() - Exit Sub + Return End If For Each File As NetFile In Files If File Is Nothing Then Throw New ArgumentException("存在空文件请求！") For Each Source As NetSource In File.Sources If Not (Source.Url.StartsWithF("https://", True) OrElse Source.Url.StartsWithF("http://", True)) Then - Source.Ex = New ArgumentException("输入的下载链接不正确！") + Source.Ex = New ArgumentException("输入的下载链接不正确：" & Source.Url) Source.IsFailed = True End If Next - If File.IsSourceFailed() Then Throw New ArgumentException("输入的下载链接不正确！") - If Not File.LocalPath.ToLower.Contains(":\") Then Throw New ArgumentException("输入的本地文件地址不正确！") - If File.LocalPath.EndsWithF("\") Then Throw New ArgumentException("请输入含文件名的完整文件路径！") - '文件夹检测 - Dim DirPath As String = New FileInfo(File.LocalPath).Directory.FullName - If Not Directory.Exists(DirPath) Then Directory.CreateDirectory(DirPath) + If Not File.HasAvailableSource() Then Throw New ArgumentException("输入的下载链接不正确！") + File.LocalPath = File.LocalPath.Replace("/", "\") + If Not File.LocalPath.Lower.Contains(":\") Then Throw New ArgumentException("输入的本地文件地址不正确：" & File.LocalPath) + If File.LocalPath.EndsWithF("\") Then Throw New ArgumentException("请输入含文件名的完整文件路径：" & File.LocalPath) + Directory.CreateDirectory(GetPathFromFullPath(File.LocalPath)) '创建目标文件夹 Next - '接入下载管理器 - NetManager.Start(Me) - '将文件分配给多个线程以进行已存在查找 - Dim Folders As New List(Of String) '可能会用于已存在查找的文件夹列表 - Dim FoldersFinal As New List(Of String) '最终用于查找的列表 - If Not Setup.Get("SystemDebugSkipCopy") Then '在设置中禁用复制 - Folders.Add(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\") '总是添加官启文件夹，因为 HMCL 会把所有文件存在这里 - For Each Folder In McFolderList - Folders.Add(Folder.Path) - Next - Folders = Folders.Distinct.ToList - For Each Folder In Folders - If Folder <> PathMcFolder AndAlso Directory.Exists(Folder) Then FoldersFinal.Add(Folder) - Next - End If - '最多 5 个线程，最少每个线程分配 10 个文件 - Dim FilesPerThread As Integer = Math.Max(5, Files.Count / 10 + 1) - Dim FilesInThread As New List(Of NetFile) - For Each File In Files - FilesInThread.Add(File) - If FilesInThread.Count = FilesPerThread Then - Dim FilesToRun As New List(Of NetFile) - FilesToRun.AddRange(FilesInThread) - RunInNewThread(Sub() StartCopy(FilesToRun, FoldersFinal), "NetTask FileCopy " & Uuid) - FilesInThread.Clear() + '接入下载管理器，获取新开始下载的文件列表 + Dim NewFiles = NetManager.Start(Me) + + '==================================== + ' 已存在文件查找 + '==================================== + + '整理允许进行查找的文件 + Dim FilesToCheck As New List(Of NetFile) + For Each File In NewFiles + If File.Check?.CanUseExistsFile Then + FilesToCheck.Add(File) + Else '不允许，直接开始下载 + SyncLock LockState + File.State = NetState.WaitingToDownload + File.IsCopy = False + End SyncLock End If Next - If FilesInThread.Any Then - Dim FilesToRun As New List(Of NetFile) - FilesToRun.AddRange(FilesInThread) - RunInNewThread(Sub() StartCopy(FilesToRun, FoldersFinal), "NetTask FileCopy " & Uuid) - FilesInThread.Clear() + If Not FilesToCheck.Any Then Return + '获取 MC 文件夹列表 + Dim Folders As New List(Of String) + Folders.Add(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\") '总是添加官启文件夹，因为 HMCL 会把所有文件存在这里 + Folders.AddRange(McFolderList.Select(Function(f) f.Location)) + Folders = Folders.Distinct.Where(Function(f) Directory.Exists(f)).ToList + '平均分配到多个检查线程 + Dim ThreadCount As Integer = MathClamp(FilesToCheck.Count \ 40, 1, 8) '每个线程至少 40 个文件，最多 8 线程 + If ThreadCount = 1 Then '只有一个线程，直接执行 + CheckExistingFiles(FilesToCheck, Folders) + Else + Dim BaseSize = FilesToCheck.Count \ ThreadCount + Dim Remainder = FilesToCheck.Count Mod ThreadCount + Dim Index = 0 + For i = 0 To ThreadCount - 1 + Dim Size = BaseSize + If(i < Remainder, 1, 0) + Dim ThreadFiles = FilesToCheck.GetRange(Index, Size) + Index += Size + RunInNewThread(Sub() CheckExistingFiles(ThreadFiles, Folders), $"下载 文件复制 {Uuid}/{GetUuid()}") + Next End If Catch ex As Exception - OnFail(New List(Of Exception) From {ex}) + OnFail(New List(Of Exception) From {New Exception("下载初始化失败", ex)}) End Try - End Sub, "NetTask " & Uuid & " Main") + End Sub, "L/下载 " & Uuid) End Sub - Private Sub StartCopy(Files As List(Of NetFile), FolderList As List(Of String)) + Private Sub CheckExistingFiles(Files As List(Of NetFile), FolderList As List(Of String)) Try - If ModeDebug Then Log("[Download] 检查线程分配文件数：" & Files.Count & "，线程名：" & Thread.CurrentThread.Name) - '试图从已存在的 Minecraft 文件夹中寻找目标文件 - Dim ExistFiles As New List(Of KeyValuePair(Of NetFile, String)) '{NetFile, Target As String} - For Each File As NetFile In Files - Dim ExistFilePath As String = Nothing - '判断是否有已存在的文件 - If File.Check IsNot Nothing AndAlso McFolderList IsNot Nothing AndAlso PathMcFolder IsNot Nothing AndAlso File.Check.CanUseExistsFile AndAlso File.LocalPath.StartsWithF(PathMcFolder) Then - Dim Relative = File.LocalPath.Replace(PathMcFolder, "") - For Each Folder In FolderList - Dim Target = Folder & Relative - If File.Check.Check(Target) Is Nothing Then - ExistFilePath = Target - Exit For - End If + If ModeDebug Then Log($"[Download] 文件检查开始，本线程负责的文件数：{Files.Count}") + '列出 MC 文件夹中的各个版本文件夹 + Dim VersionFolders As New List(Of String) + For Each McFolder In FolderList + Dim VersionsFolder As New DirectoryInfo(McFolder & "versions\") + If VersionsFolder.Exists() Then + For Each VersionFolder In VersionsFolder.GetDirectories + VersionFolders.Add(VersionFolder.FullName & "\") Next End If - '若存在，则改变状态 - SyncLock LockState - If ExistFilePath IsNot Nothing Then - File.State = NetState.WaitForCopy - File.IsCopy = True - ExistFiles.Add(New KeyValuePair(Of NetFile, String)(File, ExistFilePath)) - Else - File.State = NetState.WaitForDownload - File.IsCopy = False - End If - End SyncLock Next - '复制已存在的文件 - For Each FileToken In ExistFiles - Dim File As NetFile = FileToken.Key - SyncLock LockState - If File.State > NetState.WaitForCopy Then Exit Sub - End SyncLock - Dim LocalPath As String = FileToken.Value - Dim RetryCount As Integer = 0 + '处理每个文件 + For Each File As NetFile In Files + Dim Target As String = CheckExistingFile(FolderList, VersionFolders, File) + If File.State >= NetState.WaitingToDownload Then Continue For '中断 + '已找到相同文件 + If Target IsNot Nothing Then + File.IsCopy = True + Dim RetryCount As Integer = 0 Retry: - Try - Log("[Download] 复制已存在的文件（" & LocalPath & "）") - CopyFile(LocalPath, File.LocalPath) - File.Finish(False) - Catch ex As Exception - RetryCount += 1 - Log(ex, String.Format("复制已存在的文件失败，重试第 {2} 次（{0} -> {1}）", LocalPath, File.LocalPath, RetryCount)) - If RetryCount < 3 Then - Thread.Sleep(200) - GoTo Retry - End If - File.State = NetState.WaitForDownload + Try + If Target <> File.LocalPath Then + Log($"[Download] 复制已存在的文件：{Target} → {File.LocalPath}") + CopyFile(Target, File.LocalPath) + Else + If ModeDebug Then Log($"[Download] 需要下载的文件已存在，并通过校验：{Target}") + End If + File.Finish(False) + Continue For + Catch ex As Exception + RetryCount += 1 + Log(ex, $"复制已存在的文件失败，第 {RetryCount} 次重试（{Target} → {File.LocalPath}）") + If RetryCount < 3 Then + Thread.Sleep(2000) + GoTo Retry + End If + End Try + End If + '回退到下载 + SyncLock LockState + File.State = NetState.WaitingToDownload File.IsCopy = False - End Try + End SyncLock Next Catch ex As Exception - Log(ex, "下载已存在文件查找失败", LogLevel.Feedback) + OnFail(New List(Of Exception) From {New Exception("下载已存在文件查找失败", ex)}) End Try End Sub + Private Function CheckExistingFile(FolderList As List(Of String), VersionFolders As List(Of String), File As NetFile) As String + '目标文件已存在 + If File.Check.Check(File.LocalPath) Is Nothing Then Return File.LocalPath + '在设置中禁用了复制 + If Settings.Get("SystemDebugSkipCopy") Then Return Nothing + '没有可用的检查规则，只能开始下载 + If File.Check.Hash Is Nothing AndAlso File.Check.ActualSize < 0 Then Return Nothing + '大致判断文件类别 + Dim TypeIndexes = + {"\assets\", "\libraries\", "\versions\", "\mods\", "\coremods\", "\lib\", "\resourcepacks\", "\texturepacks\", "\shaderpacks\"}. + Select(Function(FolderName) (FolderName, File.LocalPath.IndexOfF(FolderName, True))). + Where(Function(kv) kv.Item2 >= 0).ToList + If Not TypeIndexes.Any Then + If File.LocalName.EndsWithF(".jar") Then + TypeIndexes.Add(("\versions\", 1)) '总是对 jar 进行版本文件检查，以包括另存为 jar 的情况 + Else + Return Nothing + End If + End If + Dim Type = TypeIndexes.MaxBy(Function(kv) kv.Item2).FolderName.TrimStart("\"c) + '根据类别进行查找 + Static Sizes As New SafeDictionary(Of String, Long) + Select Case Type + Case "assets\", "libraries\" + 'assets/libraries：查找 MC 文件夹下的相同路径 + For Each Folder In FolderList + Dim Candidate = Folder & Type & File.LocalPath.AfterFirst(Type) + If File.Check.Check(Candidate) Is Nothing Then Return Candidate + Next + Case "versions\" + '版本 jar 或 json：查找 MC 文件夹下的各个版本文件夹 + For Each VersionFolder In VersionFolders + For Each Candidate In Directory.GetFiles(VersionFolder, + "*." & GetFileNameFromPath(File.LocalPath).AfterLast(".").Lower, SearchOption.TopDirectoryOnly) + '快速进行大小校验 + If Not Sizes.ContainsKey(Candidate) Then Sizes(Candidate) = New FileInfo(Candidate).Length + If File.Check.ActualSize <> Sizes(Candidate) Then Continue For + 'Hash 校验 + If File.Check.Check(Candidate) Is Nothing Then Return Candidate + Next + Next + Case Else + '社区资源 + If File.Check.ActualSize < 0 OrElse File.Check.Hash Is Nothing Then Return Nothing '必须要求指定了文件大小和 Hash + For Each Folder In FolderList.Concat(VersionFolders) + Dim TargetFolder = Folder & Type + If Not Directory.Exists(TargetFolder) Then Continue For + For Each Candidate In Directory.GetFiles(TargetFolder) + '快速进行大小校验 + If Not Sizes.ContainsKey(Candidate) Then Sizes(Candidate) = New FileInfo(Candidate).Length + If File.Check.ActualSize <> Sizes(Candidate) Then Continue For + 'Hash 校验 + If File.Check.Check(Candidate) Is Nothing Then Return Candidate + Next + Next + End Select + Return Nothing + End Function Public Sub OnFileFinish(File As NetFile) '要求全部文件完成 SyncLock FileRemainLock FileRemain -= 1 - If FileRemain > 0 Then Exit Sub + If FileRemain > 0 Then Return End SyncLock OnFinish() End Sub Public Sub OnFinish() RaisePreviewFinish() SyncLock LockState - If State > LoadState.Loading Then Exit Sub + If State > LoadState.Loading Then Return State = LoadState.Finished End SyncLock End Sub @@ -1881,44 +1705,52 @@ Retry: Next OnFail(File.Ex) End Sub + Public Overrides Sub Failed(Ex As Exception) + OnFail(New List(Of Exception) From {Ex}) + End Sub Public Sub OnFail(ExList As List(Of Exception)) SyncLock LockState - If State > LoadState.Loading Then Exit Sub + If State >= LoadState.Finished Then Return If ExList Is Nothing OrElse Not ExList.Any() Then ExList = New List(Of Exception) From {New Exception("未知错误！")} - '寻找第一个不是 404 的下载源 - Dim UsefulExs = ExList.Where(Function(e) Not e.Message.Contains("(404)")).ToList - [Error] = If(UsefulExs.Any, UsefulExs(0), ExList(0)) + '寻找有效的错误信息 + Dim UsefulExs = ExList.Where(Function(e) TypeOf e IsNot OperationCanceledException AndAlso TypeOf e IsNot TimeoutException AndAlso TypeOf e IsNot ThreadInterruptedException).ToList + [Error] = If(UsefulExs.FirstOrDefault, ExList.FirstOrDefault) '获取实际失败的文件 For Each File In Files - If File.State = NetState.Error Then - [Error] = New Exception("文件下载失败：" & File.LocalPath & vbCrLf & Join( - File.Sources.Select(Function(s) If(s.Ex Is Nothing, s.Url, s.Ex.Message & "（" & s.Url & "）")), vbCrLf), [Error]) - Exit For - End If + If File.State <> NetState.Interrupted Then Continue For + If File.Sources.All(Function(s) TypeOf s.Ex Is OperationCanceledException OrElse TypeOf s.Ex Is TimeoutException OrElse TypeOf s.Ex Is ThreadInterruptedException) Then Continue For + Dim Detail As String = File.Sources.Select(Function(s) $"{If(s.Ex Is Nothing, "无错误信息。", s.Ex.GetBrief())}（{s.Url}）").Join(vbCrLf) + [Error] = New Exception("文件下载失败：" & File.LocalPath & vbCrLf & + "各下载源的错误如下：" & vbCrLf & Detail, [Error]) + '上报 + Telemetry("文件下载失败", + "FileName", File.LocalName, + "Exception", Detail) + Exit For Next '在设置 Error 对象后再更改为失败，避免 WaitForExit 无法捕获错误 State = LoadState.Failed End SyncLock '中断所有文件 For Each TaskFile In Files - If TaskFile.State < NetState.Merge Then TaskFile.State = NetState.Error + TaskFile.Interrupt(Me) Next '在退出同步锁后再进行日志输出 Dim ErrOutput As New List(Of String) For Each Ex As Exception In ExList - ErrOutput.Add(GetExceptionDetail(Ex)) + ErrOutput.Add(Ex.GetDetail()) Next - Log("[Download] " & Join(ErrOutput.Distinct.ToArray, vbCrLf)) + Log("[Download] " & ErrOutput.Distinct.Join(vbCrLf)) End Sub - Public Overrides Sub Abort() + Public Overrides Sub Interrupt() SyncLock LockState - If State >= LoadState.Finished Then Exit Sub - State = LoadState.Aborted + If State >= LoadState.Finished Then Return + State = LoadState.Interrupted End SyncLock Log("[Download] " & Name & " 已取消！") '中断所有文件 For Each TaskFile In Files - TaskFile.Abort(Me) + TaskFile.Interrupt(Me) Next End Sub @@ -1935,8 +1767,7 @@ Retry: ''' ''' 需要下载的文件。为“本地地址 - 文件对象”键值对。 ''' - Public Files As New Dictionary(Of String, NetFile) - Public ReadOnly LockFiles As New Object + Public AllFiles As New SafeDictionary(Of String, NetFile) ''' ''' 当前的所有下载任务。 @@ -1946,34 +1777,13 @@ Retry: ''' ''' 已下载完成的大小。 ''' - Public Property DownloadDone As Long - Get - Return _DownloadDone - End Get - Set(value As Long) - SyncLock LockDone - _DownloadDone = value - End SyncLock - End Set - End Property - Private _DownloadDone As Long = 0 - Private ReadOnly LockDone As New Object - + Public DownloadDone As Long = 0 ''' ''' 尚未完成下载的文件数。 ''' Public FileRemain As Integer = 0 - Public ReadOnly LockRemain As New Object - ''' - ''' 上次记速时的已下载大小。 - ''' - Private SpeedLastDone As Long = 0 - ''' - ''' 至多最近 30 次下载速度的记录，较新的在前面。 - ''' - Private SpeedLast As New List(Of Long) '这些属性由 RefreshStat 刷新 ''' ''' 当前的全局下载速度，单位为 Byte / 秒。 @@ -1989,11 +1799,13 @@ Retry: ''' Private Sub RefreshStat() Try - Dim DeltaTime As Long = GetTimeTick() - RefreshStatLast + Dim DeltaTime As Long = GetTimeMs() - RefreshStatLast If DeltaTime = 0 Then Return RefreshStatLast += DeltaTime #Region "刷新整体速度" '计算瞬时速度 + Static SpeedLast As New List(Of Long) '记录至多最近 30 次下载速度的记录，较新的在前面 + Static SpeedLastDone As Long = 0 '上次记速时的已下载大小 Dim ActualSpeed As Double = Math.Max(0, (DownloadDone - SpeedLastDone) / (DeltaTime / 1000)) SpeedLast.Insert(0, ActualSpeed) If SpeedLast.Count >= 31 Then SpeedLast.RemoveAt(30) @@ -2029,8 +1841,9 @@ Retry: ''' 启动监控线程，用于新增下载线程。 ''' Private Sub StartManager() - If IsManagerStarted Then Exit Sub - IsManagerStarted = True + Static IsStarted As Boolean = False + If IsStarted Then Return + IsStarted = True Dim ThreadStarter = Sub(Id As Integer) '0 或 1 Try @@ -2038,17 +1851,17 @@ Retry: Thread.Sleep(20) '获取文件列表 Dim AllFiles As List(Of NetFile) - SyncLock LockFiles - If Id = 0 AndAlso FileRemain = 0 AndAlso Files.Any() Then Files.Clear() '若已完成，则清空 - AllFiles = Files.Values.ToList() + SyncLock Me.AllFiles.SyncRoot + If Id = 0 AndAlso FileRemain = 0 AndAlso Me.AllFiles.Any() Then Me.AllFiles.Clear() '若已完成，则清空 + AllFiles = Me.AllFiles.Values.ToList() End SyncLock Dim WaitingFiles As New List(Of NetFile) Dim OngoingFiles As New List(Of NetFile) For Each File As NetFile In AllFiles If File.Uuid Mod 2 = Id Then Continue For - If File.State = NetState.WaitForDownload Then + If File.State = NetState.WaitingToDownload Then WaitingFiles.Add(File) - ElseIf File.State < NetState.Merge Then + ElseIf File.State < NetState.Merging AndAlso File.State >= NetState.WaitingToDownload Then OngoingFiles.Add(File) End If Next @@ -2056,7 +1869,7 @@ Retry: For Each File As NetFile In WaitingFiles If NetTaskThreadCount >= NetTaskThreadLimit Then Continue While '最大线程数检查 Dim NewThread = File.TryBeginThread() - If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(30) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） + If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(100) '减少 BMCLAPI 请求频率 Next '为进行中的文件追加线程 If Speed >= NetTaskSpeedLimitLow Then Continue While '下载速度足够，无需新增 @@ -2066,9 +1879,9 @@ Retry: Dim PreparingCount = 0, DownloadingCount = 0 If File.Threads IsNot Nothing Then For Each Thread As NetThread In File.Threads.ToList - If Thread.State < NetState.Download Then + If Thread.State < NetState.Downloading Then PreparingCount += 1 - ElseIf Thread.State = NetState.Download Then + ElseIf Thread.State = NetState.Downloading Then DownloadingCount += 1 End If Next @@ -2076,7 +1889,7 @@ Retry: '新增线程 If PreparingCount > DownloadingCount Then Continue For '准备中的线程已多于下载中的线程，不再新增 Dim NewThread = File.TryBeginThread() - If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(30) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） + If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(100) '减少 BMCLAPI 请求频率 Next End While Catch ex As Exception @@ -2088,83 +1901,68 @@ Retry: RunInNewThread( Sub() Try - Dim LastLoopTime As Long - NetTaskSpeedLimitLeftLast = GetTimeTick() + Dim NextTick As Long = GetTimeMs() While True - Dim TimeNow = GetTimeTick() - LastLoopTime = TimeNow '增加限速余量 - If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft = NetTaskSpeedLimitHigh / 1000 * (TimeNow - NetTaskSpeedLimitLeftLast) - NetTaskSpeedLimitLeftLast = TimeNow + If NetTaskSpeedLimitHigh > 0 Then Interlocked.Add(NetTaskSpeedLimitLeft, CLng(NetTaskSpeedLimitHigh / 10)) '刷新公开属性 RefreshStat() - '等待直至 80 ms - Do While GetTimeTick() - LastLoopTime < 80 - Thread.Sleep(10) - Loop + '等待 100 ms + NextTick += 100 + Dim SleepTime = NextTick - GetTimeMs() + If SleepTime > 0 Then + Thread.Sleep(SleepTime) + Else + NextTick = GetTimeMs() '超时，直接追帧，不等待 + End If End While Catch ex As Exception Log(ex, "下载管理刷新线程出错", LogLevel.Critical) End Try End Sub, "NetManager StatRefresher") End Sub - Private IsManagerStarted As Boolean = False - 'Public FileRemainList As New List(Of String) + Private DownloadCacheLock As New Object Private IsDownloadCacheCleared As Boolean = False ''' ''' 开始一个下载任务。 ''' - Public Sub Start(Task As LoaderDownload) + Public Function Start(Task As LoaderDownload) As List(Of NetFile) StartManager() '清理缓存 - If Not IsDownloadCacheCleared Then - Try - DeleteDirectory(PathTemp & "Download") - Catch ex As Exception - Log(ex, "清理下载缓存失败") - End Try - IsDownloadCacheCleared = True - End If - Directory.CreateDirectory(PathTemp & "Download") - '文件处理 - SyncLock LockFiles - '添加每个文件 - For i = 0 To Task.Files.Count - 1 - Dim File = Task.Files(i) - If Files.ContainsKey(File.LocalPath) Then - '已有该文件 - If Files(File.LocalPath).State >= NetState.Finish Then - '该文件已经下载过一次，且下载完成 - '将已下载的文件替换成当前文件，重新下载 - File.Tasks.Add(Task) - Files(File.LocalPath) = File - SyncLock LockRemain - FileRemain += 1 - If ModeDebug Then Log("[Download] " & File.LocalName & "：已替换列表，剩余文件 " & FileRemain) - 'FileRemainList.Add(File.LocalPath) - End SyncLock - Else - '该文件正在下载中 - '将当前文件替换成下载中的文件，即两个任务指向同一个文件 - File = Files(File.LocalPath) - File.Tasks.Add(Task) - End If - Else - '没有该文件 - File.Tasks.Add(Task) - Files.Add(File.LocalPath, File) - SyncLock LockRemain - FileRemain += 1 - If ModeDebug Then Log("[Download] " & File.LocalName & "：已加入列表，剩余文件 " & FileRemain) - 'FileRemainList.Add(File.LocalPath) - End SyncLock - End If - Task.Files(i) = File '回设 - Next + SyncLock DownloadCacheLock '防止同时开启多个下载任务时重复清理 + If Not IsDownloadCacheCleared Then + Try + Log("[Net] 开始清理下载缓存") + DeleteDirectory(PathTemp & "Download") + Log("[Net] 下载缓存已清理") + Catch ex As Exception + Log(ex, "清理下载缓存失败") + End Try + IsDownloadCacheCleared = True + End If End SyncLock + '添加每个文件 + Dim NewFiles As New List(Of NetFile) + For i = 0 To Task.Files.Count - 1 + Dim File As NetFile = Task.Files(i) + If AllFiles.ContainsKey(File.LocalPath) AndAlso AllFiles(File.LocalPath).State < NetState.Finished Then + '该文件正在被另一个任务下载 + If ModeDebug Then Log($"[Download] {File.LocalName}：无需开始，该文件已在下载中，目标 {File.LocalPath}") + File = AllFiles(File.LocalPath) '将列表中的文件替换成下载中的文件，即两个任务指向同一个文件；抛弃现在的 File 对象 + Task.Files(i) = File + Else + '常规情况（该文件可能已在其他任务中下载完成，但这并不影响） + If ModeDebug Then Log($"[Download] {File.LocalName}：开始，目标 {File.LocalPath}") + AllFiles(File.LocalPath) = File + NewFiles.Add(File) + Interlocked.Increment(FileRemain) + End If + File.Tasks.Add(Task) + Next Tasks.Add(Task) - End Sub + Return NewFiles + End Function End Class @@ -2172,13 +1970,110 @@ Retry: ''' 是否有正在进行中、需要在下载管理页面显示的下载任务？ ''' Public Function HasDownloadingTask(Optional IgnoreCustomDownload As Boolean = False) As Boolean - For Each Task In LoaderTaskbar.ToList() - If (Task.Show AndAlso Task.State = LoadState.Loading) AndAlso - (Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载")) Then - Return True - End If - Next - Return False + Return LoaderTaskbar.Any( + Function(Task) Task.Show AndAlso Task.State = LoadState.Loading AndAlso + (Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载"))) End Function +#End Region + +#Region "端口" + + ''' + ''' 随机获取单个可用的端口。 + ''' + Public Function FindFreePort() As Integer + Dim Listener As New TcpListener(IPAddress.Loopback, 0) + Listener.Start() + Dim port As Integer = CType(Listener.LocalEndpoint, IPEndPoint).Port + Listener.Stop() + Return port + End Function + + ''' + ''' 获取当前已被占用的端口列表。 + ''' + Public Function GetUsedPorts() As List(Of Integer) + Dim IPProperties = NetworkInformation.IPGlobalProperties.GetIPGlobalProperties() + Dim UsedPorts As New List(Of Integer) + UsedPorts.AddRange(IPProperties.GetActiveTcpListeners().Select(Function(ep) ep.Port)) + UsedPorts.AddRange(IPProperties.GetActiveUdpListeners().Select(Function(ep) ep.Port)) + UsedPorts.AddRange(IPProperties.GetActiveTcpConnections().Select(Function(conn) conn.LocalEndPoint.Port)) + Return UsedPorts.Distinct().ToList() + End Function + + ''' + ''' 寻找数个连续编号的可用端口。 + ''' + Public Function FindFreePorts(ConsecutiveCount As Integer, ParamArray ExtraBlackLists As Integer()) As List(Of Integer) + Dim UsedPorts = GetUsedPorts().Concat(ExtraBlackLists) + For port = 12000 + RandomInteger(0, 1000) To 65000 - ConsecutiveCount + Dim Range = Enumerable.Range(port, ConsecutiveCount) + If Not Range.Any(Function(p) UsedPorts.Contains(p)) Then Return Range.ToList + Next + Throw New Exception("未能找到可用的端口！") + End Function + +#End Region + + ''' + ''' 测试 Ping。失败则返回 -1。 + ''' + Public Function Ping(Ip As String, Optional Timeout As Integer = 10000, Optional MakeLog As Boolean = True) As Integer + Dim PingResult As NetworkInformation.PingReply + Try + PingResult = (New NetworkInformation.Ping).Send(Ip) + Catch ex As Exception + If MakeLog Then Log("[Net] Ping " & Ip & " 失败：" & ex.Message) + Return -1 + End Try + If PingResult.Status = NetworkInformation.IPStatus.Success Then + If MakeLog Then Log("[Net] Ping " & Ip & " 结束：" & PingResult.RoundtripTime & "ms") + Return PingResult.RoundtripTime + Else + If MakeLog Then Log("[Net] Ping " & Ip & " 失败") + Return -1 + End If + End Function + + ''' + ''' 判断某个 Exception 是否为网络问题所导致。 + ''' + Public Function IsNetworkRelated(Ex As Exception) As Boolean + '提取 Message（不能用 GetDetail，因为堆栈的方法参数中就有 timeout 字样） + Dim Detail As String = "" + Dim InnerEx As Exception = Ex + Detail += InnerEx.Message + Do Until InnerEx.InnerException Is Nothing + InnerEx = InnerEx.InnerException + Detail += InnerEx.Message + Loop + '判断 + If Detail.Contains("(403)") Then Return False + Return { + "(408)", "超时", "timeout", "网络请求失败", "连接尝试失败", "远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", + "由于目标计算机积极拒绝", "基础连接已经关闭" + }.Any(Function(k) Detail.ContainsF(k, True)) + End Function + + ''' + ''' 设置是否应当在正版登录时校验 SSL 证书。 + ''' + Public Sub ShouldValidateSslCertificateOnLogin(Enabled As Boolean) + ServicePointManager.ServerCertificateValidationCallback = + Function(Sender, Certificate, Chain, Failure) + Dim Request As HttpWebRequest = TryCast(Sender, HttpWebRequest) + If Failure = Net.Security.SslPolicyErrors.None Then Return True '已通过验证 + '基于 #3018 和 #5879，只在访问正版登录 API 时跳过证书验证 + Log($"[System] 未通过 SSL 证书验证（{Failure}），提供的证书为 {Certificate?.Subject}，URL：{Request?.Address}", LogLevel.Debug) + If Request Is Nothing Then + Return Not Enabled + ElseIf Request.Address.Host.Contains("xboxlive") OrElse Request.Address.Host.Contains("minecraftservices") Then + Return Not Enabled '根据设置决定是否忽略错误 + Else + Return False + End If + End Function + End Sub + End Module diff --git a/Plain Craft Launcher 2/Modules/Base/ModValidate.vb b/Plain Craft Launcher 2/Modules/Base/ModValidate.vb index 55eaff9..7a5f35e 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModValidate.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModValidate.vb @@ -114,10 +114,10 @@ Public Class ValidateInteger End Sub Public Overrides Function Validate(Str As String) As String If Str.Length > 9 Then Return "请输入一个大小合理的数字！" - Dim Valed As Integer = Val(Str) - If Valed.ToString <> Str Then Return "请输入一个整数！" - If Val(Str) > Max Then Return "不可超过 " & Max & "！" - If Val(Str) < Min Then Return "不可低于 " & Min & "！" + Dim Valed As Integer + If Not Integer.TryParse(Str, Valed) Then Return "请输入一个整数！" + If Valed > Max Then Return "不可超过 " & Max & "！" + If Valed < Min Then Return "不可低于 " & Min & "！" Return "" End Function End Class @@ -148,7 +148,7 @@ End Class ''' Public Class ValidateExcept Inherits Validate - Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) + Public Property Excepts As New ObjectModel.Collection(Of String) Public Property ErrorMessage As String Public Sub New() ErrorMessage = "输入内容不能包含 %" @@ -157,12 +157,15 @@ Public Class ValidateExcept Me.Excepts = Excepts Me.ErrorMessage = ErrorMessage End Sub - Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能包含 %") - Me.Excepts = New ObjectModel.Collection(Of String) - Me.ErrorMessage = ErrorMessage - For Each Data As String In Excepts - Me.Excepts.Add(Data) - Next + Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能包含 %") + Me.New( + New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)), + ErrorMessage) + End Sub + Public Sub New(Excepts As IEnumerable(Of Char), Optional ErrorMessage As String = "输入内容不能包含 %") + Me.New( + New ObjectModel.Collection(Of String)(Excepts.Select(Function(c) c.ToString).ToList), + ErrorMessage) End Sub Public Overrides Function Validate(Str As String) As String For Each Ch As String In Excepts @@ -181,7 +184,7 @@ End Class ''' Public Class ValidateExceptSame Inherits Validate - Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) + Public Property Excepts As New ObjectModel.Collection(Of String) Public Property ErrorMessage As String Public Property IgnoreCase As Boolean = False Public Sub New() @@ -191,19 +194,21 @@ Public Class ValidateExceptSame Me.ErrorMessage = ErrorMessage Me.IgnoreCase = IgnoreCase End Sub - Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) - Me.Excepts = New ObjectModel.Collection(Of String) - For Each Data As String In Excepts - Me.Excepts.Add(Data) - Next - Me.ErrorMessage = ErrorMessage - Me.IgnoreCase = IgnoreCase + Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) + Me.New( + New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)), + ErrorMessage, IgnoreCase) + End Sub + Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) + Me.New( + New ObjectModel.Collection(Of String) From {Except}, + ErrorMessage, IgnoreCase) End Sub Public Overrides Function Validate(Str As String) As String If Str Is Nothing Then Return ErrorMessage.Replace("%", "null") For Each Ch As String In Excepts If IgnoreCase Then - If Str.ToLower = Ch.ToLower Then Return ErrorMessage.Replace("%", Ch) + If Str.Lower = Ch.Lower Then Return ErrorMessage.Replace("%", Ch) Else If Str.Equals(Ch) Then Return ErrorMessage.Replace("%", Ch) '使用 = 不确定是否会忽略大小写 End If @@ -213,6 +218,27 @@ Public Class ValidateExceptSame End Class +''' +''' 必须为特定字符串。 +''' +Public Class ValidateSame + Inherits Validate + Public Property Required As String + Public Property ErrorMessage As String + Public Property IgnoreCase As Boolean = False + Public Sub New() + End Sub + Public Sub New(Required As String, Optional ErrorMessage As String = "输入内容有误", Optional IgnoreCase As Boolean = False) + Me.Required = Required + Me.ErrorMessage = ErrorMessage + Me.IgnoreCase = IgnoreCase + End Sub + Public Overrides Function Validate(Str As String) As String + Return If(String.Compare(Str, Required, IgnoreCase) = 0, "", ErrorMessage) + End Function + +End Class + ''' ''' 对文件夹名的粗略的特化检测。 ''' @@ -350,7 +376,7 @@ Public Class ValidateFolderPath '检查开头 If Str.StartsWithF("\\Mac\") Then GoTo Fin For Each Drive As DriveInfo In My.Computer.FileSystem.Drives - If Str.ToUpper = Drive.Name Then Return "" + If Str.Upper = Drive.Name Then Return "" If Str.StartsWithF(Drive.Name, True) Then GoTo Fin Next Return "文件夹路径头存在错误！" diff --git a/Plain Craft Launcher 2/Modules/Base/MyBitmap.vb b/Plain Craft Launcher 2/Modules/Base/MyBitmap.vb index c5303d6..dce0cce 100644 --- a/Plain Craft Launcher 2/Modules/Base/MyBitmap.vb +++ b/Plain Craft Launcher 2/Modules/Base/MyBitmap.vb @@ -4,11 +4,6 @@ Imports System.Drawing.Imaging Public Class MyBitmap - ''' - ''' 位图缓存。 - ''' - Public Shared BitmapCache As New Concurrent.ConcurrentDictionary(Of String, MyBitmap) - ''' ''' 存储的图片 ''' @@ -30,14 +25,17 @@ Public Class MyBitmap End Operator Public Shared Widening Operator CType(Image As MyBitmap) As ImageSource If Image Is Nothing Then Return Nothing - Dim Bitmap = Image.Pic - Dim rect = New System.Drawing.Rectangle(0, 0, Bitmap.Width, Bitmap.Height) - Dim bitmapData = Bitmap.LockBits(rect, ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb) + Dim BitmapPic As System.Drawing.Bitmap = Image.Pic + Dim rect = New System.Drawing.Rectangle(0, 0, BitmapPic.Width, BitmapPic.Height) + Dim bitmapData = BitmapPic.LockBits(rect, ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb) Try - Dim size = rect.Width * rect.Height * 4 - Return BitmapSource.Create(Bitmap.Width, Bitmap.Height, Bitmap.HorizontalResolution, Bitmap.VerticalResolution, PixelFormats.Bgra32, Nothing, bitmapData.Scan0, size, bitmapData.Stride) + Dim Result = BitmapSource.Create(BitmapPic.Width, BitmapPic.Height, BitmapPic.HorizontalResolution, BitmapPic.VerticalResolution, + PixelFormats.Bgra32, Nothing, bitmapData.Scan0, + rect.Width * rect.Height * 4, bitmapData.Stride) + Result.Freeze() + Return Result Finally - Bitmap.UnlockBits(bitmapData) + BitmapPic.UnlockBits(bitmapData) End Try End Operator Public Shared Widening Operator CType(Image As System.Drawing.Bitmap) As MyBitmap @@ -65,15 +63,16 @@ Public Class MyBitmap FilePathOrResourceName = FilePathOrResourceName.Replace("pack://application:,,,/images/", PathImage) If FilePathOrResourceName.StartsWithF(PathImage) Then '使用缓存 - If BitmapCache.ContainsKey(FilePathOrResourceName) Then - Pic = BitmapCache(FilePathOrResourceName).Pic + Static Cache As New Concurrent.ConcurrentDictionary(Of String, MyBitmap) + If Cache.ContainsKey(FilePathOrResourceName) Then + Pic = Cache(FilePathOrResourceName).Pic Else Pic = New MyBitmap(CType((New ImageSourceConverter).ConvertFromString(FilePathOrResourceName), ImageSource)) - BitmapCache.TryAdd(FilePathOrResourceName, Pic) + Cache.TryAdd(FilePathOrResourceName, Pic) End If Else '使用这种自己接管 FileStream 的方法加载才能解除文件占用 - Using InputStream As New FileStream(FilePathOrResourceName, FileMode.Open) + Using InputStream As New FileStream(FilePathOrResourceName, FileMode.Open, FileAccess.Read, FileShare.Read) '判断是否为 WebP 文件头 Dim Header(1) As Byte InputStream.Read(Header, 0, 2) @@ -92,7 +91,11 @@ Public Class MyBitmap Pic = My.Application.TryFindResource(FilePathOrResourceName) If Pic Is Nothing Then Pic = New System.Drawing.Bitmap(1, 1) - Throw New Exception($"加载 MyBitmap 失败（{FilePathOrResourceName}）", ex) + If TypeOf ex Is ArgumentException Then + Throw New Exception($"图片格式不支持，或图片文件损坏（{FilePathOrResourceName}）", ex) + Else + Throw New Exception($"加载 MyBitmap 意外失败（{FilePathOrResourceName}）", ex) + End If Else Log(ex, $"指定类型有误的 MyBitmap 加载（{FilePathOrResourceName}）", LogLevel.Developer) Exit Try diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb index 08d07aa..481c3ba 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb @@ -1,35 +1,40 @@ -Public Module ModComp +Imports System.IO.Compression - Public Enum CompType - ''' - ''' 允许任意种类，或种类未知。 - ''' - Any = -1 +Public Module ModComp + + Public Enum CompType ''' ''' Mod。 ''' - [Mod] = 0 + [Mod] = 1 ''' ''' 整合包。 ''' - ModPack = 1 + ModPack = 2 ''' ''' 资源包。 ''' - ResourcePack = 2 + ResourcePack = 4 ''' ''' 光影包。 ''' - Shader = 3 + Shader = 8 ''' - ''' CurseForge：数据包。 - ''' Modrinth：数据包，或数据包与 Mod 的混合。 + ''' 数据包。 ''' - DataPack = 4 + DataPack = 16 ''' ''' 服务端插件。 ''' - Plugin = 5 + Plugin = 32 + ''' + ''' 同时包含数据包以及 Mod。 + ''' + ModOrDataPack = [Mod] Or DataPack + ''' + ''' 允许任意种类，或种类未知。 + ''' + Any = [Mod] Or ModPack Or ResourcePack Or Shader Or DataPack Or Plugin End Enum Public Enum CompModLoaderType 'https://docs.curseforge.com/?http#tocS_ModLoaderType @@ -48,43 +53,46 @@ #Region "CompDatabase | Mod 数据库" - Private _CompDatabase As List(Of CompDatabaseEntry) = Nothing Private ReadOnly Property CompDatabase As List(Of CompDatabaseEntry) Get + Static _CompDatabase As List(Of CompDatabaseEntry) = Nothing If _CompDatabase IsNot Nothing Then Return _CompDatabase '初始化数据库 _CompDatabase = New List(Of CompDatabaseEntry) Dim i As Integer = 0 - For Each Line In DecodeBytes(GetResources("ModData")).Replace(vbCrLf, vbLf).Replace(vbCr, "").Split(vbLf) - i += 1 - If Line = "" Then Continue For - For Each EntryData As String In Line.Split("¨") - Dim Entry = New CompDatabaseEntry - Dim SplitedLine = EntryData.Split("|") - If SplitedLine(0).StartsWithF("@") Then - Entry.CurseForgeSlug = Nothing - Entry.ModrinthSlug = SplitedLine(0).Replace("@", "") - ElseIf SplitedLine(0).EndsWithF("@") Then - Entry.CurseForgeSlug = SplitedLine(0).TrimEnd("@") - Entry.ModrinthSlug = Entry.CurseForgeSlug - ElseIf SplitedLine(0).Contains("@") Then - Entry.CurseForgeSlug = SplitedLine(0).Split("@")(0) - Entry.ModrinthSlug = SplitedLine(0).Split("@")(1) - Else - Entry.CurseForgeSlug = SplitedLine(0) - Entry.ModrinthSlug = Nothing - End If - Entry.WikiId = i - If SplitedLine.Count >= 2 Then - Entry.ChineseName = SplitedLine(1) - If Entry.ChineseName.Contains("*") Then '处理 * - Entry.ChineseName = Entry.ChineseName.Replace("*", - $" ({If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Replace("-", " ").Capitalize})") + Using Archive As New ZipArchive(New MemoryStream(GetResources("ModData")), ZipArchiveMode.Read) + For Each Line In ReadFile(Archive.GetEntry("moddata.txt").Open(), Encoding.UTF8).Replace(vbCrLf, vbLf).Replace(vbCr, "").Split(vbLf) + i += 1 + If Line = "" Then Continue For + For Each EntryData As String In Line.Split("¨") + Dim Entry = New CompDatabaseEntry + Dim Splited = EntryData.Split("|") + Entry.Popularity = Val(Splited(0)) + If Splited(1).StartsWithF("@") Then + Entry.CurseForgeSlug = Nothing + Entry.ModrinthSlug = Splited(1).Replace("@", "") + ElseIf Splited(1).EndsWithF("@") Then + Entry.CurseForgeSlug = Splited(1).TrimEnd("@") + Entry.ModrinthSlug = Entry.CurseForgeSlug + ElseIf Splited(1).Contains("@") Then + Entry.CurseForgeSlug = Splited(1).Split("@")(0) + Entry.ModrinthSlug = Splited(1).Split("@")(1) + Else + Entry.CurseForgeSlug = Splited(1) + Entry.ModrinthSlug = Nothing End If - End If - _CompDatabase.Add(Entry) + Entry.WikiId = i + If Splited.Count >= 3 Then + Entry.ChineseName = Splited.Last + If Entry.ChineseName.Contains("*") Then '处理 * + Entry.ChineseName = Entry.ChineseName.Replace("*", + $" ({If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Replace("-", " ").Capitalize})") + End If + End If + _CompDatabase.Add(Entry) + Next Next - Next + End Using Return _CompDatabase End Get End Property @@ -106,9 +114,13 @@ ''' Modrinth Slug（例如 advanced-solar-panels）。 ''' Public ModrinthSlug As String = Nothing + ''' + ''' MC 百科的浏览量逆序排行，1 代表浏览量最低。 + ''' + Public Popularity As Integer Public Overrides Function ToString() As String - Return If(CurseForgeSlug, "") & "&" & If(ModrinthSlug, "") & "|" & WikiId & "|" & ChineseName + Return If(CurseForgeSlug, "") & "&" & If(ModrinthSlug, "") & "|" & WikiId & "|" & ChineseName & ", Rank " & Popularity End Function End Class @@ -127,10 +139,10 @@ ''' Public ReadOnly FromCurseForge As Boolean ''' - ''' 工程的种类。 - ''' 由于 Modrinth 混合使用 Mod 和数据包，结果不一定准确。 + ''' 工程中包含的文件种类。 + ''' 若为 Modrinth 工程，可能为 Mod 或 数据包。 ''' - Public ReadOnly Type As CompType + Public ReadOnly Types As CompType ''' ''' 工程的短名。例如 technical-enchant。 ''' @@ -161,9 +173,9 @@ ''' Public ReadOnly Website As String ''' - ''' 最后一次更新的时间。可能为 Nothing。 + ''' 最后一次更新的时间。 ''' - Public ReadOnly LastUpdate As Date? = Nothing + Public ReadOnly LastUpdate As Date ''' ''' 下载量计数。注意，该计数仅为一个来源，无法反应两边加起来的下载量！ ''' @@ -177,13 +189,21 @@ ''' Public ReadOnly Tags As List(Of String) ''' - ''' Logo 图片的下载地址。若为 Nothing 则没有。 + ''' Logo 图片的下载地址。 + ''' 若为 Nothing 则没有，保证不为空字符串。 ''' Public LogoUrl As String = Nothing ''' - ''' 游戏大版本列表。例如：18, 16, 15…… + ''' 支持的 Drop 编号，从高到低排序，不为 Nothing。 + ''' 例如：261（26.1.x）、180（1.18.x）。 ''' - Public ReadOnly GameVersions As List(Of Integer) + Public ReadOnly Drops As List(Of Integer) + ''' + ''' Modrinth API 返回的原始版本列表。 + ''' 仅用于 Modrinth 工程的二次筛选，不会被缓存，不会被预处理。 + ''' 若非从 Modrinth 获取则为 Nothing。 + ''' + Public ReadOnly UnsafeGameVersions As List(Of String) '数据库信息 @@ -196,7 +216,7 @@ Get If Not LoadedDatabase Then LoadedDatabase = True - If Type = CompType.Mod OrElse Type = CompType.DataPack Then + If Types.HasFlag(CompType.Mod) OrElse Types.HasFlag(CompType.DataPack) Then _DatabaseEntry = CompDatabase.FirstOrDefault(Function(c) If(FromCurseForge, c.CurseForgeSlug, c.ModrinthSlug) = Slug) End If End If @@ -233,14 +253,14 @@ If Data.ContainsKey("Tags") Then #Region "CompJson" FromCurseForge = Data("DataSource") = "CurseForge" - Type = Data("Type").ToObject(Of Integer) + Types = Data("Types").ToObject(Of Integer) Slug = Data("Slug") Id = Data("Id") If Data.ContainsKey("CurseForgeFileIds") Then CurseForgeFileIds = CType(Data("CurseForgeFileIds"), JArray).Select(Function(t) t.ToObject(Of Integer)).ToList RawName = Data("RawName") Description = Data("Description") Website = Data("Website") - If Data.ContainsKey("LastUpdate") Then LastUpdate = Data("LastUpdate") + LastUpdate = Data("LastUpdate") DownloadCount = Data("DownloadCount") If Data.ContainsKey("ModLoaders") Then ModLoaders = CType(Data("ModLoaders"), JArray).Select(Function(t) CType(t.ToObject(Of Integer), CompModLoaderType)).ToList @@ -249,10 +269,10 @@ End If Tags = CType(Data("Tags"), JArray).Select(Function(t) t.ToString).ToList If Data.ContainsKey("LogoUrl") Then LogoUrl = Data("LogoUrl") - If Data.ContainsKey("GameVersions") Then - GameVersions = CType(Data("GameVersions"), JArray).Select(Function(t) t.ToObject(Of Integer)).ToList + If Data.ContainsKey("Drops") Then + Drops = CType(Data("Drops"), JArray).Select(Function(t) t.ToObject(Of Integer)).ToList Else - GameVersions = New List(Of Integer) + Drops = New List(Of Integer) End If #End Region Else @@ -274,39 +294,39 @@ LogoUrl = Data("logo")("thumbnailUrl") End If End If + If LogoUrl = "" Then LogoUrl = Nothing 'Type If Website.Contains("/mc-mods/") OrElse Website.Contains("/mod/") Then - Type = CompType.Mod + Types = CompType.Mod ElseIf Website.Contains("/modpacks/") Then - Type = CompType.ModPack + Types = CompType.ModPack ElseIf Website.Contains("/resourcepacks/") Then - Type = CompType.ResourcePack + Types = CompType.ResourcePack ElseIf Website.Contains("/texture-packs/") Then - Type = CompType.ResourcePack + Types = CompType.ResourcePack ElseIf Website.Contains("/shaders/") Then - Type = CompType.Shader + Types = CompType.Shader Else - Type = CompType.DataPack + Types = CompType.DataPack End If - 'FileIndexes / GameVersions / ModLoaders + 'FileIndexes / VanillaMajorVersions / ModLoaders ModLoaders = New List(Of CompModLoaderType) Dim Files As New List(Of KeyValuePair(Of Integer, List(Of String))) 'FileId, GameVersions For Each File In If(Data("latestFiles"), New JArray) - Dim NewFile As New CompFile(File, Type) + Dim NewFile As New CompFile(File, Types) If Not NewFile.Available Then Continue For ModLoaders.AddRange(NewFile.ModLoaders) Dim GameVersions = File("gameVersions").ToObject(Of List(Of String)) - If Not GameVersions.Any(Function(v) v.StartsWithF("1.")) Then Continue For + If Not GameVersions.Any(Function(v) McVersion.IsFormatFit(v)) Then Continue For Files.Add(New KeyValuePair(Of Integer, List(Of String))(File("id"), GameVersions)) Next For Each File In If(Data("latestFilesIndexes"), New JArray) '这俩玩意儿包含的文件不一样，见 #3599 - If Not File("gameVersion").ToString.StartsWithF("1.") Then Continue For + If Not McVersion.IsFormatFit(File("gameVersion")) Then Continue For Files.Add(New KeyValuePair(Of Integer, List(Of String))(File("fileId"), {File("gameVersion").ToString}.ToList)) Next CurseForgeFileIds = Files.Select(Function(f) f.Key).Distinct.ToList - GameVersions = Files.SelectMany(Function(f) f.Value).Where(Function(v) v.StartsWithF("1.")). - Select(Function(v) CInt(Val(v.Split(".")(1).BeforeFirst("-")))).Where(Function(v) v > 0). - Distinct.OrderByDescending(Function(v) v).ToList + Drops = Files.SelectMany(Function(f) f.Value). + Select(Function(v) McVersion.VersionToDrop(v)).Where(Function(v) v <> 209).Distinct.OrderByDescending(Function(v) v).ToList ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList 'Tags Tags = New List(Of String) @@ -333,6 +353,8 @@ Case 424 : Tags.Add("装饰") Case 411 : Tags.Add("生物") Case 434 : Tags.Add("装备") + Case 6814 : Tags.Add("性能优化") + Case 9026 : Tags.Add("创造模式") Case 423 : Tags.Add("信息显示") Case 435 : Tags.Add("服务器") Case 5191 : Tags.Add("改良") @@ -347,7 +369,7 @@ Case 4475 : Tags.Add("冒险") Case 4476 : Tags.Add("探索") Case 4477 : Tags.Add("小游戏") - Case 4471 : Tags.Add("科幻") + Case 4474 : Tags.Add("科幻") Case 4736 : Tags.Add("空岛") Case 5128 : Tags.Add("原版改良") Case 4487 : Tags.Add("FTB") @@ -392,23 +414,21 @@ Slug = Data("slug") RawName = Data("title") Description = Data("description") - LastUpdate = Data("date_modified") + LastUpdate = If(Data("date_modified"), Data("updated")) DownloadCount = Data("downloads") LogoUrl = Data("icon_url") If LogoUrl = "" Then LogoUrl = Nothing Website = $"https://modrinth.com/{Data("project_type")}/{Slug}" 'GameVersions '搜索结果的键为 versions，获取特定工程的键为 game_versions - GameVersions = If(CType(If(Data("game_versions"), Data("versions")), JArray), New JArray). - Select(Function(v) v.ToString).Where(Function(v) v.StartsWithF("1.")). - Select(Of Integer)(Function(v) Val(v.Split(".")(1).BeforeFirst("-"))).Where(Function(v) v > 0). - Distinct.OrderByDescending(Function(v) v).ToList + UnsafeGameVersions = If(CType(If(Data("game_versions"), Data("versions")), JArray), New JArray).Select(Function(v) v.ToString).Distinct.ToList + Drops = UnsafeGameVersions.Select(Function(v) McVersion.VersionToDrop(v)).Where(Function(v) v <> 209).Distinct.OrderByDescending(Function(v) v).ToList 'Type Select Case Data("project_type").ToString - Case "modpack" : Type = CompType.ModPack - Case "resourcepack" : Type = CompType.ResourcePack - Case "shader" : Type = CompType.Shader - Case Else : Type = CompType.Mod 'Modrinth 将数据包标为 Mod + Case "modpack" : Types = CompType.ModPack + Case "resourcepack" : Types = CompType.ResourcePack + Case "shader" : Types = CompType.Shader + Case Else : Types = CompType.Mod 'Modrinth 将数据包标为 Mod，但 categories 字段里有 datapack End Select 'Tags & ModLoaders Tags = New List(Of String) @@ -430,7 +450,7 @@ Case "fabric" : ModLoaders.Add(CompModLoaderType.Fabric) Case "quilt" : ModLoaders.Add(CompModLoaderType.Quilt) Case "neoforge" : ModLoaders.Add(CompModLoaderType.NeoForge) - Case "datapack" : Type = CompType.DataPack '若包含数据包版本，则优先标为 DataPack + Case "datapack" : Types = CompType.DataPack '共用 Case "technology" : Tags.Add("科技") Case "magic" : Tags.Add("魔法") @@ -445,9 +465,9 @@ Case "game-mechanics" : Tags.Add("游戏机制") Case "transportation" : Tags.Add("运输") Case "storage" : Tags.Add("仓储") - Case "decoration" : If Type <> CompType.ResourcePack Then Tags.Add("装饰") - Case "mobs" : If Type <> CompType.ResourcePack Then Tags.Add("生物") - Case "equipment" : If Type <> CompType.ResourcePack Then Tags.Add("装备") + Case "decoration" : If Types <> CompType.ResourcePack Then Tags.Add("装饰") + Case "mobs" : If Types <> CompType.ResourcePack Then Tags.Add("生物") + Case "equipment" : If Types <> CompType.ResourcePack Then Tags.Add("装备") Case "social" : Tags.Add("服务器") Case "library" : Tags.Add("支持库") '整合包 @@ -497,6 +517,7 @@ Case "vanilla" : Tags.Add("原版可用") End Select Next + If Types = CompType.DataPack AndAlso ModLoaders.Any Then Types = CompType.DataPack Or CompType.Mod #End Region End If If Not Tags.Any() Then Tags.Add("其他") @@ -512,77 +533,79 @@ Public Function ToJson() As JObject Dim Json As New JObject Json("DataSource") = If(FromCurseForge, "CurseForge", "Modrinth") - Json("Type") = CInt(Type) + Json("Types") = CInt(Types) Json("Slug") = Slug Json("Id") = Id If CurseForgeFileIds IsNot Nothing Then Json("CurseForgeFileIds") = New JArray(CurseForgeFileIds) Json("RawName") = RawName Json("Description") = Description Json("Website") = Website - If LastUpdate IsNot Nothing Then Json("LastUpdate") = LastUpdate + Json("LastUpdate") = LastUpdate 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 Not String.IsNullOrEmpty(LogoUrl) Then Json("LogoUrl") = LogoUrl - If GameVersions.Any Then Json("GameVersions") = New JArray(GameVersions) + If LogoUrl IsNot Nothing Then Json("LogoUrl") = LogoUrl + If Drops.Any Then Json("Drops") = New JArray(Drops) Json("CacheTime") = Date.Now '用于检查缓存时间 Return Json End Function ''' ''' 将当前工程信息实例化为控件。 ''' - Public Function ToCompItem(ShowMcVersionDesc As Boolean, ShowLoaderDesc As Boolean) As MyCompItem + Public Function ToCompItem(ShowMcVersionDesc As Boolean, ShowLoaderDesc As Boolean) As MyVirtualizingElement(Of MyCompItem) '获取版本描述 Dim GameVersionDescription As String - If GameVersions Is Nothing OrElse Not GameVersions.Any() Then + If Drops Is Nothing OrElse Not Drops.Any() Then GameVersionDescription = "仅快照版本" '#5412 Else - Dim SpaVersions As New List(Of String) + Dim Segments As New List(Of String) Dim IsOld As Boolean = False - For i = 0 To GameVersions.Count - 1 '版本号一定为降序 + For i = 0 To Drops.Count - 1 '版本号一定为降序 '获取当前连续的版本号段 - Dim StartVersion As Integer = GameVersions(i), EndVersion As Integer = GameVersions(i) - If StartVersion < 10 Then '如果支持新版本，则不显示 1.9- - If SpaVersions.Any() AndAlso Not IsOld Then + Dim StartDrop As Integer = Drops(i), EndDrop As Integer = Drops(i) + If StartDrop < 120 Then '如果支持新版本，则不显示 1.11- + If Segments.Any() AndAlso Not IsOld Then Exit For Else IsOld = True End If End If - For ii = i + 1 To GameVersions.Count - 1 - If GameVersions(ii) <> EndVersion - 1 Then Exit For - EndVersion = GameVersions(ii) + For ii = i + 1 To Drops.Count - 1 + If AllDrops Is Nothing OrElse AllDrops.IndexOf(Drops(ii)) <> AllDrops.IndexOf(EndDrop) + 1 Then Exit For + EndDrop = Drops(ii) i = ii Next '将版本号段转为描述文本 - If StartVersion = EndVersion Then - SpaVersions.Add("1." & StartVersion) - ElseIf McVersionHighest > -1 AndAlso StartVersion >= McVersionHighest Then - If EndVersion < 10 Then - SpaVersions.Clear() - SpaVersions.Add("全版本") + Dim StartName = McVersion.DropToVersion(StartDrop) + Dim EndName = McVersion.DropToVersion(EndDrop) + If StartDrop = EndDrop Then + Segments.Add(StartName) + ElseIf AllDrops IsNot Nothing AndAlso StartDrop >= AllDrops.First Then + If EndDrop < 120 Then + Segments.Clear() + Segments.Add("全版本") Exit For Else - SpaVersions.Add("1." & EndVersion & "+") + Segments.Add(EndName & "+") End If - ElseIf EndVersion < 10 Then - SpaVersions.Add("1." & StartVersion & "-") + ElseIf EndDrop < 120 Then + Segments.Add(StartName & "-") Exit For - ElseIf StartVersion - EndVersion = 1 Then - SpaVersions.Add("1." & StartVersion & ", 1." & EndVersion) + ElseIf AllDrops Is Nothing OrElse AllDrops.IndexOf(EndDrop) - AllDrops.IndexOf(StartDrop) = 1 Then + Segments.Add(StartName & ", " & EndName) Else - SpaVersions.Add("1." & StartVersion & "~1." & EndVersion) + Segments.Add(StartName & "~" & EndName) End If Next - GameVersionDescription = SpaVersions.Join(", ") + GameVersionDescription = Segments.Join(", ") End If '获取 Mod 加载器描述 Dim ModLoaderDescriptionFull As String, ModLoaderDescriptionPart As String Dim ModLoadersForDesc As New List(Of CompModLoaderType)(ModLoaders) - If Setup.Get("ToolDownloadIgnoreQuilt") Then ModLoadersForDesc.Remove(CompModLoaderType.Quilt) + If Settings.Get("ToolDownloadIgnoreQuilt") Then ModLoadersForDesc.Remove(CompModLoaderType.Quilt) Select Case ModLoadersForDesc.Count Case 0 - If ModLoaders.Count = 1 Then + If ModLoaders.IsSingle Then ModLoaderDescriptionFull = "仅 " & ModLoaders.Single.ToString ModLoaderDescriptionPart = ModLoaders.Single.ToString Else @@ -593,11 +616,11 @@ ModLoaderDescriptionFull = "仅 " & ModLoadersForDesc.Single.ToString ModLoaderDescriptionPart = ModLoadersForDesc.Single.ToString Case Else - Dim MaxVersion As Integer = If(GameVersions.Any, GameVersions.Max, 99) + Dim NewestDrop As Integer = If(Drops.Any, Drops.First, 9999) If ModLoaders.Contains(CompModLoaderType.Forge) AndAlso - (MaxVersion < 14 OrElse ModLoaders.Contains(CompModLoaderType.Fabric)) AndAlso - (MaxVersion < 20 OrElse ModLoaders.Contains(CompModLoaderType.NeoForge)) AndAlso - (MaxVersion < 14 OrElse ModLoaders.Contains(CompModLoaderType.Quilt) OrElse Setup.Get("ToolDownloadIgnoreQuilt")) Then + (NewestDrop < 140 OrElse ModLoaders.Contains(CompModLoaderType.Fabric)) AndAlso + (NewestDrop < 200 OrElse ModLoaders.Contains(CompModLoaderType.NeoForge)) AndAlso + (NewestDrop < 140 OrElse ModLoaders.Contains(CompModLoaderType.Quilt) OrElse Settings.Get("ToolDownloadIgnoreQuilt")) Then ModLoaderDescriptionFull = "任意" ModLoaderDescriptionPart = "" Else @@ -606,56 +629,54 @@ End If End Select '实例化 UI - Dim NewItem As New MyCompItem With {.Tag = Me, .Logo = GetControlLogo()} - Dim Title = GetControlTitle(True) - NewItem.Title = Title.Key - If Title.Value = "" Then - CType(NewItem.LabTitleRaw.Parent, StackPanel).Children.Remove(NewItem.LabTitleRaw) - Else - NewItem.SubTitle = Title.Value - End If - NewItem.Tags = Tags - NewItem.Description = Description.Replace(vbCr, "").Replace(vbLf, "") - '下边栏 - If Not ShowMcVersionDesc AndAlso Not ShowLoaderDesc Then - '全部隐藏 - CType(NewItem.PathVersion.Parent, Grid).Children.Remove(NewItem.PathVersion) - CType(NewItem.LabVersion.Parent, Grid).Children.Remove(NewItem.LabVersion) - NewItem.ColumnVersion1.Width = New GridLength(0) - NewItem.ColumnVersion2.MaxWidth = 0 - NewItem.ColumnVersion3.Width = New GridLength(0) - ElseIf ShowMcVersionDesc AndAlso ShowLoaderDesc Then - '全部显示 - NewItem.LabVersion.Text = If(ModLoaderDescriptionPart = "", "", ModLoaderDescriptionPart & " ") & GameVersionDescription - ElseIf ShowMcVersionDesc Then - '仅显示版本 - NewItem.LabVersion.Text = GameVersionDescription - Else - '仅显示 Mod 加载器 - NewItem.LabVersion.Text = ModLoaderDescriptionFull - End If - NewItem.LabSource.Text = If(FromCurseForge, "CurseForge", "Modrinth") - If LastUpdate IsNot Nothing Then + Return New MyVirtualizingElement(Of MyCompItem)( + Function() + Dim NewItem As New MyCompItem With {.Tag = Me} + ApplyLogoToMyImage(NewItem.PathLogo) + Dim Titles = GetControlTitle(True) + NewItem.Title = Titles.Title + If Titles.SubTitle = "" Then + CType(NewItem.LabTitleRaw.Parent, StackPanel).Children.Remove(NewItem.LabTitleRaw) + Else + NewItem.SubTitle = Titles.SubTitle + End If + NewItem.Tags = Tags + NewItem.Description = Description.Replace(vbCr, "").Replace(vbLf, "") + '下边栏 + If Not ShowMcVersionDesc AndAlso Not ShowLoaderDesc Then + '全部隐藏 + CType(NewItem.PathVersion.Parent, Grid).Children.Remove(NewItem.PathVersion) + CType(NewItem.LabVersion.Parent, Grid).Children.Remove(NewItem.LabVersion) + NewItem.ColumnVersion1.Width = New GridLength(0) + NewItem.ColumnVersion2.MaxWidth = 0 + NewItem.ColumnVersion3.Width = New GridLength(0) + ElseIf ShowMcVersionDesc AndAlso ShowLoaderDesc Then + '全部显示 + NewItem.LabVersion.Text = If(ModLoaderDescriptionPart = "", "", ModLoaderDescriptionPart & " ") & GameVersionDescription + ElseIf ShowMcVersionDesc Then + '仅显示版本 + NewItem.LabVersion.Text = GameVersionDescription + Else + '仅显示 Mod 加载器 + NewItem.LabVersion.Text = ModLoaderDescriptionFull + End If + NewItem.LabSource.Text = If(FromCurseForge, "CurseForge", "Modrinth") NewItem.LabTime.Text = GetTimeSpanString(LastUpdate - Date.Now, True) - Else - NewItem.LabTime.Visibility = Visibility.Collapsed - NewItem.ColumnTime1.Width = New GridLength(0) - NewItem.ColumnTime2.Width = New GridLength(0) - NewItem.ColumnTime3.Width = New GridLength(0) - End If - NewItem.LabDownload.Text = - If(DownloadCount > 100000000, Math.Round(DownloadCount / 100000000, 2) & " 亿", + NewItem.LabDownload.Text = + If(DownloadCount > 100000000, Math.Round(DownloadCount / 100000000, 2) & " 亿", If(DownloadCount > 100000, Math.Floor(DownloadCount / 10000) & " 万", DownloadCount)) - Return NewItem + Return NewItem + End Function) With {.Height = 64} End Function - Public Function GetControlLogo() As String + Public Sub ApplyLogoToMyImage(Img As MyImage) If String.IsNullOrEmpty(LogoUrl) Then - Return PathImage & "Icons/NoIcon.png" + Img.Source = PathImage & "Icons/NoIcon.png" Else - Return LogoUrl + Img.Source = LogoUrl + Img.FallbackSource = DlSourceModGet(LogoUrl) End If - End Function - Public Function GetControlTitle(HasModLoaderDescription As Boolean) As KeyValuePair(Of String, String) + End Sub + Public Function GetControlTitle(HasModLoaderDescription As Boolean) As (Title As String, SubTitle As String) '检查下列代码时可以参考 #1567 的测试例 Dim Title As String = RawName Dim SubtitleList As List(Of String) @@ -663,18 +684,18 @@ '没有中文翻译 '将所有名称分段 Dim NameLists = TranslatedName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, StringSplitOptions.RemoveEmptyEntries). - Select(Function(s) s.Trim(" /\".ToCharArray)).Where(Function(w) Not String.IsNullOrEmpty(w)).ToList - If NameLists.Count = 1 Then GoTo NoSubtitle + Select(Function(s) s.Trim(" /\".ToCharArray)).Where(Function(w) Not String.IsNullOrEmpty(w)) + If NameLists.IsSingle Then GoTo NoSubtitle '查找其中的缩写、Forge/Fabric 等版本标记 SubtitleList = New List(Of String) Dim NormalNameList = New List(Of String) For Each Name In NameLists - Dim LowerName As String = Name.ToLower - If Name.ToUpper = Name AndAlso Name <> "FPS" AndAlso Name <> "HUD" Then + Dim LowerName As String = Name.Lower + If Name = Name.Upper AndAlso Name <> "FPS" AndAlso Name <> "HUD" Then '缩写 SubtitleList.Add(Name) - ElseIf (LowerName.Contains("forge") OrElse LowerName.Contains("fabric") OrElse LowerName.Contains("quilt")) AndAlso - Not RegexCheck(LowerName.Replace("forge", "").Replace("fabric", "").Replace("quilt", ""), "[a-z]+") Then '去掉关键词后没有其他字母 + ElseIf {"neoforge", "forge", "fabric", "quilt"}.Any(Function(l) LowerName.Contains(l)) AndAlso + Not RegexCheck(LowerName.Replace("neoforge", "").Replace("forge", "").Replace("fabric", "").Replace("quilt", ""), "[a-z]+") Then '去掉关键词后没有其他字母 'Forge/Fabric 等版本标记 SubtitleList.Add(Name) Else @@ -689,8 +710,8 @@ Else '有中文翻译 '尝试将文本分为三段：Title (EnglishName) - Suffix - '检查时注意 Carpet：它没有中文译名，但有 Suffix - Title = TranslatedName.BeforeFirst(" (").BeforeFirst(" - ") + '检查时注意 Carpet（它没有中文译名，但有 Suffix）和 “汤姆存储 - 星的奇妙优化 (Tom's balabala)” + Title = If(TranslatedName.Contains(" ("), TranslatedName.BeforeFirst(" ("), TranslatedName.BeforeLast(" - ")) Dim Suffix As String = "" If TranslatedName.AfterLast(")").Contains(" - ") Then Suffix = TranslatedName.AfterLast(")").AfterLast(" - ") Dim EnglishName As String = TranslatedName @@ -700,8 +721,8 @@ SubtitleList = EnglishName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, StringSplitOptions.RemoveEmptyEntries). Select(Function(s) s.Trim(" /".ToCharArray)).Where(Function(w) Not String.IsNullOrEmpty(w)).ToList If SubtitleList.Count > 1 AndAlso - Not SubtitleList.Any(Function(s) s.ToLower.Contains("forge") OrElse s.ToLower.Contains("fabric") OrElse s.ToLower.Contains("quilt")) AndAlso '不是标注 XX 版 - Not (SubtitleList.Count = 2 AndAlso SubtitleList.Last.ToUpper = SubtitleList.Last) Then '不是缩写 + Not SubtitleList.Any(Function(s) s.Lower.Contains("forge") OrElse s.Lower.Contains("fabric") OrElse s.Lower.Contains("quilt")) AndAlso '不是标注 XX 版 + Not (SubtitleList.Count = 2 AndAlso SubtitleList.Last.Upper = SubtitleList.Last) Then '不是缩写 SubtitleList = New List(Of String) From {EnglishName} '使用原名 End If '添加后缀 @@ -713,25 +734,25 @@ If SubtitleList.Any Then For Each Ex In SubtitleList Dim IsModLoaderDescription As Boolean = - Ex.ToLower.Contains("forge") OrElse Ex.ToLower.Contains("fabric") OrElse Ex.ToLower.Contains("quilt") + Ex.Lower.Contains("neoforge") OrElse Ex.Lower.Contains("forge") OrElse Ex.Lower.Contains("fabric") OrElse Ex.Lower.Contains("quilt") '是否显示 ModLoader 信息 If Not HasModLoaderDescription AndAlso IsModLoaderDescription Then Continue For '去除 “Forge/Fabric” 这一无意义提示 - If Ex.Length < 16 AndAlso Ex.ToLower.Contains("fabric") AndAlso Ex.ToLower.Contains("forge") Then Continue For + If Ex.Length < 16 AndAlso Ex.Lower.Contains("fabric") AndAlso Ex.Lower.Contains("forge") Then Continue For '将 “Forge” 等提示改为 “Forge 版” If IsModLoaderDescription AndAlso Not Ex.Contains("版") AndAlso - Ex.ToLower.Replace("forge", "").Replace("fabric", "").Replace("quilt", "").Length <= 3 Then + Ex.Lower.Replace("neoforge", "").Replace("forge", "").Replace("fabric", "").Replace("quilt", "").Length <= 3 Then Ex = Ex.Replace("Edition", "").Replace("edition", "").Trim.Capitalize & " 版" End If '将 “forge” 等词语的首字母大写 - Ex = Ex.Replace("forge", "Forge").Replace("neo", "Neo").Replace("fabric", "Fabric").Replace("quilt", "Quilt") + Ex = Ex.Replace("neoforge", "NeoForge").Replace("forge", "Forge").Replace("neo", "Neo").Replace("fabric", "Fabric").Replace("quilt", "Quilt") Subtitle &= " | " & Ex.Trim Next Else NoSubtitle: Subtitle = "" End If - Return New KeyValuePair(Of String, String)(Title, Subtitle) + Return (Title, Subtitle) End Function '辅助函数 @@ -748,17 +769,16 @@ NoSubtitle: For Each r As Char In Data.Where(Function(c) Char.IsLetterOrDigit(c)) Result.Append(r) Next - Return Result.ToString.ToLower + Return Result.ToString.Lower End Function '来自不同的网站 If FromCurseForge = Project.FromCurseForge Then Return False 'Mod 加载器一致 If ModLoaders.Count <> Project.ModLoaders.Count OrElse ModLoaders.Except(Project.ModLoaders).Any() Then Return False '若不为光影，则要求 MC 版本一致 - If Type <> CompType.Shader AndAlso (GameVersions.Count <> Project.GameVersions.Count OrElse GameVersions.Except(Project.GameVersions).Any()) Then Return False + If Types <> CompType.Shader AndAlso (Drops.Count <> Project.Drops.Count OrElse Drops.Except(Project.Drops).Any()) Then Return False '最近更新时间差距在一周以内 - If LastUpdate IsNot Nothing AndAlso Project.LastUpdate IsNot Nothing AndAlso - Math.Abs((LastUpdate - Project.LastUpdate).Value.TotalDays) > 7 Then Return False + If Math.Abs((LastUpdate - Project.LastUpdate).TotalDays) > 7 Then Return False 'MCMOD 翻译名 / 原名 / 描述文本 / Slug 的英文部分相同 If TranslatedName = Project.TranslatedName OrElse RawName = Project.RawName OrElse Description = Project.Description OrElse @@ -807,8 +827,8 @@ NoSubtitle: ''' Public ReadOnly Property CanContinue As Boolean Get - If Tag.StartsWithF("/") OrElse Not Source.HasFlag(CompSourceType.CurseForge) Then Storage.CurseForgeTotal = 0 - If Tag.EndsWithF("/") OrElse Not Source.HasFlag(CompSourceType.Modrinth) Then Storage.ModrinthTotal = 0 + If Tag.StartsWithF("/") OrElse Not Sources.HasFlag(CompSourceType.CurseForge) Then Storage.CurseForgeTotal = 0 + If Tag.EndsWithF("/") OrElse Not Sources.HasFlag(CompSourceType.Modrinth) Then Storage.ModrinthTotal = 0 If Storage.CurseForgeTotal = -1 OrElse Storage.ModrinthTotal = -1 Then Return True Return Storage.CurseForgeOffset < Storage.CurseForgeTotal OrElse Storage.ModrinthOffset < Storage.ModrinthTotal End Get @@ -833,16 +853,13 @@ NoSubtitle: ''' Public GameVersion As String = Nothing ''' - ''' 搜索的文本内容。 + ''' 搜索的初始内容。 ''' Public SearchText As String = Nothing ''' ''' 允许的来源。 ''' - Public Source As CompSourceType = CompSourceType.Any - ''' - ''' 构造函数。 - ''' + Public Sources As CompSourceType = CompSourceType.Any Public Sub New(Type As CompType, Storage As CompProjectStorage, TargetResultCount As Integer) Me.Type = Type Me.Storage = Storage @@ -852,14 +869,12 @@ NoSubtitle: '构造请求 ''' - ''' 获取对应的 CurseForge API 请求链接。若返回 Nothing 则为不进行 CurseForge 请求。 + ''' 获取对应的 CurseForge API 请求链接。 ''' - Public Function GetCurseForgeAddress() As String - If Not Source.HasFlag(CompSourceType.CurseForge) Then Return Nothing + Public Function GetCurseForgeAddress(SearchText As String, IgnoreModLoaderFilter As Boolean) As String If Tag.StartsWithF("/") Then Storage.CurseForgeTotal = 0 - If Storage.CurseForgeTotal > -1 AndAlso Storage.CurseForgeTotal <= Storage.CurseForgeOffset Then Return Nothing '应用筛选参数 - Dim Address As String = $"https://api.curseforge.com/v1/mods/search?gameId=432&sortField=2&sortOrder=desc&pageSize={CompPageSize}" + Dim Address As String = $"https://api.curseforge.com/v1/mods/search?gameId=432&sortField=2&sortOrder=desc&pageSize={COMP_PAGE_SIZE}" Select Case Type Case CompType.Mod Address += "&classId=6" @@ -872,29 +887,27 @@ NoSubtitle: Case CompType.ResourcePack Address += "&classId=12" End Select - Address += "&categoryId=" & If(Tag = "", "0", Tag.BeforeFirst("/")) - If ModLoader <> CompModLoaderType.Any Then Address += "&modLoaderType=" & CType(ModLoader, Integer) + If Tag <> "" Then Address += "&categoryId=" & Tag.BeforeFirst("/") + If ModLoader <> CompModLoaderType.Any AndAlso Not IgnoreModLoaderFilter Then Address += "&modLoaderType=" & CType(ModLoader, Integer) If Not String.IsNullOrEmpty(GameVersion) Then Address += "&gameVersion=" & GameVersion If Not String.IsNullOrEmpty(SearchText) Then Address += "&searchFilter=" & Net.WebUtility.UrlEncode(SearchText) If Storage.CurseForgeOffset > 0 Then Address += "&index=" & Storage.CurseForgeOffset Return Address End Function ''' - ''' 获取对应的 Modrinth API 请求链接。若返回 Nothing 则为不进行 Modrinth 请求。 + ''' 获取对应的 Modrinth API 请求链接。 ''' - Public Function GetModrinthAddress() As String - If Not Source.HasFlag(CompSourceType.Modrinth) Then Return Nothing + Public Function GetModrinthAddress(SearchText As String, IgnoreModLoaderFilter As Boolean) As String If Tag.EndsWithF("/") Then Storage.ModrinthTotal = 0 - If Storage.ModrinthTotal > -1 AndAlso Storage.ModrinthTotal <= Storage.ModrinthOffset Then Return Nothing '应用筛选参数 - Dim Address As String = $"https://api.modrinth.com/v2/search?limit={CompPageSize}&index=relevance" + Dim Address As String = $"https://api.modrinth.com/v2/search?limit={COMP_PAGE_SIZE}&index=relevance" If Not String.IsNullOrEmpty(SearchText) Then Address += "&query=" & Net.WebUtility.UrlEncode(SearchText) If Storage.ModrinthOffset > 0 Then Address += "&offset=" & Storage.ModrinthOffset 'facets=[["categories:'game-mechanics'"],["categories:'forge'"],["versions:1.19.3"],["project_type:mod"]] Dim Facets As New List(Of String) - Facets.Add($"[""project_type:{GetStringFromEnum(Type).ToLower}""]") + Facets.Add($"[""project_type:{GetStringFromEnum(Type).Lower}""]") If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.AfterLast("/")}'""]") - If ModLoader <> CompModLoaderType.Any Then Facets.Add($"[""categories:'{GetStringFromEnum(ModLoader).ToLower}'""]") + If ModLoader <> CompModLoaderType.Any AndAlso Not IgnoreModLoaderFilter Then Facets.Add($"[""categories:'{GetStringFromEnum(ModLoader).Lower}'""]") If Not String.IsNullOrEmpty(GameVersion) Then Facets.Add($"[""versions:'{GameVersion}'""]") Address += "&facets=[" & String.Join(",", Facets) & "]" Return Address @@ -905,7 +918,7 @@ NoSubtitle: Dim request = TryCast(obj, CompProjectRequest) Return request IsNot Nothing AndAlso Type = request.Type AndAlso TargetResultCount = request.TargetResultCount AndAlso - Tag = request.Tag AndAlso ModLoader = request.ModLoader AndAlso Source = request.Source AndAlso + Tag = request.Tag AndAlso ModLoader = request.ModLoader AndAlso Sources = request.Sources AndAlso GameVersion = request.GameVersion AndAlso SearchText = request.SearchText End Function Public Shared Operator =(left As CompProjectRequest, right As CompProjectRequest) As Boolean @@ -914,6 +927,9 @@ NoSubtitle: Public Shared Operator <>(left As CompProjectRequest, right As CompProjectRequest) As Boolean Return Not left = right End Operator + Public Overrides Function GetHashCode() As Integer + Return (Type, Tag, ModLoader, GameVersion, SearchText, Sources).GetHashCode() + End Function End Class Public Class CompProjectStorage @@ -941,7 +957,8 @@ NoSubtitle: '实际的获取 - Private Const CompPageSize = 40 + Private Const COMP_PAGE_SIZE = 40 + Private Const MSG_NO_CHINESE_SEARCH_RESULT As String = "无搜索结果，请尝试搜索其英文名称" ''' ''' 已知工程信息的缓存。 ''' @@ -951,133 +968,156 @@ NoSubtitle: ''' Public Sub CompProjectsGet(Task As LoaderTask(Of CompProjectRequest, Integer)) Dim Request As CompProjectRequest = Task.Input - Dim Storage = Request.Storage '避免多线程问题 + Dim Storage = Request.Storage '避免其他线程对 Request.Storage 重新进行了赋值 - If Request.Storage.Results.Count >= Request.TargetResultCount Then - Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理") +#Region "前置检查" + + If Storage.Results.Count >= Request.TargetResultCount Then + Log($"[Comp] 已有 {Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理") Return ElseIf Not Request.CanContinue Then - If Not Request.Storage.Results.Any() Then + If Not Storage.Results.Any() Then Throw New Exception("没有符合条件的结果") Else - Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理") + Log($"[Comp] 已有 {Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理") Return End If End If -#Region "拒绝 1.13- Quilt（这个版本根本没有 Quilt）" - - If Request.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Request.GameVersion, "1.15"), "1.14") = -1 Then + '拒绝 1.13- Quilt（这个版本根本没有 Quilt） + If Request.ModLoader = CompModLoaderType.Quilt AndAlso CompareVersion(If(Request.GameVersion, "1.15"), "1.14") = -1 Then Throw New Exception("Quilt 不支持 Minecraft " & Request.GameVersion) End If #End Region -#Region "处理搜索文本，赋值回 Task.Input.SearchText" +#Region "中文搜索" - Dim RawFilter As String = If(Request.SearchText, "").Trim - Request.SearchText = RawFilter - RawFilter = RawFilter.ToLower - Log("[Comp] 工程列表搜索原始文本：" & RawFilter) + Dim RawSearchText As String = If(Request.SearchText, "").Trim + RawSearchText = RawSearchText.Lower + Log("[Comp] 工程列表搜索原始文本：" & RawSearchText) - '中文请求关键字处理 - Dim IsChineseSearch As Boolean = RegexCheck(RawFilter, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawFilter) - If IsChineseSearch AndAlso (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then - '构造搜索请求 - Dim SearchEntries As New List(Of SearchEntry(Of CompDatabaseEntry)) - For Each Entry In CompDatabase - If Entry.ChineseName.Contains("动态的树") Then Continue For '这玩意儿附属太多了 - SearchEntries.Add(New SearchEntry(Of CompDatabaseEntry) With { + Dim IsChineseSearch As Boolean = + RegexCheck(RawSearchText, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawSearchText) AndAlso + (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) '目前仅对 Mod 和数据包进行中文搜索，注意整合包的名称可能已经有中文了 + Dim CurseForgeAltSearchText As String = Nothing, ModrinthAltSearchText As String = Nothing, ModrinthSlugs As New List(Of String) '从中文转为英文的替代搜索内容 + If IsChineseSearch Then + '帮助方法：从搜索项提取可能的英文单词 + Dim ExtractWords = + Function(Result As SearchEntry(Of CompDatabaseEntry), Source As CompSourceType) As IEnumerable(Of String) + '从各个可能的来源提取候选 + Dim Candidates As New List(Of String) + If Result.Item.CurseForgeSlug IsNot Nothing AndAlso Source = CompSourceType.CurseForge Then + Candidates.Add(Result.Item.CurseForgeSlug.Replace("-", " ").Replace("/", " ")) + End If + If Result.Item.ModrinthSlug IsNot Nothing AndAlso Source = CompSourceType.Modrinth Then + Candidates.Add(Result.Item.ModrinthSlug.Replace("-", " ").Replace("/", " ")) + End If + Candidates.Add(Result.Item.ChineseName.AfterLast(" (").TrimEnd(") ").BeforeFirst(" - "). + Replace("-", " ").Replace("/", " ").Replace(":", " ").Replace("(", " ").Replace(")", "")) + '分词、清洗、去重 + Candidates = Candidates. + SelectMany(Function(c) c.Split(" ")). + Select(Function(w) w.TrimStart("{[(").TrimEnd("}])").Lower). + Where( + Function(w) + If w.Length <= 1 Then Return False '单字或空白 + If {"the", "of", "mod", "and", "forge", "fabric", "for", "quilt", "neoforge"}.Contains(w) Then Return False '常见词 + If Val(w) > 0 Then Return False '数字 + Return True + End Function).Distinct.ToList + '如果一个词可以由其他词拼成，则去掉这个词（例如将 ender io enderio 的 enderio 剔除，只保留 ender io） + Dim CanForm As Func(Of String, Boolean) = Nothing + CanForm = Function(s) Candidates.Contains(s) OrElse Candidates.Any(Function(c) s.StartsWith(c) AndAlso CanForm(s.Substring(c.Length))) + Candidates = Candidates.Where(Function(w) Not Candidates.Any(Function(c) c.Length < w.Length AndAlso w.StartsWith(c) AndAlso CanForm(w.Substring(c.Length)))).ToList() + Return Candidates + End Function + 'CurseForge + If Request.Sources.HasFlag(CompSourceType.CurseForge) Then + '数据库搜索 + Static CurseForgeSearchEntries As List(Of SearchEntry(Of CompDatabaseEntry)) = + CompDatabase.Where(Function(Entry) Entry.CurseForgeSlug IsNot Nothing).Select( + Function(Entry) New SearchEntry(Of CompDatabaseEntry) With { .Item = Entry, - .SearchSource = New List(Of KeyValuePair(Of String, Double)) From { - New KeyValuePair(Of String, Double)(Entry.ChineseName & If(Entry.CurseForgeSlug, "") & If(Entry.ModrinthSlug, ""), 1) - } - }) - Next - '获取搜索结果 - Dim SearchResults = Search(SearchEntries, Request.SearchText, 3) - If Not SearchResults.Any() Then Throw New Exception("无搜索结果，请尝试搜索英文名称") - Dim SearchResult As String = "" - For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的，也最多只要 5 个 - If Not SearchResults(i).AbsoluteRight AndAlso i >= Math.Min(2, SearchResults.Count - 1) Then Exit For '把 3 个结果拼合以提高准确度 - If SearchResults(i).Item.CurseForgeSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.CurseForgeSlug.Replace("-", " ").Replace("/", " ") & " " - If SearchResults(i).Item.ModrinthSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.ModrinthSlug.Replace("-", " ").Replace("/", " ") & " " - SearchResult += SearchResults(i).Item.ChineseName.AfterLast(" (").TrimEnd(") ").BeforeFirst(" - "). - Replace(":", "").Replace("(", "").Replace(")", "").ToLower.Replace("/", " ") & " " - Next - Log("[Comp] 中文搜索原始关键词：" & SearchResult, LogLevel.Developer) - '去除常见连接词 - Dim RealFilter As String = "" - For Each Word In SearchResult.Split(" ") - If {"the", "of", "a", "mod", "and"}.Contains(Word.ToLowerInvariant) OrElse Val(Word) > 0 Then Continue For - If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For - RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " " - Next - Request.SearchText = RealFilter - Log("[Comp] 中文搜索最终关键词：" & RealFilter, LogLevel.Developer) - End If - - '驼峰英文请求关键字处理 - Dim SpacedKeywords = Request.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ") - Dim ConnectedKeywords = Request.SearchText.Replace(" ", "") - Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Request.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower - - '最终处理关键字：分割、去重 - Dim RightKeywords As New List(Of String) - For Each Keyword In AllPossibleKeywords.Split(" ") - Keyword = Keyword.Trim("["c, "]"c) - If Keyword = "" Then Continue For - If {"forge", "fabric", "for", "mod", "quilt"}.Contains(Keyword) Then '#208 - Log("[Comp] 已跳过搜索关键词：" & Keyword, LogLevel.Developer) - Continue For + .SearchSource = New List(Of SearchSource) From { + New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1), '部分 Mod 有别名 + New SearchSource(Entry.ChineseName.AfterFirst(" (") & Entry.CurseForgeSlug, 0.5)} + }).ToList + Dim CurseForgeSearchResults = Search(CurseForgeSearchEntries, RawSearchText, 100, 0.25) + If CurseForgeSearchResults.Any Then + '选取目标（CurseForge 要求每个词都必须匹配上，所以只能选择一个 Mod 进行搜索） + Dim CurseForgeTarget = + If(CurseForgeSearchResults.First.AbsoluteRight, + CurseForgeSearchResults.Where(Function(s) s.AbsoluteRight).ToList, '优先使用所有完全匹配的 + CurseForgeSearchResults.MaxByAll(Function(s) s.Similarity)). '其次使用所有相似度最高的 + MaxBy(Function(s) s.Item.Popularity) '然后从中选择最受欢迎的那一个 + '后处理 + CurseForgeAltSearchText = ExtractWords(CurseForgeTarget, CompSourceType.CurseForge).Join(" ") + Log("[Comp] 中文搜索关键词（CurseForge）：" & CurseForgeAltSearchText, LogLevel.Debug) + End If + End If + 'Modrinth + If Request.Sources.HasFlag(CompSourceType.Modrinth) Then + '数据库搜索 + Static ModrinthSearchEntries As List(Of SearchEntry(Of CompDatabaseEntry)) = + CompDatabase.Where(Function(Entry) Entry.ModrinthSlug IsNot Nothing).Select( + Function(Entry) New SearchEntry(Of CompDatabaseEntry) With { + .Item = Entry, + .SearchSource = New List(Of SearchSource) From { + New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1), '部分 Mod 有别名 + New SearchSource(Entry.ChineseName.AfterFirst(" (") & Entry.ModrinthSlug, 0.5)} + }).ToList + Dim ModrinthSearchResults = Search(ModrinthSearchEntries, RawSearchText, 100, 0.25) + If ModrinthSearchResults.Any Then + '分词 + Dim WordWeights As New Dictionary(Of String, Double) '各个单词及其出现的权重 + For Each Result In ModrinthSearchResults + For Each Word In ExtractWords(Result, CompSourceType.Modrinth) + If Not WordWeights.ContainsKey(Word) Then WordWeights.Add(Word, 0) + Dim Similarity = If(Result.SearchSource.Any(Function(s) s.Aliases.Contains(RawSearchText)), 1000, Result.Similarity) '完全匹配为 1000 + WordWeights(Word) += Similarity * Result.Item.Popularity '权重 += 相似度 * 受欢迎程度 + Next + Next + ModrinthAltSearchText = WordWeights.MaxBy(Function(w) w.Value).Key + Log("[Comp] 中文搜索关键词（Modrinth）：" & ModrinthAltSearchText, LogLevel.Debug) + '直接请求工程 + ModrinthSlugs = ModrinthSearchResults.Take(100).Select(Function(r) r.Item.ModrinthSlug).ToList + End If + End If + '结束 + If String.IsNullOrEmpty(CurseForgeAltSearchText) AndAlso String.IsNullOrEmpty(ModrinthAltSearchText) AndAlso Not ModrinthSlugs.Any Then + Throw New Exception(MSG_NO_CHINESE_SEARCH_RESULT) End If - RightKeywords.Add(Keyword) - Next - If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then - Request.SearchText = RawFilter '全都被过滤掉了 - Else - Request.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower End If - - '例外项：OptiForge、OptiFabric（拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod） - If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Request.SearchText = "optiforge" - If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Request.SearchText = "optifabric" - Log("[Comp] 工程列表搜索最终文本：" & Request.SearchText, LogLevel.Debug) - Task.Progress = 0.1 + Task.Progress = 0.05 #End Region Dim RealResults As New List(Of CompProject) -Retry: - Dim RawResults As New List(Of CompProject) - Dim [Error] As Exception = Nothing +NextPage: + Dim RawResults As New SafeList(Of CompProject) #Region "从 CurseForge 和 Modrinth 获取结果列表，存储于 RawResults" - Dim CurseForgeThread As Thread = Nothing - Dim ModrinthThread As Thread = Nothing - Dim ResultsLock As New Object + Dim WorkThreads As New List(Of Thread) + Dim Errors As New SafeList(Of (Ex As Exception, Source As CompSourceType)) '在 1.14-，部分老 Mod 没有设置支持的加载器，因此添加 Forge 筛选就会出现遗漏 '所以，在发起请求时不筛选加载器，然后在返回的结果中自行筛除不是 Forge 的 Mod - Dim IsOldForgeRequest = Request.ModLoader = CompModLoaderType.Forge AndAlso Request.GameVersion?.Contains(".") AndAlso Val(Request.GameVersion.Split(".")(1)) < 14 - If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Any - Dim CurseForgeUrl As String = Request.GetCurseForgeAddress() - Dim ModrinthUrl As String = Request.GetModrinthAddress() - If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Forge '设置回去 - + Dim IgnoreModLoaderFilter = Request.ModLoader = CompModLoaderType.Forge AndAlso McVersion.VersionToDrop(Request.GameVersion) < 140 Try - '启动 CurseForge 线程 - Dim CurseForgeFailed As Boolean = False - If CurseForgeUrl IsNot Nothing Then - CurseForgeThread = RunInNewThread( + 'CurseForge 搜索 + If Request.Sources.HasFlag(CompSourceType.CurseForge) AndAlso + Not (Storage.CurseForgeTotal > -1 AndAlso Storage.CurseForgeTotal <= Storage.CurseForgeOffset) AndAlso '剩余的未显示的搜索结果不足 + (Not IsChineseSearch OrElse (IsChineseSearch AndAlso Not String.IsNullOrEmpty(CurseForgeAltSearchText))) Then '如果是中文搜索，就只在有对应搜索关键词的时候才继续 + WorkThreads.Add(RunInNewThread( Sub() Try '获取工程列表 - Log("[Comp] 开始从 CurseForge 获取工程列表：" & CurseForgeUrl) - Dim RequestResult As JObject = DlModRequest(CurseForgeUrl, IsJson:=True) - Task.Progress += 0.2 + Dim CurseForgeUrl As String = Request.GetCurseForgeAddress(If(CurseForgeAltSearchText, RawSearchText), IgnoreModLoaderFilter) + Log("[Comp] 开始 CurseForge 搜索：" & CurseForgeUrl) + Dim RequestResult As JObject = DlModRequest(CurseForgeUrl) Dim ProjectList As New List(Of CompProject) For Each JsonEntry As JObject In RequestResult("data") Dim Project As New CompProject(JsonEntry) @@ -1085,108 +1125,137 @@ Retry: ProjectList.Add(Project) Next '更新结果 - SyncLock ResultsLock - RawResults.AddRange(ProjectList) - End SyncLock - Storage.CurseForgeOffset += ProjectList.Count + ProjectList.ForEach(Sub(p) RawResults.Add(p)) + Storage.CurseForgeOffset += RequestResult("data").Count Storage.CurseForgeTotal = RequestResult("pagination")("totalCount").ToObject(Of Integer) - Log($"[Comp] 从 CurseForge 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.CurseForgeOffset} 个，共 {Storage.CurseForgeTotal} 个）") + 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 + Log(ex, "CurseForge 搜索失败") + Storage.CurseForgeTotal = -1 + Errors.Add((ex, CompSourceType.CurseForge)) End Try - End Sub, "CurseForge Project Request") + If Task.Progress < 0.75 Then Task.Progress += 0.25 '可能重复加载多页，所以不能直接给够 + End Sub, "CurseForge Search")) End If - '启动 Modrinth 线程 - Dim ModrinthFailed As Boolean = False - If ModrinthUrl IsNot Nothing Then - ModrinthThread = RunInNewThread( + 'Modrinth 搜索 + If Request.Sources.HasFlag(CompSourceType.Modrinth) AndAlso + Not (Storage.ModrinthTotal > -1 AndAlso Storage.ModrinthTotal <= Storage.ModrinthOffset) AndAlso '剩余的未显示的搜索结果不足 + (Not IsChineseSearch OrElse (IsChineseSearch AndAlso Not String.IsNullOrEmpty(ModrinthAltSearchText))) Then '如果是中文搜索，就只在有对应搜索关键词的时候才继续 + WorkThreads.Add(RunInNewThread( Sub() Try - Log("[Comp] 开始从 Modrinth 获取工程列表：" & ModrinthUrl) - Dim RequestResult As JObject = DlModRequest(ModrinthUrl, IsJson:=True) - Task.Progress += 0.2 + Dim ModrinthUrl As String = Request.GetModrinthAddress(If(ModrinthAltSearchText, RawSearchText), IgnoreModLoaderFilter) + Log("[Comp] 开始 Modrinth 搜索：" & ModrinthUrl) + Dim RequestResult As JObject = DlModRequest(ModrinthUrl) 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 - RawResults.Add(Project) - Next - End SyncLock - Storage.ModrinthOffset += ProjectList.Count + ProjectList.ForEach(Sub(p) RawResults.Add(p)) + Storage.ModrinthOffset += RequestResult("hits").Count Storage.ModrinthTotal = RequestResult("total_hits").ToObject(Of Integer) - Log($"[Comp] 从 Modrinth 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.ModrinthOffset} 个，共 {Storage.ModrinthTotal} 个）") + 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 + Log(ex, "Modrinth 搜索失败") + Storage.ModrinthTotal = -1 + Errors.Add((ex, CompSourceType.Modrinth)) End Try - End Sub, "Modrinth Project Request") + If Task.Progress < 0.75 Then Task.Progress += 0.25 '可能重复加载多页，所以不能直接给够 + End Sub, "Modrinth Search")) + End If + + 'Modrinth 直接获取工程 + If Request.Sources.HasFlag(CompSourceType.Modrinth) AndAlso + Not (Storage.ModrinthTotal > -1 AndAlso Storage.ModrinthTotal <= Storage.ModrinthOffset) AndAlso '剩余的未显示的搜索结果不足 + ModrinthSlugs.Any Then '有直接获取的 Slug + WorkThreads.Add(RunInNewThread( + Sub() + Try + Dim ModrinthUrl As String = $"https://api.modrinth.com/v2/projects?ids=[""{ModrinthSlugs.Join(""",""")}""]" + Log("[Comp] 开始 Modrinth 直接获取：" & ModrinthUrl) + Dim ProjectList As New List(Of CompProject) + For Each JsonEntry As JObject In DlModRequest(ModrinthUrl) + Dim Project As New CompProject(JsonEntry) + '应用筛选 + If Request.Type <> CompType.Any AndAlso Not Project.Types.HasFlag(Request.Type) Then Continue For + If Not String.IsNullOrEmpty(Request.Tag) AndAlso + Not JsonEntry("categories").Any(Function(c) c.ToString = Request.Tag.AfterLast("/")) Then Continue For 'Project.Tags 已经转换成中文了，只能从 json 判 + If Request.ModLoader <> CompModLoaderType.Any AndAlso Not IgnoreModLoaderFilter AndAlso + Not Project.ModLoaders.Any(Function(m) m = Request.ModLoader) Then Continue For + If Not String.IsNullOrEmpty(Request.GameVersion) AndAlso + Not Project.UnsafeGameVersions.Any(Function(d) d = Request.GameVersion) Then Continue For + ProjectList.Add(Project) + Next + '更新结果 + ProjectList.ForEach(Sub(p) RawResults.Add(p)) + Log($"[Comp] 从 Modrinth 直接获取到了 {ProjectList.Count} 个工程") + ModrinthSlugs.Clear() '防止重试/加载下一页时重复获取 + Catch ex As Exception + Log(ex, "Modrinth 直接获取失败") + Errors.Add((ex, CompSourceType.Modrinth)) + End Try + If Task.Progress < 0.75 Then Task.Progress += 0.25 '可能重复加载多页，所以不能直接给够 + End Sub, "Modrinth Get")) End If '等待线程结束 - If CurseForgeThread IsNot Nothing Then CurseForgeThread.Join() - If Task.IsAborted Then Return '会自动触发 Finally - If ModrinthThread IsNot Nothing Then ModrinthThread.Join() - If Task.IsAborted Then Return + For Each Thread In WorkThreads + Thread.Join() + If Task.IsInterrupted Then Return '会自动触发 Finally 以清理线程 + Next + + '筛除不是 Forge 的 Mod + If IgnoreModLoaderFilter Then + RawResults = RawResults.Where(Function(p) Not p.ModLoaders.Any() OrElse p.ModLoaders.Contains(CompModLoaderType.Forge)).ToList + End If '确保存在结果 Storage.ErrorMessage = Nothing If Not RawResults.Any() Then - If [Error] IsNot Nothing Then - Throw [Error] + If Errors.Any() Then + Throw Errors.First.Ex Else If IsChineseSearch AndAlso Not (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then - Throw New Exception("没有搜索结果，请尝试使用英文搜索") - ElseIf Request.Source = CompSourceType.CurseForge AndAlso Request.Tag.StartsWithF("/") Then + Throw New Exception(MSG_NO_CHINESE_SEARCH_RESULT) + ElseIf Request.Sources = CompSourceType.CurseForge AndAlso Request.Tag.StartsWithF("/") Then Throw New Exception("CurseForge 不兼容所选的类型") - ElseIf Request.Source = CompSourceType.Modrinth AndAlso Request.Tag.EndsWithF("/") Then + ElseIf Request.Sources = CompSourceType.Modrinth AndAlso Request.Tag.EndsWithF("/") Then Throw New Exception("Modrinth 不兼容所选的类型") Else Throw New Exception("没有搜索结果") End If End If - ElseIf [Error] IsNot Nothing Then + ElseIf Errors.Any() Then '有结果但是有错误 - If CurseForgeFailed Then - Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。" + If Errors.Any(Function(e) e.Source = CompSourceType.CurseForge) Then + Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。" Else - Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。" + Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。" End If End If Finally - CurseForgeThread?.Interrupt() - ModrinthThread?.Interrupt() + For Each Thread In WorkThreads + If Thread.IsAlive Then Thread.Interrupt() + Next End Try - '筛除不是 Forge 的 Mod - If IsOldForgeRequest Then - RawResults = RawResults.Where(Function(p) Not p.ModLoaders.Any() OrElse p.ModLoaders.Contains(CompModLoaderType.Forge)).ToList - End If - #End Region #Region "提取非重复项，存储于 RealResults" - '将 Modrinth 排在 CurseForge 的前面，避免加载结束顺序不同导致排名不同 - '这样做的话，去重后将优先保留 CurseForge 内容 - RawResults = RawResults.Where(Function(x) Not x.FromCurseForge).Concat(RawResults.Where(Function(x) x.FromCurseForge)).ToList - 'RawResults 去重 + '将 CurseForge 排在 Modrinth 的前面，避免加载结束顺序不同导致排名不同 + RawResults = RawResults.Where(Function(x) x.FromCurseForge).Concat(RawResults.Where(Function(x) Not x.FromCurseForge)).ToList + '去重 RawResults = RawResults.Distinct(Function(a, b) a.IsLike(b)) '已有内容去重 RawResults = RawResults.Where(Function(r) Not RealResults.Any(Function(b) r.IsLike(b)) AndAlso Not Storage.Results.Any(Function(b) r.IsLike(b))).ToList '加入列表 RealResults.AddRange(RawResults) - Log($"[Comp] 去重、筛选后累计新增结果 {RealResults.Count} 个") + Log($"[Comp] 去重、筛选后累计新增结果 {RealResults.Count} 个（目前已有结果 {Storage.Results.Count} 个）") #End Region @@ -1194,9 +1263,9 @@ Retry: If RealResults.Count + Storage.Results.Count < Request.TargetResultCount Then Log($"[Comp] 总结果数需求最少 {Request.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个") - If Request.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试，这时候重试可能导致无限循环 + If Request.CanContinue AndAlso Not Errors.Any Then '如果有某个源失败则不再重试，这时候重试可能导致无限循环 Log("[Comp] 将继续尝试加载下一页") - GoTo Retry + GoTo NextPage Else Log("[Comp] 无法继续加载，将强制结束") End If @@ -1211,37 +1280,40 @@ Retry: Function(Project As CompProject) As Double Select Case Request.Type Case CompType.Mod, CompType.ModPack - Return If(Project.FromCurseForge, 1, 7) + Return If(Project.FromCurseForge, 1, 5) Case CompType.DataPack Return If(Project.FromCurseForge, 10, 1) Case CompType.ResourcePack, CompType.Shader - Return If(Project.FromCurseForge, 1, 5) + Return If(Project.FromCurseForge, 1, 4) Case Else Return 1 End Select End Function - If String.IsNullOrEmpty(Request.SearchText) Then + If String.IsNullOrEmpty(RawSearchText) Then '如果没有搜索文本，按下载量将结果排序 For Each Result As CompProject In RealResults - Scores.Add(Result, Result.DownloadCount * GetDownloadCountMult(Result)) + Scores(Result) = Result.DownloadCount * GetDownloadCountMult(Result) Next Else '如果有搜索文本，按关联度将结果排序 '排序分 = 搜索相对相似度 (1) + 下载量权重 (对数，10 亿时为 1) + 有中文名 (0.2) - Dim Entry As New List(Of SearchEntry(Of CompProject)) + Dim SearchEntries 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) * GetDownloadCountMult(Result)) / 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)}}) + Scores(Result) = If(Result.WikiId > 0, 0.2, 0) + + Math.Log10(Math.Max(Result.DownloadCount, 1) * GetDownloadCountMult(Result)) / 9 + SearchEntries.Add(New SearchEntry(Of CompProject) With {.Item = Result, .SearchSource = New List(Of SearchSource) From { + New SearchSource(If(IsChineseSearch, Result.TranslatedName, Result.RawName).Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1), + New SearchSource(Result.Description, 0.05)}}) Next - Dim SearchResult = Search(Entry, RawFilter, 101, -1) + Dim SearchResult = Search(SearchEntries, RawSearchText, 10000, -1) For Each OneResult In SearchResult - Scores(OneResult.Item) += OneResult.Similarity / SearchResult(0).Similarity '最高 1 分的相似度分 + Scores(OneResult.Item) += + If(OneResult.AbsoluteRight, 10, OneResult.Similarity) / + If(SearchResult.First.AbsoluteRight, 10, SearchResult.First.Similarity) '最高 1 分的相似度分 Next End If '根据排序分得出结果并添加 + If Task.IsInterrupted Then Throw New ThreadInterruptedException '#8246 Storage.Results.AddRange( Scores.OrderByDescending(Function(s) s.Value).Select(Function(r) r.Key)) @@ -1292,11 +1364,16 @@ Retry: ''' Public ReadOnly DownloadCount As Integer ''' + ''' Mod 版本号。 + ''' 不一定是标准格式。CurseForge 上默认为 Nothing。 + ''' + Public Version As String + ''' ''' 支持的 Mod 加载器列表。可能为空。 ''' Public ReadOnly ModLoaders As List(Of CompModLoaderType) ''' - ''' 支持的游戏版本列表。类型包括："1.18.5"，"1.18"，"1.18 预览版"，"21w15a"，"未知版本"。 + ''' 支持的游戏版本列表。类型包括："26.1.5"，"26.1"，"26.1 预览版"，"1.18.5"，"1.18"，"1.18 预览版"，"21w15a"，"未知版本"。 ''' Public ReadOnly GameVersions As List(Of String) ''' @@ -1341,6 +1418,10 @@ Retry: ''' Public ReadOnly Hash As String = Nothing ''' + ''' 文件大小。不可用时为 -1。 + ''' + Public ReadOnly Size As Integer = -1 + ''' ''' 该文件的所有依赖工程的原始 ID。 ''' 这些 ID 可能没有加载，在加载后会添加到 Dependencies 中（主要是因为 Modrinth 返回的是字符串 ID 而非 Slug，导致 Project.Id 查询不到）。 ''' @@ -1354,13 +1435,13 @@ Retry: ''' ''' 目标本地文件夹，或完整的文件路径。会自动判断类型。 Public Function ToNetFile(LocalAddress As String) As NetFile - Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True) + Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash, ActualSize:=Size), SimulateBrowserHeaders:=True) End Function '实例化 ''' - ''' 从文件 Json 中初始化实例。若出错会抛出异常。 + ''' 从 json 中初始化实例。若出错会抛出异常。 ''' Public Sub New(Data As JObject, DefaultType As CompType) Type = DefaultType @@ -1369,12 +1450,14 @@ Retry: FromCurseForge = Data("FromCurseForge").ToObject(Of Boolean) Id = Data("Id").ToString DisplayName = Data("DisplayName").ToString + If Data.ContainsKey("Version") Then Version = Data("Version").ToString ReleaseDate = Data("ReleaseDate").ToObject(Of Date) DownloadCount = Data("DownloadCount").ToObject(Of Integer) Status = CType(Data("Status").ToObject(Of Integer), CompFileStatus) If Data.ContainsKey("FileName") Then FileName = Data("FileName").ToString If Data.ContainsKey("DownloadUrls") Then DownloadUrls = Data("DownloadUrls").ToObject(Of List(Of String)) If Data.ContainsKey("ModLoaders") Then ModLoaders = Data("ModLoaders").ToObject(Of List(Of CompModLoaderType)) + If Data.ContainsKey("Size") Then Size = Data("Size").ToObject(Of Integer) If Data.ContainsKey("Hash") Then Hash = Data("Hash").ToString If Data.ContainsKey("GameVersions") Then GameVersions = Data("GameVersions").ToObject(Of List(Of String)) If Data.ContainsKey("RawDependencies") Then RawDependencies = Data("RawDependencies").ToObject(Of List(Of String)) @@ -1387,18 +1470,19 @@ Retry: '简单信息 Id = Data("id") DisplayName = Data("displayName").ToString.Replace(" ", "").Trim(" ") + Version = Nothing ReleaseDate = Data("fileDate") Status = CType(Data("releaseType").ToObject(Of Integer), CompFileStatus) DownloadCount = Data("downloadCount") FileName = Data("fileName") + Size = Data("fileLength") Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 1)?("value") If Hash Is Nothing Then Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 2)?("value") 'DownloadAddress Dim Url = Data("downloadUrl").ToString - If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}" - Url = Url.Replace(FileName, Net.WebUtility.UrlEncode(FileName)) '对文件名进行编码 - DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正 - DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源，这个写法是为了让镜像源排在后面 + If Url = "" Then Url = $"https://edge.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}" + DownloadUrls = HandleCurseForgeDownloadUrls(Url.Replace(FileName, WebUtility.UrlEncode(FileName))) '对脑残 CurseForge 的下载地址进行多种修正 + DownloadUrls.Add(DlSourceModGet(Url)) '添加镜像源；注意 MCIM 源不支持 URL 编码后的文件名，必须传入 URL 编码前的文件名 DownloadUrls = DownloadUrls.Distinct.ToList '最终去重 'Dependencies If Data.ContainsKey("dependencies") Then @@ -1408,13 +1492,16 @@ Retry: Select(Function(d) d("modId").ToString).ToList End If 'GameVersions - Dim RawVersions As List(Of String) = Data("gameVersions").Select(Function(t) t.ToString.Trim.ToLower).ToList - GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.")).Select(Function(v) v.Replace("-snapshot", " 预览版")).ToList - If GameVersions.Count > 1 Then - GameVersions = GameVersions.Sort(AddressOf VersionSortBoolean).ToList - If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本 - ElseIf GameVersions.Count = 1 Then + Dim RawVersions As List(Of String) = Data("gameVersions").Select(Function(t) t.ToString.Trim.Lower).ToList + GameVersions = RawVersions. + Where(Function(v) McVersion.IsFormatFit(v)). + Select(Function(v) v.Replace("-snapshot", " 预览版")). + Distinct.ToList + If GameVersions.IsSingle Then GameVersions = GameVersions.ToList + ElseIf GameVersions.Count > 1 Then + GameVersions = GameVersions.SortByComparison(AddressOf CompareVersionGE).ToList + If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本 Else GameVersions = New List(Of String) From {"未知版本"} End If @@ -1430,6 +1517,7 @@ Retry: '简单信息 Id = Data("id") DisplayName = Data("name").ToString.Replace(" ", "").Trim(" ") + Version = Data("version_number") 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") @@ -1437,26 +1525,22 @@ Retry: Dim File As JToken = Data("files")(0) FileName = File("filename") DownloadUrls = New List(Of String) From {File("url"), DlSourceModGet(File("url"))}.Distinct.ToList '同时添加了镜像源 + Size = File("size") Hash = File("hashes")("sha1") End If - 'ModLoaders + 'Loaders '结果可能混杂着 Mod、数据包和服务端插件 Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList ModLoaders = New List(Of CompModLoaderType) - If Type = CompType.Mod Then '以尽量宽容的方式检测加载器，以免同时兼容两种的项被删除 + If Type.HasFlag(CompType.Mod) OrElse Type.HasFlag(CompType.DataPack) Then If RawLoaders.Intersect({"bukkit", "folia", "paper", "purpur", "spigot"}).Any() Then Type = CompType.Plugin 'Veinminer Enchantment 同时支持服务端与 Fabric If RawLoaders.Contains("datapack") Then Type = CompType.DataPack If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge) : Type = CompType.Mod If RawLoaders.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge) : Type = CompType.Mod If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric) : Type = CompType.Mod If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt) : Type = CompType.Mod - ElseIf Type = CompType.DataPack Then - If RawLoaders.Intersect({"bukkit", "folia", "paper", "purpur", "spigot"}).Any() Then Type = CompType.Plugin - If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge) : Type = CompType.Mod - If RawLoaders.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge) : Type = CompType.Mod - If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric) : Type = CompType.Mod - If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt) : Type = CompType.Mod - If RawLoaders.Contains("datapack") Then Type = CompType.DataPack + Else + '使用传入的类别，不作修改（#8377） End If 'Dependencies If Data.ContainsKey("dependencies") Then @@ -1467,16 +1551,17 @@ Retry: Select(Function(d) d("project_id").ToString).ToList End If 'GameVersions - Dim RawVersions As List(Of String) = Data("game_versions").Select(Function(t) t.ToString.Trim.ToLower).ToList - GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.") OrElse v.StartsWithF("b1.")). - Select(Function(v) If(v.Contains("-"), v.BeforeFirst("-") & " 预览版", If(v.StartsWithF("b1."), "远古版本", v))).ToList - If GameVersions.Count > 1 Then - GameVersions = GameVersions.Sort(AddressOf VersionSortBoolean).ToList - If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本 - ElseIf GameVersions.Count = 1 Then + Dim RawVersions As List(Of String) = Data("game_versions").Select(Function(t) t.ToString.Trim.Lower).ToList + GameVersions = RawVersions.Where(Function(v) v.Contains(".")). + Select(Function(v) If(v.Contains("-"), v.BeforeFirst("-") & " 预览版", If(v.StartsWithF("b1."), "远古版本", v))). + Distinct.ToList + If GameVersions.IsSingle Then '无需处理 - ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")) Then - GameVersions = RawVersions.Where(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")).ToList + ElseIf GameVersions.Count > 1 Then + GameVersions = GameVersions.SortByComparison(AddressOf CompareVersionGE).ToList + If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本 + ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]")) Then + GameVersions = RawVersions.Where(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]")).ToList Else GameVersions = New List(Of String) From {"未知版本"} End If @@ -1492,9 +1577,8 @@ Retry: Return { Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."), Url.Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."), - Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge.", "://media."), Url.Replace("-service.overwolf.wtf", ".forgecdn.net"), - Url.Replace("://edge.", "://media."), + Url.Replace("://media.", "://edge."), Url }.Distinct.ToList End Function @@ -1506,6 +1590,7 @@ Retry: Dim Json As New JObject Json.Add("FromCurseForge", FromCurseForge) Json.Add("Id", Id) + If Version IsNot Nothing Then Json.Add("Version", Version) Json.Add("DisplayName", DisplayName) Json.Add("ReleaseDate", ReleaseDate) Json.Add("DownloadCount", DownloadCount) @@ -1515,6 +1600,7 @@ Retry: If FileName IsNot Nothing Then Json.Add("FileName", FileName) If DownloadUrls IsNot Nothing Then Json.Add("DownloadUrls", New JArray(DownloadUrls)) If Hash IsNot Nothing Then Json.Add("Hash", Hash) + If Size >= 0 Then Json.Add("Size", Size) Json.Add("RawDependencies", New JArray(RawDependencies)) Json.Add("Dependencies", New JArray(Dependencies)) Return Json @@ -1523,56 +1609,56 @@ Retry: ''' 将当前文件信息实例化为控件。 ''' Public Function ToListItem(OnClick As MyListItem.ClickEventHandler, Optional OnSaveClick As MyIconButton.ClickEventHandler = Nothing, - Optional BadDisplayName As Boolean = False) As MyListItem + Optional BadDisplayName As Boolean = False) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '获取描述信息 + Dim Title As String = If(BadDisplayName, FileName, DisplayName) + Dim Info As New List(Of String) + If Title <> FileName.BeforeLast(".") Then Info.Add(FileName.BeforeLast(".")) + If Dependencies.Any Then Info.Add(Dependencies.Count & " 项前置") + If GameVersions.All( + Function(VerName) + Return Not VerName.Contains(".") OrElse {"w", "snapshot", "rc", "pre", "experimental", "-"}.Any(Function(s) VerName.ContainsF(s, True)) + End Function) Then Info.Add($"游戏版本 {GameVersions.Join("、"c)}") + If DownloadCount > 0 Then 'CurseForge 的下载次数经常错误地返回 0 + Info.Add("下载 " & If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次", DownloadCount & " 次")) + End If + Info.Add("更新于 " & GetTimeSpanString(ReleaseDate - Date.Now, False)) + If Status <> CompFileStatus.Release Then Info.Add(StatusDescription) - '获取描述信息 - Dim Title As String = If(BadDisplayName, FileName, DisplayName) - Dim Info As New List(Of String) - If Title <> FileName.BeforeLast(".") Then Info.Add(FileName.BeforeLast(".")) - If Dependencies.Any Then Info.Add(Dependencies.Count & " 项前置") - If GameVersions.All(Function(v) Not IsVersionNameLikeRelease(v)) Then Info.Add($"游戏版本 {Join(GameVersions, "、")}") - If DownloadCount > 0 Then 'CurseForge 的下载次数经常错误地返回 0 - Info.Add("下载 " & If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次", DownloadCount & " 次")) - End If - Info.Add("更新于 " & GetTimeSpanString(ReleaseDate - Date.Now, False)) - If Status <> CompFileStatus.Release Then Info.Add(StatusDescription) + '建立控件 + Dim NewItem As New MyListItem With { + .Title = Title, + .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Me, + .Info = Info.Join("，"c) + } + Select Case Status + Case CompFileStatus.Release + NewItem.Logo = PathImage & "Icons/R.png" + Case CompFileStatus.Beta + NewItem.Logo = PathImage & "Icons/B.png" + Case Else 'Alpha + NewItem.Logo = PathImage & "Icons/A.png" + End Select + AddHandler NewItem.Click, OnClick - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Title, - .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Me, - .Info = Info.Join("，") - } - Select Case Status - Case CompFileStatus.Release - NewItem.Logo = PathImage & "Icons/R.png" - Case CompFileStatus.Beta - NewItem.Logo = PathImage & "Icons/B.png" - Case Else 'Alpha - NewItem.Logo = PathImage & "Icons/A.png" - End Select - AddHandler NewItem.Click, OnClick - - '建立另存为按钮 - If OnSaveClick IsNot Nothing Then - Dim BtnSave As New MyIconButton With {.Logo = Logo.IconButtonSave, .ToolTip = "另存为"} - ToolTipService.SetPlacement(BtnSave, Primitives.PlacementMode.Center) - ToolTipService.SetVerticalOffset(BtnSave, 30) - ToolTipService.SetHorizontalOffset(BtnSave, 2) - AddHandler BtnSave.Click, OnSaveClick - NewItem.Buttons = {BtnSave} - End If - - '结束 - Return NewItem + '建立另存为按钮 + If OnSaveClick IsNot Nothing Then + Dim BtnSave As New MyIconButton With {.Logo = Logo.IconButtonSave, .ToolTip = "另存为"} + ToolTipService.SetPlacement(BtnSave, Primitives.PlacementMode.Center) + ToolTipService.SetVerticalOffset(BtnSave, 30) + ToolTipService.SetHorizontalOffset(BtnSave, 2) + AddHandler BtnSave.Click, OnSaveClick + NewItem.Buttons = {BtnSave} + End If + Return NewItem + End Function) With {.Height = 42} End Function - '辅助函数 - Public Overrides Function ToString() As String Return $"{Id}: {FileName}" End Function - End Class '获取 @@ -1591,29 +1677,42 @@ Retry: If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存 TargetProject = CompProjectCache(ProjectId) ElseIf FromCurseForge Then 'CurseForge - TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data")) + TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId)("data")) Else 'Modrinth - TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True)) + TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId)) End If '获取工程对象的文件列表 If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回，这时候前置可能没获取（#5173） Log("[Comp] 开始获取文件列表：" & ProjectId) - Dim ResultJsonArray As JArray + Dim ResultJsonArray As JArray = Nothing If FromCurseForge Then 'CurseForge - 'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522） - ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=10000", IsJson:=True)("data") - '之前只请求一部分文件的方法备份如下： - 'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件 - ' ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data") - 'Else '否则使用全部文件 - ' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data") - 'End If + For RetryCount As Integer = 0 To 2 + Dim ResultJson As JObject = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=" & + (10000 + RetryCount)) '每次重试多请求一个文件，以避免触发 CDN 缓存 + 'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522） + '之前只请求一部分文件的方法备份如下： + 'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件 + ' ResultJsonArray = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json")("data") + 'Else '否则使用全部文件 + ' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999")("data") + 'End If + If ResultJson("pagination")("resultCount").ToObject(Of Integer) = ResultJson("pagination")("totalCount").ToObject(Of Integer) Then + ResultJsonArray = ResultJson("data") + Exit For + ElseIf RetryCount < 2 Then + Log($"[Comp] CurseForge 返回的文件列表存在缺失，即将进行第 {RetryCount + 1} 次重试", LogLevel.Debug) '#6224 + Log($"[Comp] 返回的原始内容如下：{vbCrLf}{ResultJson}") + Else + Log($"[Comp] CurseForge 返回的文件列表存在缺失，返回的原始内容如下：{vbCrLf}{ResultJson}") + Throw New Exception("CurseForge 返回的文件列表存在缺失") + End If + Next Else 'Modrinth - ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True) + ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version?include_changelog=false") End If - CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)). + CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Types)). Where(Function(a) a.Available).ToList. Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项（#1330） End If @@ -1622,13 +1721,13 @@ Retry: Dim UndoneDeps = Deps.Where(Function(f) Not CompProjectCache.ContainsKey(f)).ToList '获取前置工程信息 If UndoneDeps.Any Then - Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置：{Join(UndoneDeps, "，")}") + Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置：{UndoneDeps.Join("，"c)}") Dim Projects As JArray If TargetProject.FromCurseForge Then - Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods", - "POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data") + Projects = DlModRequest("https://api.curseforge.com/v1/mods", + HttpMethod.Post, "{""modIds"": [" & UndoneDeps.Join(","c) & "]}", "application/json")("data") Else - Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]", IsJson:=True) + Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{UndoneDeps.Join(""",""")}""]") End If For Each Project In Projects Dim Unused As New CompProject(Project) '在 New 的时候会添加缓存以便之后读取 diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb index 33fe597..5363333 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb @@ -2,7 +2,9 @@ '构造函数 Private TempFolder As String - Public Sub New(UUID As Integer) + Private TargetInstance As McInstance + Public Sub New(Optional TargetInstance As McInstance = Nothing) + Me.TargetInstance = TargetInstance '构建文件结构 TempFolder = RequestTaskTempFolder() Directory.CreateDirectory(TempFolder & "Temp\") @@ -77,7 +79,7 @@ End Try Next If LatestLog IsNot Nothing AndAlso LatestLog.Any Then - Dim RawOutput As String = Join(LatestLog, vbCrLf) + Dim RawOutput As String = LatestLog.Join(vbCrLf) Log("[Crash] 以下为游戏输出的最后一段内容：" & vbCrLf & RawOutput) WriteFile(TempFolder & "RawOutput.log", RawOutput) AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TempFolder & "RawOutput.log", LatestLog.ToArray)) @@ -96,7 +98,7 @@ Try Dim Info As New FileInfo(FilePath) If Info.Exists AndAlso Info.Length > 0 AndAlso Not FilePath.EndsWithF(".jar", True) Then - ExtractFile(FilePath, TempFolder & "Temp\") + ExtractCompressedFile(FilePath, TempFolder & "Temp\") Log("[Crash] 已解压导入的日志文件：" & FilePath) GoTo Extracted End If @@ -111,7 +113,7 @@ Extracted: For Each TargetFile As FileInfo In New DirectoryInfo(TempFolder & "Temp\").EnumerateFiles.ToList() Try If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For - Dim Ext As String = TargetFile.Extension.ToLower + Dim Ext As String = TargetFile.Extension.Lower If Ext = ".log" OrElse Ext = ".txt" Then AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray))) Else @@ -145,7 +147,7 @@ Extracted: DirectFile = Nothing Dim AllFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))) For Each LogFile In AnalyzeRawFiles - Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower + Dim MatchName As String = GetFileNameFromPath(LogFile.Key).Lower Dim TargetType As AnalyzeFileType If MatchName.StartsWithF("hs_err") Then TargetType = AnalyzeFileType.HsErr @@ -227,7 +229,7 @@ Extracted: '创建文件名词典 Dim FileNameDict As New Dictionary(Of String, KeyValuePair(Of String, String())) For Each SelectedFile In SelectedFiles - FileNameDict(GetFileNameFromPath(SelectedFile.Key).ToLower) = SelectedFile + FileNameDict(GetFileNameFromPath(SelectedFile.Key).Lower) = SelectedFile OutputFiles.Add(SelectedFile.Key) Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为 Minecraft 或启动器日志") Next @@ -305,7 +307,7 @@ Extracted: ''' 输出字符串的前后某些行，并统一行尾为 vbLf (正则 \n)、删除空行和重复行。 ''' Private Function GetHeadTailLines(Raw As String(), HeadLines As Integer, TailLines As Integer) As String - If Raw.Length <= HeadLines + TailLines Then Return Join(Raw.Distinct, vbLf) + If Raw.Length <= HeadLines + TailLines Then Return Raw.Distinct.Join(vbLf) Dim Lines As New List(Of String) Dim RealHeadLines As Integer = 0, ViewedLines As Integer For ViewedLines = 0 To Raw.Length - 1 @@ -339,6 +341,7 @@ Extracted: ''' 导致崩溃的原因枚举。 ''' Private Enum CrashReason + Java虚拟机参数有误 Mod文件被解压 MixinBootstrap缺失 内存不足 @@ -388,7 +391,7 @@ Extracted: ''' ''' 根据 AnalyzeLogs 与可能的版本信息分析崩溃原因。 ''' - Public Sub Analyze(Optional Version As McVersion = Nothing) + Public Sub Analyze() Log("[Crash] 步骤 3：分析崩溃原因") LogAll = If(LogMc, If(LogMcDebug, "")) & If(LogHs, "") & If(LogCrash, "") @@ -445,7 +448,7 @@ Done: Else Log("[Crash] 步骤 3：分析崩溃原因完成，找到 " & CrashReasons.Count & " 条可能的原因") For Each Reason In CrashReasons - Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Any, "（" & Join(Reason.Value, "；") & "）", "")) + Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Any, "（" & Reason.Value.Join("；"c) & "）", "")) Next End If End Sub @@ -461,7 +464,7 @@ Done: Else CrashReasons.Add(Reason, New List(Of String)(If(Additional, {}))) End If - Log("[Crash] 可能的崩溃原因：" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Any, "（" & Join(Additional, "；") & "）", "")) + Log("[Crash] 可能的崩溃原因：" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Any, "（" & Additional.Join("；"c) & "）", "")) End Sub Private Sub AppendReason(Reason As CrashReason, Additional As String) AppendReason(Reason, If(String.IsNullOrEmpty(Additional), Nothing, New List(Of String) From {Additional})) @@ -482,10 +485,12 @@ Done: '崩溃报告分析，高优先级 If LogCrash IsNot Nothing Then If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高) + If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071 End If '游戏日志分析 If LogMc IsNot Nothing Then + If LogMc.Contains("Unrecognized option:") Then AppendReason(CrashReason.Java虚拟机参数有误) If LogMc.Contains("Found multiple arguments for option fml.forgeVersion, but you asked for only one") Then AppendReason(CrashReason.版本Json中存在多个Forge) If LogMc.Contains("The driver does not appear to support OpenGL") Then AppendReason(CrashReason.显卡不支持OpenGL) If LogMc.Contains("java.lang.ClassCastException: java.base/jdk") Then AppendReason(CrashReason.使用JDK) @@ -508,13 +513,13 @@ Done: If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式) If LogMc.Contains("java.lang.OutOfMemoryError") OrElse LogMc.Contains("an out of memory error") Then AppendReason(CrashReason.内存不足) If LogMc.Contains("java.lang.RuntimeException: Shaders Mod detected. Please remove it, OptiFine has built-in support for shaders.") Then AppendReason(CrashReason.ShadersMod与OptiFine同时安装) - If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容) + If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") OrElse LogMc.Contains("java.lang.NoSuchMethodError: 'void sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容) If LogMc.Contains("1282: Invalid operation") Then AppendReason(CrashReason.光影或资源包导致OpenGL1282错误) If LogMc.Contains("signer information does not match signer information of other classes in the same package") Then AppendReason(CrashReason.文件或内容校验失败, If(RegexSeek(LogMc, "(?<=class "")[^']+(?=""'s signer information)"), "").TrimEnd(vbCrLf)) If LogMc.Contains("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足) If LogMc.Contains("java.lang.NoSuchMethodError: net.minecraft.world.server.ChunkManager$ProxyTicketManager.shouldForceTicks(J)Z") AndAlso LogMc.Contains("OptiFine") Then AppendReason(CrashReason.OptiFine导致无法加载世界) If LogMc.Contains("Unsupported class file major version") Then AppendReason(CrashReason.Java版本不兼容) - If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") Then AppendReason(CrashReason.NightConfig的Bug) + If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") AndAlso Not CrashReasons.ContainsKey(CrashReason.Mod配置文件导致游戏崩溃) Then AppendReason(CrashReason.NightConfig的Bug) If LogMc.Contains("Cannot find launch target fmlclient, unable to launch") Then AppendReason(CrashReason.Forge安装不完整) If LogMc.Contains("Invalid paths argument, contained no existing paths") AndAlso LogMc.Contains("libraries\net\minecraftforge\fmlcore") Then AppendReason(CrashReason.Forge安装不完整) If LogMc.Contains("Invalid module name: '' is not a Java identifier") Then AppendReason(CrashReason.Mod名称包含特殊字符) @@ -533,12 +538,12 @@ Done: '确定的 Mod 导致崩溃 If LogMc.Contains("Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(RegexSeek(LogMc, "(?<=Caught exception from )[^\n]+?")?.TrimEnd((vbCrLf & " ").ToCharArray))) 'Mod 重复 / 前置问题 - If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]{1}:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase)) + If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase)) If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase)) If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList) If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase)) - If LogMc.Contains("Incompatible mods found!") Then '#5006 - AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "")) + If LogMc.Contains("Incompatible mods found!") Then '#5006, #5115 + AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息：").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray)) End If If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then AppendReason(CrashReason.Mod缺少前置或MC版本错误, @@ -602,7 +607,7 @@ Done: Return True End If 'JSON 名称匹配 - For Each JsonName In RegexSearch(LogText, "(?<=^[^\t]+[ \[{(]{1})[^ \[{(]+\.[^ ]+(?=\.json)", RegularExpressions.RegexOptions.Multiline) + For Each JsonName In RegexSearch(LogText, "(?<=^[^\t]+[ \[{(])[^ \[{(]+\.[^ ]+(?=\.json)", RegularExpressions.RegexOptions.Multiline) AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(JsonName.Replace("mixins", "mixin").Replace(".mixin", "").Replace("mixin.", ""))) Return True @@ -618,9 +623,9 @@ Done: Dim IsMixin As Boolean = MixinAnalyze(LogMc) '常规信息 If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, RegexSeek(LogMc, "(?<=the game will display an error screen and halt.[\n\r]+[^\n]+?Exception: )[\s\S]+?(?=\n\tat)")?.Trim(vbCrLf)) - If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf)) - If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf)) - If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf)) + If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf)) + If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf)) + If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf)) If Not IsMixin AndAlso LogMc.Contains("due to errors, provided by ") Then '在 #3104 的情况下，这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败 AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray))) End If @@ -654,7 +659,7 @@ Done: End If 'Mod 解析错误（常见于 Fabric 前置校验失败） If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错) - 'Mixin 失败可以导致大量 Mod 实例创建失败 + 'Mixin 失败可以导致大量 Mod 实例创建失败，因此需要放到低优先级中 If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf))) '注意：Fabric 的 Warnings were found! 不一定是崩溃原因，它可能是单纯的警报 End If @@ -707,20 +712,20 @@ NextStack: Dim Word As String = Splited(i) If Word.Length <= 2 OrElse Word.StartsWithF("func_") Then Continue For If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top", "mcp", - "core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi", "impl", "data", "pool", "task", - "forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world", "lwjgl", - "gitlab", "common", "server", "config", "mixins", "compat", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events", - "preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service", - "fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge", + "core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "fake", "oshi", "impl", "data", "pool", "task", + "forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world", "lwjgl", "fakes", + "fabric", "gitlab", "common", "server", "config", "mixins", "compat", "loader", "launch", "script", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events", + "preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service", "scripts", "network", + "fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge", "external", "injection", "listeners", "scheduler", "minecraft", "universal", "multipart", "neoforged", "microsoft", - "transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill" - }.Contains(Word.ToLower) Then Continue For + "transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill", "concurrent" + }.Contains(Word.Lower) Then Continue For PossibleWords.Add(Word.Trim) Next Next PossibleWords = PossibleWords.Distinct.ToList Log("[Crash] 从堆栈信息中找到 " & PossibleWords.Count & " 个可能的 Mod ID 关键词") - If PossibleWords.Any Then Log("[Crash] - " & Join(PossibleWords, ", ")) + If PossibleWords.Any Then Log("[Crash] - " & PossibleWords.Join(", ")) If PossibleWords.Count > 10 Then Log("[Crash] 关键词过多，考虑匹配出错，不纳入考虑") Return New List(Of String) @@ -768,8 +773,8 @@ NextStack: Dim HintLines As New List(Of String) For Each KeyWord As String In Keywords For Each ModString As String In ModNameLines - Dim RealModString As String = ModString.ToLower.Replace("_", "") - If Not RealModString.Contains(KeyWord.ToLower.Replace("_", "")) Then Continue For + Dim RealModString As String = ModString.Lower.Replace("_", "") + If Not RealModString.Contains(KeyWord.Lower.Replace("_", "")) Then Continue For If RealModString.Contains("minecraft.jar") OrElse RealModString.Contains(" forge-") OrElse RealModString.Contains(" mixin-") Then Continue For HintLines.Add(ModString.Trim(vbCrLf.ToCharArray)) Exit For @@ -856,20 +861,21 @@ NextStack: ''' ''' 弹出崩溃弹窗，并指导导出崩溃报告。 ''' - Public Sub Output(IsHandAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing) + Public Sub Output(IsManualAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing) '弹窗提示 FrmMain.ShowWindowToTop() - Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"), - "确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"), - Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing, + Dim Detail As String = GetAnalyzeResult(IsManualAnalyze) + Select Case MyMsgBox(Detail, If(IsManualAnalyze, "错误报告分析结果", "Minecraft 出现错误"), + "确定", If(IsManualAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsManualAnalyze, "", "导出错误报告"), + Button2Action:=If(IsManualAnalyze OrElse DirectFile Is Nothing, Nothing, Sub() '弹窗选择：查看日志 If File.Exists(DirectFile.Value.Key) Then - ShellOnly(DirectFile.Value.Key) + StartProcess(DirectFile.Value.Key) Else Dim FilePath As String = PathTemp & "Crash.txt" - WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf)) - ShellOnly(FilePath) + WriteFile(FilePath, DirectFile.Value.Value.Join(vbCrLf)) + StartProcess(FilePath) End If End Sub)) Case 3 @@ -902,8 +908,7 @@ NextStack: If File.Exists(OutputFile) Then If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile)) Dim FileContent As String = ReadFile(OutputFile, FileEncoding) - FileContent = FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")) - FileContent = FilterUserName(FileContent, "*") + FileContent = FilterUserName(FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")), "*") WriteFile(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding) Log($"[Crash] 导出文件：{FileName}，编码：{FileEncoding.HeaderName}") End If @@ -911,13 +916,18 @@ NextStack: '导出报告 Compression.ZipFile.CreateFromDirectory(TempFolder & "Report\", FileAddress) DeleteDirectory(TempFolder & "Report\") - Hint("错误报告已导出！", HintType.Finish) + Hint("错误报告已导出！", HintType.Green) Catch ex As Exception Log(ex, "导出错误报告失败", LogLevel.Feedback) Return End Try OpenExplorer(FileAddress) End Select + '上报 + If IsManualAnalyze Then Return + Telemetry("Minecraft 崩溃", + "Version", If(TargetInstance Is Nothing, "null", TargetInstance.VersionDisplayName), + "Detail", FilterUserName(Detail, "*")) End Sub ''' ''' 获取崩溃分析的结果描述。 @@ -938,6 +948,8 @@ NextStack: For Each Reason In CrashReasons Dim Additional As List(Of String) = Reason.Value Select Case Reason.Key + Case CrashReason.Java虚拟机参数有误 + Results.Add("由于 Java 参数有误，导致游戏无法继续运行。\n请检查高级选项中的 Java 虚拟机参数和游戏参数设置是否有误。") Case CrashReason.Mod文件被解压 Results.Add("由于 Mod 文件被解压了，导致游戏无法继续运行。\n直接把整个 Mod 文件放进 Mod 文件夹中即可，若解压就会导致游戏出错。\n\n请删除 Mod 文件夹中已被解压的 Mod，然后再启动游戏。") Case CrashReason.内存不足 @@ -962,35 +974,35 @@ NextStack: End If Case CrashReason.Mod缺少前置或MC版本错误 If Additional.Any Then - Results.Add("由于未安装正确的前置 Mod，导致游戏退出。\n缺失的依赖项：\n - " & Join(Additional, "\n - ") & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") + Results.Add("由于未安装正确的前置 Mod，导致游戏退出。\n缺失的依赖项：\n - " & Additional.Join("\n - ") & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("由于未安装正确的前置 Mod，导致游戏退出。\n请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") End If Case CrashReason.堆栈分析发现关键字 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("你的游戏遇到了一些问题，PCL 为此找到了一个可疑的关键词：" & Additional.First & "。\n\n如果你知道某个关键词对应的 Mod，那么有可能就是它引起的错误，你也可以查看错误报告获取详情。\h") Else - Results.Add("你的游戏遇到了一些问题，PCL 为此找到了以下可疑的关键词：\n - " & Join(Additional, ", ") & "\n\n如果你知道某个关键词对应的 Mod，那么有可能就是它引起的错误，你也可以查看错误报告获取详情。\h") + Results.Add("你的游戏遇到了一些问题，PCL 为此找到了以下可疑的关键词：\n - " & Additional.Join(", ") & "\n\n如果你知道某个关键词对应的 Mod，那么有可能就是它引起的错误，你也可以查看错误报告获取详情。\h") End If Case CrashReason.堆栈分析发现Mod名称, CrashReason.怀疑Mod导致游戏崩溃 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("PCL 怀疑名为 " & Additional.First & " 的 Mod 导致了游戏出错，但不能完全确定。\n你可以尝试禁用此 Mod，然后观察游戏是否还会崩溃。\n\e\h") Else - Results.Add("PCL 怀疑以下 Mod 导致了游戏出错，但不能完全确定：\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") + Results.Add("PCL 怀疑以下 Mod 导致了游戏出错，但不能完全确定：\n - " & Additional.Join("\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") End If Case CrashReason.确定Mod导致游戏崩溃 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("名为 " & Additional.First & " 的 Mod 导致了游戏出错。\n你可以尝试禁用此 Mod，然后观察游戏是否还会崩溃。\n\e\h") Else - Results.Add("以下 Mod 导致了游戏出错：\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") + Results.Add("以下 Mod 导致了游戏出错：\n - " & Additional.Join("\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") End If Case CrashReason.ModMixin失败 If Additional.Count = 0 Then Results.Add("部分 Mod 注入失败，导致游戏出错。\n这一般代表着部分 Mod 与其他 Mod 或当前环境不兼容，或是它存在 Bug。\n你可以尝试逐步禁用 Mod，然后观察游戏是否还会崩溃，以此定位导致崩溃的 Mod。\n\e\h") - ElseIf Additional.Count = 1 Then + ElseIf Additional.IsSingle Then Results.Add("名为 " & Additional.First & " 的 Mod 注入失败，导致游戏出错。\n这一般代表着它与其他 Mod 或当前环境不兼容，或是它存在 Bug。\n你可以尝试禁用此 Mod，然后观察游戏是否还会崩溃。\n\e\h") Else - Results.Add("以下 Mod 导致了游戏出错：\n - " & Join(Additional, "\n - ") & "\n这一般代表着它们与其他 Mod 或当前环境不兼容，或是它存在 Bug。\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") + Results.Add("以下 Mod 导致了游戏出错：\n - " & Additional.Join("\n - ") & "\n这一般代表着它们与其他 Mod 或当前环境不兼容，或是它存在 Bug。\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") End If Case CrashReason.Mod配置文件导致游戏崩溃 If Additional(1) Is Nothing Then @@ -999,28 +1011,36 @@ NextStack: Results.Add("名为 " & Additional.First & " 的 Mod 导致了游戏出错：\n其配置文件 " & Additional(1) & " 存在异常，无法读取。") End If Case CrashReason.Mod初始化失败 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("名为 " & Additional.First & " 的 Mod 初始化失败，导致游戏无法继续加载。\n你可以尝试禁用此 Mod，然后观察游戏是否还会崩溃。\n\e\h") Else - Results.Add("以下 Mod 初始化失败，导致游戏出错：\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") + Results.Add("以下 Mod 初始化失败，导致游戏出错：\n - " & Additional.Join("\n - ") & "\n\n你可以尝试依次禁用上述 Mod，然后观察游戏是否还会崩溃。\n\e\h") End If Case CrashReason.特定方块导致崩溃 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("游戏似乎因为方块 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并观察游戏的运行情况：\n - 若正常运行，则是该方块导致出错，你或许需要使用一些方式删除此方块。\n - 若仍然出错，问题就可能来自其他原因……\h") Else Results.Add("游戏似乎因为世界中的某些方块出现了问题。\n\n你可以创建一个新世界，并观察游戏的运行情况：\n - 若正常运行，则是某些方块导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h") End If Case CrashReason.Mod重复安装 If Additional.Count >= 2 Then - Results.Add("你重复安装了多个相同的 Mod：\n - " & Join(Additional, "\n - ") & "\n\n每个 Mod 只能出现一次，请删除重复的 Mod，然后再启动游戏。") + Results.Add("你重复安装了多个相同的 Mod：\n - " & Additional.Join("\n - ") & "\n\n每个 Mod 只能出现一次，请删除重复的 Mod，然后再启动游戏。") Else Results.Add("你可能重复安装了多个相同的 Mod，导致游戏出错。\n\n每个 Mod 只能出现一次，请删除重复的 Mod，然后再启动游戏。\e\h") End If Case CrashReason.特定实体导致崩溃 - If Additional.Count = 1 Then - Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况：\n - 若正常运行，则是该实体导致出错，你或许需要使用一些方式删除此实体。\n - 若仍然出错，问题就可能来自其他原因……\h") + If Additional.IsSingle Then + If Additional.First.Contains("minecraft:player") Then + If Additional.First.Contains(" ") Then + Results.Add($"游戏因为位于 {Additional.First.AfterFirst(" ")} 的玩家实体导致了崩溃。\h") + Else + Results.Add($"游戏因为玩家实体导致了崩溃。\h") + End If + Else + Results.Add($"游戏因为实体 {Additional.First} 导致了崩溃。\h") + End If Else - Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，观察游戏的运行情况：\n - 若正常运行，则是某些实体导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h") + Results.Add($"游戏因为下列实体导致了崩溃：{Additional.Join("、"c)}\h") End If Case CrashReason.OptiFine与Forge不兼容 Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容，导致了游戏崩溃。\n\n请前往 OptiFine 官网（https://optifine.net/downloads）查看 OptiFine 所兼容的 Forge 版本，并严格按照对应版本重新安装游戏。") @@ -1057,31 +1077,31 @@ NextStack: Case CrashReason.Forge安装不完整 Results.Add("由于安装的 Forge 文件丢失，导致游戏无法正常运行。\n请重新安装一次相同版本的 Forge，然后再启动游戏。\n在打包游戏时删除 libraries 文件夹可能导致此错误。\h") Case CrashReason.Fabric报错 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("Fabric 提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("Fabric 可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") End If Case CrashReason.Mod互不兼容 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("你所安装的 Mod 不兼容：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("你所安装的 Mod 不兼容，Mod 加载器可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") End If Case CrashReason.Mod加载器报错 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("Mod 加载器提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("Mod 加载器可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") End If Case CrashReason.Fabric报错并给出解决方案 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("Fabric 提供了以下解决方案：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("Fabric 可能已经提供了解决方案，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") End If Case CrashReason.Forge报错 - If Additional.Count = 1 Then + If Additional.IsSingle Then Results.Add("Forge 提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。") Else Results.Add("Forge 可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\h") @@ -1093,7 +1113,7 @@ NextStack: End Select Next - Return Join(Results, "\n\n此外，"). + Return Results.Join("\n\n此外，"). Replace("\n", vbCrLf). Replace("\h", ""). Replace("\e", If(IsHandAnalyze, "", vbCrLf & "你可以查看错误报告了解错误具体是如何发生的。")). @@ -1102,7 +1122,7 @@ NextStack: If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "", vbCrLf & "如果要寻求帮助，请把错误报告文件发给对方，而不是发送这个窗口的照片或者截图。" & If(If(PageSetupSystem.IsLauncherNewest(), True), "", - vbCrLf & vbCrLf & "此外，你正在使用老版本 PCL，更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。")) + vbCrLf & vbCrLf & "此外，你正在使用老版本 PCL，更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 [设置 → 其他 → 启动器 → 检查更新] 更新 PCL。")) End Function End Class diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb index ef7e020..52c5a06 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb @@ -6,40 +6,40 @@ ''' 返回某 Minecraft 版本对应的原版主 Jar 文件的下载信息，要求对应依赖版本已存在。 ''' 失败则抛出异常，不需要下载则返回 Nothing。 ''' - Public Function DlClientJarGet(Version As McVersion, ReturnNothingOnFileUseable As Boolean) As NetFile + Public Function DlClientJarGet(Instance As McInstance, ReturnNothingOnFileUseable As Boolean) As NetFile '获取底层继承版本 Try - Do While Not String.IsNullOrEmpty(Version.InheritVersion) - Version = New McVersion(Version.InheritVersion) + Do While Not String.IsNullOrEmpty(Instance.InheritName) + Instance = New McInstance(Instance.InheritName) Loop Catch ex As Exception Log(ex, "获取底层继承版本失败") End Try '检查 Json 是否标准 - If Version.JsonObject("downloads") Is Nothing OrElse Version.JsonObject("downloads")("client") Is Nothing OrElse Version.JsonObject("downloads")("client")("url") Is Nothing Then - Throw New Exception("底层版本 " & Version.Name & " 中无 jar 文件下载信息") + If Instance.JsonObject("downloads") Is Nothing OrElse Instance.JsonObject("downloads")("client") Is Nothing OrElse Instance.JsonObject("downloads")("client")("url") Is Nothing Then + Throw New Exception("底层版本 " & Instance.Name & " 中无 jar 文件下载信息") End If '检查文件 - Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(Version.JsonObject("downloads")("client")("size"), -1), Hash:=Version.JsonObject("downloads")("client")("sha1")) - If ReturnNothingOnFileUseable AndAlso Checker.Check(Version.Path & Version.Name & ".jar") Is Nothing Then Return Nothing '通过校验 + Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(Instance.JsonObject("downloads")("client")("size"), -1), Hash:=Instance.JsonObject("downloads")("client")("sha1")) + If ReturnNothingOnFileUseable AndAlso Checker.Check(Instance.PathVersion & Instance.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) + Dim JarUrl As String = Instance.JsonObject("downloads")("client")("url") + Return New NetFile(DlSourceLauncherOrMetaGet(JarUrl), Instance.PathVersion & Instance.Name & ".jar", Checker) End Function ''' ''' 返回某 Minecraft 版本对应的原版主 AssetIndex 文件的下载信息，要求对应依赖版本已存在。 ''' 若未找到，则会返回 Legacy 资源文件或 Nothing。 ''' - Public Function DlClientAssetIndexGet(Version As McVersion) As NetFile + Public Function DlClientAssetIndexGet(Instance As McInstance) As NetFile '获取底层继承版本 - Do While Not String.IsNullOrEmpty(Version.InheritVersion) - Version = New McVersion(Version.InheritVersion) + Do While Not String.IsNullOrEmpty(Instance.InheritName) + Instance = New McInstance(Instance.InheritName) Loop '获取信息 - Dim IndexInfo = McAssetsGetIndex(Version, True, True) - Dim IndexAddress As String = PathMcFolder & "assets\indexes\" & IndexInfo("id").ToString & ".json" - Log("[Download] 版本 " & Version.Name & " 对应的资源文件索引为 " & IndexInfo("id").ToString) + Dim IndexInfo = McAssetsGetIndex(Instance, True, True) + Dim IndexAddress As String = McFolderSelected & "assets\indexes\" & IndexInfo("id").ToString & ".json" + Log("[Download] 版本 " & Instance.Name & " 对应的资源文件索引为 " & IndexInfo("id").ToString) Dim IndexUrl As String = If(IndexInfo("url"), "") If IndexUrl = "" Then Return Nothing @@ -51,12 +51,12 @@ ''' ''' 构造补全某 Minecraft 版本的所有文件的加载器列表。失败会抛出异常。 ''' - Public Function DlClientFix(Version As McVersion, CheckAssetsHash As Boolean, AssetsIndexBehaviour As AssetsIndexExistsBehaviour) As List(Of LoaderBase) + Public Function DlClientFix(Instance As McInstance, CheckAssetsHash As Boolean, AssetsIndexBehaviour As AssetsIndexExistsBehaviour) As List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase) #Region "下载支持库文件" Dim LoadersLib As New List(Of LoaderBase) From { - New LoaderTask(Of String, List(Of NetFile))("分析缺失支持库文件", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(Version)) With {.ProgressWeight = 1}, + New LoaderTask(Of String, List(Of NetFile))("分析缺失支持库文件", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibNetFilesFromInstance(Instance)) With {.ProgressWeight = 1}, New LoaderDownload("下载支持库文件", New List(Of NetFile)) With {.ProgressWeight = 15} } '构造加载器 @@ -64,7 +64,7 @@ #End Region #Region "下载资源文件" - If ShouldIgnoreFileCheck(Version) Then + If ShouldIgnoreFileCheck(Instance) Then Log("[Download] 已跳过所有 Assets 检查") Else Dim LoadersAssets As New List(Of LoaderBase) @@ -72,9 +72,11 @@ LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析资源文件索引地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Try - Dim IndexFile = DlClientAssetIndexGet(Version) - Dim IndexFileInfo As New FileInfo(IndexFile.LocalPath) - If AssetsIndexBehaviour <> AssetsIndexExistsBehaviour.AlwaysDownload AndAlso IndexFile.Check.Check(IndexFile.LocalPath) Is Nothing Then + Dim IndexFile = DlClientAssetIndexGet(Instance) + If IndexFile Is Nothing Then + Task.Output = New List(Of NetFile) + Log("[Download] 未找到版本 " & Instance.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", LogLevel.Debug) + ElseIf AssetsIndexBehaviour <> AssetsIndexExistsBehaviour.AlwaysDownload AndAlso IndexFile.Check.Check(IndexFile.LocalPath) Is Nothing Then Task.Output = New List(Of NetFile) Else Task.Output = New List(Of NetFile) From {IndexFile} @@ -92,7 +94,12 @@ Dim RealAddress As String = Nothing LoadersAssetsUpdate.Add(New LoaderTask(Of String, List(Of NetFile))("后台分析资源文件索引地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) - Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Version) + Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Instance) + If BackAssetsFile Is Nothing Then + Log("[Download] 未找到版本 " & Instance.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", LogLevel.Debug) + Task.Interrupt() + Throw New ThreadInterruptedException + End If RealAddress = BackAssetsFile.LocalPath TempAddress = PathTemp & "Cache\" & BackAssetsFile.LocalName BackAssetsFile.LocalPath = TempAddress @@ -100,7 +107,7 @@ '检查是否需要更新：每天只更新一次 If File.Exists(RealAddress) AndAlso Math.Abs((File.GetLastWriteTime(RealAddress).Date - Now.Date).TotalDays) < 1 Then Log("[Download] 无需更新资源文件索引，取消") - Task.Abort() + Task.Interrupt() End If End Sub)) LoadersAssetsUpdate.Add(New LoaderDownload("后台下载资源文件索引", New List(Of NetFile))) @@ -114,14 +121,12 @@ Updater.Start() End If '获取资源文件地址 - LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析缺失资源文件", - Sub(Task As LoaderTask(Of String, List(Of NetFile))) - Task.Output = McAssetsFixList(Version, CheckAssetsHash, Task) - End Sub) With {.ProgressWeight = 3}) + LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("获取资源文件列表", + Sub(Task) Task.Output = McAssetsFixList(Instance, CheckAssetsHash, Task)) With {.ProgressWeight = 0.01}) '下载资源文件 LoadersAssets.Add(New LoaderDownload("下载资源文件", New List(Of NetFile)) With {.ProgressWeight = 25}) '构造加载器 - Loaders.Add(New LoaderCombo(Of String)("下载资源文件（主加载器）", LoadersAssets) With {.Block = False, .Show = False, .ProgressWeight = 30.5}) + Loaders.Add(New LoaderCombo(Of String)("下载资源文件（主加载器）", LoadersAssets) With {.Block = False, .Show = False, .ProgressWeight = 27}) End If #End Region @@ -146,6 +151,25 @@ #Region "DlClientList | Minecraft 客户端 版本列表" + ''' + ''' 所有正式版的 Minecraft Drop 序数。 + ''' 若从未完成过获取，返回 Nothing；否则必定存在元素，且从高到低排列。 + ''' + Public Property AllDrops As List(Of Integer) + Get + If _AllDrops Is Nothing Then + _AllDrops = Settings.Get("CacheDrops").ToString. + Split(",".ToCharArray, StringSplitOptions.RemoveEmptyEntries).Select(Function(d) CInt(Val(d))).ToList() + End If + Return If(_AllDrops.Any, _AllDrops, Nothing) '不要将 _AllDrops 再设为 Nothing，以防止反复获取设置尝试初始化 + End Get + Set(value As List(Of Integer)) + _AllDrops = value + Settings.Set("CacheDrops", value.Join(","c)) + End Set + End Property + Private _AllDrops As List(Of Integer) = Nothing + '主加载器 Public Structure DlClientListResult ''' @@ -160,10 +184,6 @@ ''' 获取到的 Json 数据。 ''' Public Value As JObject - '''' - '''' 官方源的失败原因。若没有则为 Nothing。 - '''' - 'Public OfficialError As Exception End Structure ''' ''' Minecraft 客户端 版本列表，主加载器。 @@ -171,7 +191,7 @@ ''' Public DlClientListLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Main", AddressOf DlClientListMain) Private Sub DlClientListMain(Loader As LoaderTask(Of String, DlClientListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 30), @@ -188,6 +208,14 @@ New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 60 + 60) }, Loader.IsForceRestarting) End Select + '提取所有 Drop 序数 + Dim Drops As New List(Of Integer) + For Each Version As JObject In Loader.Output.Value("versions") + Dim Drop As Integer = McVersion.VersionToDrop(Version("id")) + If Drop = 209 Then Continue For + Drops.Add(Drop) + Next + AllDrops = Drops.Distinct.OrderByDescending(Function(d) d).ToList() End Sub '各个下载源的分加载器 @@ -195,16 +223,15 @@ ''' Minecraft 客户端 版本列表，Mojang 官方源加载器。 ''' Public DlClientListMojangLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Mojang", AddressOf DlClientListMojangMain) - Private IsNewClientVersionHinted As Boolean = False Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult)) - Dim StartTime As Long = GetTimeTick() - Dim Json As JObject = NetGetCodeByRequestRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", IsJson:=True) + Dim StartTime As Long = GetTimeMs() + Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", RequireJson:=True)) Try Dim Versions As JArray = Json("versions") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）") '确定官方源是否可用 If Not DlPreferMojang Then - Dim DeltaTime = GetTimeTick() - StartTime + Dim DeltaTime = GetTimeMs() - StartTime DlPreferMojang = DeltaTime < 4000 Log($"[Download] Mojang 官方源加载耗时：{DeltaTime}ms，{If(DlPreferMojang, "可优先使用官方源", "不优先使用官方源")}") End If @@ -212,20 +239,25 @@ If File.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(ReadFile(PathTemp & "Cache\download.json"))) '返回 Loader.Output = New DlClientListResult With {.IsOfficial = True, .SourceName = "Mojang 官方源", .Value = Json} - '解析更新提示（Release） - Dim Version As String = Json("latest")("release") - If Setup.Get("ToolUpdateRelease") AndAlso Not Setup.Get("ToolUpdateReleaseLast") = "" AndAlso Version IsNot Nothing AndAlso Not Setup.Get("ToolUpdateReleaseLast") = Version Then - McDownloadClientUpdateHint(Version, Json) - IsNewClientVersionHinted = True - End If - McVersionHighest = Version.Split(".")(1) - Setup.Set("ToolUpdateReleaseLast", Version) - '解析更新提示（Snapshot） + 'MC 更新提示 + Static IsHinted As Boolean = False + Dim Version As String + '快照版 Version = Json("latest")("snapshot") - If Setup.Get("ToolUpdateSnapshot") AndAlso Not Setup.Get("ToolUpdateSnapshotLast") = "" AndAlso Version IsNot Nothing AndAlso Not Setup.Get("ToolUpdateSnapshotLast") = Version AndAlso Not IsNewClientVersionHinted Then + If Settings.Get("ToolUpdateSnapshot") AndAlso Not Settings.Get("ToolUpdateSnapshotLast") = "" AndAlso + Settings.Get("ToolUpdateSnapshotLast") <> Version AndAlso Not IsHinted Then + IsHinted = True McDownloadClientUpdateHint(Version, Json) End If - Setup.Set("ToolUpdateSnapshotLast", If(Version, "Nothing")) + Settings.Set("ToolUpdateSnapshotLast", If(Version, "Nothing")) + '正式版 + Version = Json("latest")("release") + If Settings.Get("ToolUpdateRelease") AndAlso Not Settings.Get("ToolUpdateReleaseLast") = "" AndAlso + Settings.Get("ToolUpdateReleaseLast") <> Version AndAlso Not IsHinted Then + IsHinted = True + McDownloadClientUpdateHint(Version, Json) + End If + Settings.Set("ToolUpdateReleaseLast", Version) Catch ex As Exception Throw New Exception("Minecraft 官方源版本列表解析失败", ex) End Try @@ -235,7 +267,7 @@ ''' Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain) Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult)) - Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", IsJson:=True) + Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", RequireJson:=True)) Try Dim Versions As JArray = Json("versions") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）") @@ -274,7 +306,7 @@ DlClientListLoader.WaitForExit(Id, IsForceRestart:=True) Case LoadState.Loading DlClientListLoader.WaitForExit(Id) - Case LoadState.Failed, LoadState.Aborted, LoadState.Waiting + Case LoadState.Failed, LoadState.Interrupted, LoadState.Waiting DlClientListLoader.WaitForExit(Id, IsForceRestart:=True) End Select '重新查找版本 @@ -312,15 +344,15 @@ ''' ''' 显示名称，已去除 HD_U 字样，如“1.12.2 C8”。 ''' - Public NameDisplay As String + Public DisplayName As String ''' ''' 原始文件名称，如“preview_OptiFine_1.11_HD_U_E1_pre.jar”。 ''' - Public NameFile As String + Public FileName As String ''' ''' 对应的版本名称，如“1.13.2-OptiFine_HD_U_E6”。 ''' - Public NameVersion As String + Public InstanceName As String ''' ''' 是否为测试版。 ''' @@ -353,7 +385,7 @@ ''' Public DlOptiFineListLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Main", AddressOf DlOptiFineListMain) Private Sub DlOptiFineListMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 30), @@ -377,7 +409,7 @@ ''' Public DlOptiFineListOfficialLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Official", AddressOf DlOptiFineListOfficialMain) Private Sub DlOptiFineListOfficialMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult)) - Dim Result As String = NetGetCodeByClient("https://optifine.net/downloads", Encoding.Default) + Dim Result As String = NetRequestByClientRetry("https://optifine.net/downloads", Encoding:=Encoding.Default) If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）") Try '获取所有版本信息 @@ -392,14 +424,14 @@ For i = 0 To ReleaseTime.Count - 1 Name(i) = Name(i).Replace("_", " ") Dim Entry As New DlOptiFineListEntry With { - .NameDisplay = Name(i).Replace("HD U ", "").Replace(".0 ", " "), - .ReleaseTime = Join({ReleaseTime(i).Split(".")(2), ReleaseTime(i).Split(".")(1), ReleaseTime(i).Split(".")(0)}, "/"), - .IsPreview = Name(i).ContainsF("pre", True), - .Inherit = Name(i).ToString.Split(" ")(0), - .NameFile = If(Name(i).ContainsF("pre", True), "preview_", "") & "OptiFine_" & Name(i).Replace(" ", "_") & ".jar", - .RequiredForgeVersion = Forge(i).Replace("Forge ", "").Replace("#", "")} + .DisplayName = Name(i).Replace("HD U ", "").Replace(".0 ", " "), + .ReleaseTime = {ReleaseTime(i).Split(".")(2), ReleaseTime(i).Split(".")(1), ReleaseTime(i).Split(".")(0)}.Join("/"c), + .IsPreview = Name(i).ContainsF("pre", True), + .Inherit = Name(i).ToString.Split(" ")(0), + .FileName = If(Name(i).ContainsF("pre", True), "preview_", "") & "OptiFine_" & Name(i).Replace(" ", "_") & ".jar", + .RequiredForgeVersion = Forge(i).Replace("Forge ", "").Replace("#", "")} If Entry.RequiredForgeVersion.Contains("N/A") Then Entry.RequiredForgeVersion = Nothing - Entry.NameVersion = Entry.Inherit & "-OptiFine_" & Name(i).ToString.Replace(" ", "_").Replace(Entry.Inherit & "_", "") + Entry.InstanceName = Entry.Inherit & "-OptiFine_" & Name(i).ToString.Replace(" ", "_").Replace(Entry.Inherit & "_", "") Versions.Add(Entry) Next Loader.Output = New DlOptiFineListResult With {.IsOfficial = True, .SourceName = "OptiFine 官方源", .Value = Versions} @@ -413,20 +445,20 @@ ''' Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain) Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult)) - Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/optifine/versionList", IsJson:=True) + Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList", RequireJson:=True)) Try Dim Versions As New List(Of DlOptiFineListEntry) For Each Token As JObject In Json Dim Entry As New DlOptiFineListEntry With { - .NameDisplay = (Token("mcversion").ToString & Token("type").ToString.Replace("HD_U", "").Replace("_", " ") & " " & Token("patch").ToString).Replace(".0 ", " "), - .ReleaseTime = "", - .IsPreview = Token("patch").ToString.ContainsF("pre", True), - .Inherit = Token("mcversion").ToString, - .NameFile = Token("filename").ToString, - .RequiredForgeVersion = If(Token("forge"), "").ToString.Replace("Forge ", "").Replace("#", "") - } + .DisplayName = (Token("mcversion").ToString & Token("type").ToString.Replace("HD_U", "").Replace("_", " ") & " " & Token("patch").ToString).Replace(".0 ", " "), + .ReleaseTime = "", + .IsPreview = Token("patch").ToString.ContainsF("pre", True), + .Inherit = Token("mcversion").ToString, + .FileName = Token("filename").ToString, + .RequiredForgeVersion = If(Token("forge"), "").ToString.Replace("Forge ", "").Replace("#", "") + } If Entry.RequiredForgeVersion.Contains("N/A") Then Entry.RequiredForgeVersion = Nothing - Entry.NameVersion = Entry.Inherit & "-OptiFine_" & (Token("type").ToString & " " & Token("patch").ToString).Replace(".0 ", " ").Replace(" ", "_").Replace(Entry.Inherit & "_", "") + Entry.InstanceName = Entry.Inherit & "-OptiFine_" & (Token("type").ToString & " " & Token("patch").ToString).Replace(".0 ", " ").Replace(" ", "_").Replace(Entry.Inherit & "_", "") Versions.Add(Entry) Next Loader.Output = New DlOptiFineListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Versions} @@ -459,7 +491,7 @@ ''' Public DlForgeListLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Main", AddressOf DlForgeListMain) Private Sub DlForgeListMain(Loader As LoaderTask(Of Integer, DlForgeListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 30), @@ -483,10 +515,10 @@ ''' Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain) Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult)) - Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html", UseBrowserUserAgent:=True) + Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", SimulateBrowserHeaders:=True) If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）") '获取所有版本信息 - Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)") + Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+((_pre|[_-]snapshot[_-]?)[0-9]?)?(?=.html)") Names.Add("1.2.4") '1.2.4 不会被匹配上 If Names.Count < 10 Then Throw New Exception("获取到的版本数量不足（" & Result & "）") Loader.Output = New DlForgeListResult With {.IsOfficial = True, .SourceName = "Forge 官方源", .Value = Names} @@ -497,11 +529,10 @@ ''' Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain) Private Sub DlForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlForgeListResult)) - Dim Result As String = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding.Default) - If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）") - '获取所有版本信息 - Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?") - If Names.Count < 10 Then Throw New Exception("获取到的版本数量不足（" & Result & "）") + Dim Result As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft", + Encoding:=Encoding.Default, RequireJson:=True)) + Dim Names As List(Of String) = Result.Select(Function(v) v.ToString).ToList + If Names.Count < 10 Then Throw New Exception("获取到的版本数量不足") Loader.Output = New DlForgeListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Names} End Sub @@ -510,60 +541,47 @@ #Region "DlForgeVersion | Forge 版本列表" Public MustInherit Class DlForgelikeEntry + Implements IComparable(Of DlForgelikeEntry) + Public IsNeoForge As Boolean ''' ''' 加载器名称。Forge 或 NeoForge。 ''' - Public ReadOnly Property LoaderName As String - Get - Return If(IsNeoForge, "NeoForge", "Forge") - End Get - End Property + Public MustOverride ReadOnly Property LoaderName As String ''' ''' 文件扩展名。不以小数点开头。 ''' - Public ReadOnly Property FileExtension As String - Get - If IsNeoForge Then - Return "jar" - Else - Return If(CType(Me, DlForgeVersionEntry).Category = "installer", "jar", "zip") - End If - End Get - End Property + Public MustOverride ReadOnly Property FileExtension As String ''' - ''' Forge：MC 版本是否小于 1.13。 - ''' NeoForge：MC 版本是否为 1.20.1。 - ''' - Public ReadOnly Property IsLegacy As Boolean - Get - '虽然很抽象，但确实可以这样判断 - 'Forge：1.13+ 的版本号首位都大于 20 - 'NeoForge：1.20.1 的版本号首位人为规定为 19 开头 - Return Version.Major < 20 - End Get - End Property - ''' - ''' 标准化后的版本号，仅可用于比较与排序。 + ''' 标准化后的版本号，仅可用于比较与排序，且 NeoForge 项不包含 alpha/beta 编号！ ''' 格式：Major.Minor.Build.Revision ''' Forge：如 “50.1.9.0”（最后一位固定为 0）、“14.22.1.2478”（Legacy）。 ''' NeoForge：如 “20.4.30.0”（最后一位固定为 0）、“19.47.1.99”（Legacy：第一位固定为 19）。 ''' Public Version As Version ''' - ''' 可对玩家显示的非格式化版本名。 + ''' 可读的非格式化版本名。 ''' Forge：如 “50.1.9”、“14.22.1.2478”（Legacy）。 ''' NeoForge：如 “20.4.30-beta”、“47.1.99”（Legacy）。 ''' Public VersionName As String ''' - ''' 对应的 Minecraft 版本，如“1.12.2”。 + ''' 对应的 Minecraft 版本，如 1.12.2、26.1-snapshot-1。 ''' Public Inherit As String + + Public Function CompareTo(other As DlForgelikeEntry) As Integer Implements IComparable(Of DlForgelikeEntry).CompareTo + If Version <> other.Version Then + Return Version.CompareTo(other.Version) + Else + Return CompareVersion(VersionName, other.VersionName) + End If + End Function End Class Public Class DlForgeVersionEntry Inherits DlForgelikeEntry + ''' ''' 发布时间，格式为“yyyy/MM/dd HH:mm”。 ''' @@ -585,6 +603,23 @@ ''' Public FileVersion As String + ''' + ''' 加载器名称。Forge 或 NeoForge。 + ''' + Public Overrides ReadOnly Property LoaderName As String + Get + Return "Forge" + End Get + End Property + ''' + ''' 文件扩展名。不以小数点开头。 + ''' + Public Overrides ReadOnly Property FileExtension As String + Get + Return If(Category = "installer", "jar", "zip") + End Get + End Property + Public Sub New(Version As String, Branch As String, Inherit As String) '司马版本的特殊处理 If Version = "11.15.1.2318" OrElse Version = "11.15.1.1902" OrElse Version = "11.15.1.1890" Then Branch = "1.8.9" @@ -594,8 +629,9 @@ VersionName = Version Me.Version = New Version(Version) Me.Inherit = Inherit - FileVersion = Version & If(Branch Is Nothing, ""， "-" & Branch) + FileVersion = Version & If(Branch Is Nothing, "", "-" & Branch) End Sub + End Class ''' @@ -604,7 +640,7 @@ Public Sub DlForgeVersionMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) Dim DlForgeVersionOfficialLoader As New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Official", AddressOf DlForgeVersionOfficialMain) Dim DlForgeVersionBmclapiLoader As New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Bmclapi", AddressOf DlForgeVersionBmclapiMain) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)) From { New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 30), @@ -629,12 +665,12 @@ Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) Dim Result As String Try - Result = NetGetCodeByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & + Result = NetRequestByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4，#4057 - ".html", UseBrowserUserAgent:=True) + ".html", SimulateBrowserHeaders:=True) Catch ex As Exception - If GetExceptionSummary(ex).Contains("(404)") Then - Throw New Exception("不可用") + If ex.GetBrief().Contains("(404)") Then + Throw New Exception("无") Else Throw End If @@ -692,7 +728,7 @@ Catch ex As Exception Throw New Exception("Forge 官方源版本列表解析失败（" & Result & "）", ex) End Try - If Not Versions.Any() Then Throw New Exception("不可用") + If Not Versions.Any() Then Throw New Exception("无") Loader.Output = Versions End Sub @@ -700,9 +736,8 @@ ''' Forge 版本列表，BMCLAPI。 ''' Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) - Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & - Loader.Input.Replace("-", "_"), '兼容 Forge 1.7.10-pre4，#4057 - IsJson:=True) + Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & + Loader.Input.Replace("-", "_"), RequireJson:=True)) '兼容 Forge 1.7.10-pre4，#4057 Dim Versions As New List(Of DlForgeVersionEntry) Try Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input) @@ -747,7 +782,7 @@ Catch ex As Exception Throw New Exception("Forge BMCLAPI 版本列表解析失败（" & Json.ToString & "）", ex) End Try - If Not Versions.Any() Then Throw New Exception("不可用") + If Not Versions.Any() Then Throw New Exception("无") Loader.Output = Versions End Sub @@ -772,6 +807,7 @@ Public Class DlNeoForgeListEntry Inherits DlForgelikeEntry + ''' ''' 是否是 Beta 版。 ''' @@ -785,23 +821,51 @@ ''' Public ReadOnly Property UrlBase As String Get - Dim PackageName As String = If(IsLegacy, "forge", "neoforge") + Dim PackageName As String = If(Inherit = "1.20.1", "forge", "neoforge") Return $"https://maven.neoforged.net/releases/net/neoforged/{PackageName}/{ApiName}/{PackageName}-{ApiName}" End Get End Property + ''' + ''' 加载器名称。Forge 或 NeoForge。 + ''' + Public Overrides ReadOnly Property LoaderName As String + Get + Return "NeoForge" + End Get + End Property + ''' + ''' 文件扩展名。不以小数点开头。 + ''' + Public Overrides ReadOnly Property FileExtension As String + Get + Return "jar" + End Get + End Property + Public Sub New(ApiName As String) IsNeoForge = True Me.ApiName = ApiName - IsBeta = ApiName.Contains("beta") + IsBeta = ApiName.ContainsF("beta", True) OrElse ApiName.ContainsF("alpha", True) If ApiName.Contains("1.20.1") Then '1.20.1-47.1.99 VersionName = ApiName.Replace("1.20.1-", "") Version = New Version("19." & VersionName) Inherit = "1.20.1" - Else '20.4.30-beta + ElseIf ApiName.StartsWithF("0.") Then '0.25w14craftmine.3-beta + VersionName = ApiName + Dim Segments = ApiName.BeforeFirst("-").Split("."c) + Version = New Version(0, 0, Segments.Last) + Inherit = Segments(1) + Else '20.4.30-beta；26.1.0.0-alpha.1+snapshot-1 VersionName = ApiName Version = New Version(ApiName.BeforeFirst("-")) - Inherit = $"1.{Version.Major}" & If(Version.Minor = 0, "", "." & Version.Minor) + If Version.Major >= 24 Then + Inherit = $"{Version.Major}.{Version.Minor}.{Version.Build}" + Else + Inherit = $"1.{Version.Major}.{Version.Minor}" + End If + If Inherit.EndsWithF(".0") Then Inherit = Left(Inherit, Inherit.Length - 2) + If VersionName.Contains("+") Then Inherit &= "-" & VersionName.AfterFirst("+") End If End Sub End Class @@ -811,7 +875,7 @@ ''' Public DlNeoForgeListLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Main", AddressOf DlNeoForgeListMain) Private Sub DlNeoForgeListMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 30), @@ -836,8 +900,8 @@ Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain) Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) '获取版本列表 JSON - Dim ResultLatest As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True) - Dim ResultLegacy As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True) + Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", RequireJson:=True) + Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", RequireJson:=True) If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）") '解析 Try @@ -854,8 +918,8 @@ 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 = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True) - Dim ResultLegacy As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True) + Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", RequireJson:=True) + Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", RequireJson:=True) If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）") '解析 Try @@ -868,12 +932,12 @@ Private Function GetNeoForgeEntries(LatestJson As String, LatestLegacyJson As String) As List(Of DlNeoForgeListEntry) Dim VersionNames = RegexSearch(LatestLegacyJson & LatestJson, - "(?<="")(1\.20\.1-)?\d+\.\d+\.\d+(-beta)?(?="")") '我寻思直接正则就行.jpg + "(?<="")(1\.20\.1-)?\d+\.[^\.]+\.\d+(\.\d+)?(-(beta|alpha)(\.\d+)?)?(\+snapshot-\d+)?(?="")") Dim Versions = VersionNames. Where(Function(name) name <> "47.1.82"). '这个版本虽然在版本列表中，但不能下载 - Select(Function(name) New DlNeoForgeListEntry(name)).ToList - If Not Versions.Any() Then Throw New Exception("不可用") - Versions = Versions.OrderByDescending(Function(a) a.Version).ToList + Select(Function(name) New DlNeoForgeListEntry(name)). + OrderByDescending(Function(a) a).ToList + If Not Versions.Any() Then Throw New Exception("无") Return Versions End Function @@ -936,7 +1000,7 @@ ''' Public DlLiteLoaderListLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Main", AddressOf DlLiteLoaderListMain) Private Sub DlLiteLoaderListMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 30), @@ -960,7 +1024,7 @@ ''' Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain) Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) - Dim Result As JObject = NetGetCodeByRequestRetry("https://dl.liteloader.com/versions/versions.json", IsJson:=True) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json", RequireJson:=True)) Try Dim Json As JObject = Result("versions") Dim Versions As New List(Of DlLiteLoaderListEntry) @@ -970,7 +1034,7 @@ Versions.Add(New DlLiteLoaderListEntry With { .Inherit = Pair.Key, .IsLegacy = Pair.Key.Split(".")(1) < 8, - .IsPreview = RealEntry("stream").ToString.ToLower = "snapshot", + .IsPreview = RealEntry("stream").ToString.Lower = "snapshot", .FileName = "liteloader-installer-" & Pair.Key & If(Pair.Key = "1.8" OrElse Pair.Key = "1.9", ".0", "") & "-00-SNAPSHOT.jar", .MD5 = RealEntry("md5"), .ReleaseTime = GetLocalTime(GetDate(RealEntry("timestamp"))).ToString("yyyy'/'MM'/'dd HH':'mm"), @@ -988,7 +1052,7 @@ ''' Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain) Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) - Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", IsJson:=True) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", RequireJson:=True)) Try Dim Json As JObject = Result("versions") Dim Versions As New List(Of DlLiteLoaderListEntry) @@ -998,7 +1062,7 @@ Versions.Add(New DlLiteLoaderListEntry With { .Inherit = Pair.Key, .IsLegacy = Pair.Key.Split(".")(1) < 8, - .IsPreview = RealEntry("stream").ToString.ToLower = "snapshot", + .IsPreview = RealEntry("stream").ToString.Lower = "snapshot", .FileName = "liteloader-installer-" & Pair.Key & If(Pair.Key = "1.8" OrElse Pair.Key = "1.9", ".0", "") & "-00-SNAPSHOT.jar", .MD5 = RealEntry("md5"), .ReleaseTime = GetLocalTime(GetDate(RealEntry("timestamp"))).ToString("yyyy'/'MM'/'dd HH':'mm"), @@ -1035,7 +1099,7 @@ ''' Public DlFabricListLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Main", AddressOf DlFabricListMain) Private Sub DlFabricListMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) - Select Case Setup.Get("ToolDownloadVersion") + Select Case Settings.Get("ToolDownloadVersion") Case 0 DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)) From { New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 30), @@ -1059,7 +1123,7 @@ ''' Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain) Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) - Dim Result As JObject = NetGetCodeByRequestRetry("https://meta.fabricmc.net/v2/versions", IsJson:=True) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions", RequireJson:=True)) Try Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result} If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项") @@ -1074,7 +1138,7 @@ ''' Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain) Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) - Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", IsJson:=True) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", RequireJson:=True)) Try Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result} If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项") @@ -1101,72 +1165,37 @@ #Region "DlMod | Mod 镜像源请求" ''' - ''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。 - ''' 调用 NetGetCodeByRequest，会进行重试。 - ''' - Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As Object - Dim Urls As New List(Of KeyValuePair(Of String, Integer)) - Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20)) - 'Dim McimUrl As String = DlSourceModGet(Url) - 'If McimUrl <> Url Then - ' Select Case Setup.Get("ToolDownloadMod") - ' Case 0 - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Case 1 - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' Case Else - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' 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 - - ''' - ''' 对可能涉及 Mod 镜像源的请求进行处理。 + ''' 对可能涉及 Mod 镜像源的请求进行处理，返回 JToken。 ''' 调用 NetRequest，会进行重试。 ''' - Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String) As String + Public Function DlModRequest(Url As String, Optional Method As HttpMethod = Nothing, + Optional Content As String = Nothing, Optional ContentType As String = Nothing) As JToken Dim Urls As New List(Of KeyValuePair(Of String, Integer)) - Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20)) - 'Dim McimUrl As String = DlSourceModGet(Url) - 'If McimUrl <> Url Then - ' Select Case Setup.Get("ToolDownloadMod") - ' Case 0 - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Case 1 - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' Case Else - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) - ' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) - ' End Select - 'End If + Dim McimUrl As String = DlSourceModGet(Url) + If McimUrl <> Url Then + Select Case Settings.Get("ToolDownloadMod") + Case 0 + Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) + Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) + Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30)) + Case 1 + Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10))) '至少 20s，要不然 Modrinth 返回不过来 + Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) + Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30)) + Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30)) + Case Else + Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10))) + Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30)) + Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30)) + End Select + Else + Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10))) + Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30)) + End If Dim Exs As String = "" For Each Source In Urls Try - Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000) + Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8, RequireJson:=True)) Catch ex As Exception Exs += ex.Message + vbCrLf End Try @@ -1184,7 +1213,7 @@ ''' Public ReadOnly Property DlSourcePreferMojang As Boolean Get - Return Setup.Get("ToolDownloadSource") = 2 OrElse (Setup.Get("ToolDownloadSource") = 1 AndAlso DlPreferMojang) + Return Settings.Get("ToolDownloadSource") = 2 OrElse (Settings.Get("ToolDownloadSource") = 1 AndAlso DlPreferMojang) End Get End Property ''' @@ -1198,7 +1227,7 @@ ''' Public ReadOnly Property DlVersionListPreferMojang As Boolean Get - Return Setup.Get("ToolDownloadVersion") = 2 OrElse (Setup.Get("ToolDownloadVersion") = 1 AndAlso DlPreferMojang) + Return Settings.Get("ToolDownloadVersion") = 2 OrElse (Settings.Get("ToolDownloadVersion") = 1 AndAlso DlPreferMojang) End Get End Property ''' @@ -1269,7 +1298,14 @@ 'Mod 下载源 Public Function DlSourceModGet(Original As String) As String - Return Original + 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 'Loader 自动切换 @@ -1290,7 +1326,7 @@ If SubLoader.Key.State = LoadState.Finished Then '检查加载器成功 MainLoader.Output = SubLoader.Key.Output - DlSourceLoaderAbort(LoaderList) + DlSourceLoaderInterrupt(LoaderList) Return ElseIf BeforeLoadersAllFailed Then '此前的加载器全部失败，直接启动后续加载器 @@ -1316,13 +1352,13 @@ For ii = 0 To LoaderList.Count - 1 LoaderList(ii).Key.Input = Nothing '重置输入，以免以同样的输入“重试加载”时直接失败 If LoaderList(ii).Key.Error IsNot Nothing Then - If ErrorInfo Is Nothing OrElse LoaderList(ii).Key.Error.Message.Contains("不可用") Then + If ErrorInfo Is Nothing OrElse LoaderList(ii).Key.Error.Message = "无" Then ErrorInfo = LoaderList(ii).Key.Error End If End If Next If ErrorInfo Is Nothing Then ErrorInfo = New TimeoutException("下载源连接超时") - DlSourceLoaderAbort(LoaderList) + DlSourceLoaderInterrupt(LoaderList) Throw ErrorInfo End If Exit For @@ -1331,15 +1367,15 @@ Thread.Sleep(10) WaitCycle += 1 '检查父加载器中断 - If MainLoader.IsAborted Then - DlSourceLoaderAbort(LoaderList) + If MainLoader.IsInterrupted Then + DlSourceLoaderInterrupt(LoaderList) Return End If Loop End Sub - Private Sub DlSourceLoaderAbort(Of InputType, OutputType)(LoaderList As List(Of KeyValuePair(Of LoaderTask(Of InputType, OutputType), Integer))) + Private Sub DlSourceLoaderInterrupt(Of InputType, OutputType)(LoaderList As List(Of KeyValuePair(Of LoaderTask(Of InputType, OutputType), Integer))) For Each Loader In LoaderList - If Loader.Key.State = LoadState.Loading Then Loader.Key.Abort() + If Loader.Key.State = LoadState.Loading Then Loader.Key.Interrupt() Next End Sub diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb index 9c41a4a..eea492f 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb @@ -10,7 +10,7 @@ '路径 ''' - ''' Java.exe 文件的完整路径。 + ''' java.exe 文件的完整路径。 ''' Public ReadOnly Property PathJava As String Get @@ -18,15 +18,7 @@ End Get End Property ''' - ''' Javaw.exe 文件的完整路径。 - ''' - Public ReadOnly Property PathJavaw As String - Get - Return PathFolder & "javaw.exe" - End Get - End Property - ''' - ''' Javaw.exe 文件所在文件夹的路径，以 \ 结尾。 + ''' java.exe 文件所在文件夹的路径，以 \ 结尾。 ''' Public PathFolder As String ''' @@ -43,7 +35,7 @@ ''' ''' Java 的大版本号。 ''' - Public ReadOnly Property VersionCode As Integer + Public ReadOnly Property MajorVersion As Integer Get Return Version.Minor End Get @@ -79,7 +71,7 @@ Public Overrides Function ToString() As String Dim VersionString = Version.ToString If VersionString.StartsWithF("1.") Then VersionString = Mid(VersionString, 3) - Return If(IsJre, "JRE ", "JDK ") & VersionCode & " (" & VersionString & ")" & If(Is64Bit, "", "，32 位") & If(IsUserImport, "，手动导入", "") & "：" & PathFolder + Return If(IsJre, "JRE ", "JDK ") & MajorVersion & " (" & VersionString & ")" & If(Is64Bit, "", "，32 位") & If(IsUserImport, "，手动导入", "") & "：" & PathFolder End Function '构造 @@ -102,21 +94,16 @@ Dim Output As String = Nothing Try '确定文件存在 - If Not File.Exists(PathJavaw) Then - Throw New FileNotFoundException("未找到 javaw.exe 文件", PathJavaw) - End If - If Not File.Exists(PathFolder & "java.exe") Then - Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe") - End If - If File.Exists(PathFolder & "pdf-bookmark") Then - Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326 - End If + If Not File.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava) + If {"finalshell", "Paranoia File"}.Any(Function(n) PathJava.ContainsF(n, True)) Then Throw New Exception("不兼容该精简版 Java") '#2249、#8080 + If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326 IsJre = Not File.Exists(PathFolder & "javac.exe") '运行 -version - Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower + Output = StartProcessAndGetOutput(PathJava, "-version", 15000).Lower If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败") - If ModeDebug Then Log("[Java] Java 检查输出：" & PathFolder & "java.exe" & vbCrLf & Output) + If ModeDebug Then Log("[Java] Java 检查输出：" & PathJava & vbCrLf & Output) If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java，请在删除 Java 文件夹中的 /lib/ext 文件夹后再试") + If Output.Contains("a fatal error") Then Throw New ApplicationException("无法运行该 Java，该 Java 或系统存在问题") '获取详细信息 Dim VersionString = If(RegexSeek(Output, "(?<=version "")[^""]+"), If(RegexSeek(Output, "(?<=openjdk )[0-9]+"), "")).Replace("_", ".").Split("-").First If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493，VersionString = "21.0.2.0.2" @@ -135,17 +122,15 @@ End If Is64Bit = Output.Contains("64-bit") If Version.Minor <= 4 OrElse Version.Minor >= 100 Then Throw New ApplicationException("分析详细信息失败，获取的版本为 " & Version.ToString) - '基于 #3649，在 64 位系统上禁用 32 位 Java + '#3649：在 64 位系统上禁用 32 位 Java If Not Is64Bit AndAlso Not Is32BitSystem Then Throw New Exception("该 Java 为 32 位版本，请安装 64 位的 Java") - '基于 #2249 发现 JRE 17 似乎也导致了 Forge 安装失败，干脆禁用更多版本的 JRE - If IsJre AndAlso VersionCode >= 16 Then Throw New Exception("由于高版本 JRE 对游戏的兼容性很差，因此不再允许使用。你可以使用对应版本的 JDK，而非 JRE！") Catch ex As ApplicationException Throw ex Catch ex As ThreadInterruptedException Throw ex Catch ex As Exception - Log("[Java] 检查失败的 Java 输出：" & PathFolder & "java.exe" & vbCrLf & If(Output, "无程序输出")) - Throw New Exception("检查 Java 失败（" & If(PathJavaw, "Nothing") & "）", ex) + Log("[Java] 检查失败的 Java 输出：" & If(PathJava, "Nothing") & vbCrLf & If(Output, "无程序输出")) + Throw New Exception("检查 Java 失败（" & If(PathJava, "Nothing") & "）", ex) End Try IsChecked = True End Sub @@ -180,13 +165,13 @@ Public Sub JavaListInit() JavaList = New List(Of JavaEntry) Try - If Setup.Get("CacheJavaListVersion") < JavaListCacheVersion Then + If Settings.Get("CacheJavaListVersion") < JavaListCacheVersion Then '不使用缓存 Log("[Java] 要求 Java 列表缓存更新") - Setup.Set("CacheJavaListVersion", JavaListCacheVersion) + Settings.Set("CacheJavaListVersion", JavaListCacheVersion) Else '使用缓存 - For Each JsonEntry In GetJson(Setup.Get("LaunchArgumentJavaAll")) + For Each JsonEntry In GetJson(Settings.Get("LaunchArgumentJavaAll")) JavaList.Add(JavaEntry.FromJson(JsonEntry)) Next End If @@ -199,7 +184,7 @@ End If Catch ex As Exception Log(ex, "初始化 Java 列表失败", LogLevel.Feedback) - Setup.Set("LaunchArgumentJavaAll", "[]") + Settings.Set("LaunchArgumentJavaAll", "[]") End Try End Sub @@ -213,19 +198,19 @@ ''' 必须在工作线程调用，且必须包括 SyncLock JavaLock。 ''' Public Function JavaSelect(CancelException As String, Optional MinVersion As Version = Nothing, Optional MaxVersion As Version = Nothing, - Optional RelatedVersion As McVersion = Nothing) As JavaEntry + Optional GameInstance As McInstance = Nothing) As JavaEntry Try Dim AllowedJavaList As New List(Of JavaEntry) '添加特定的 Java Dim JavaPreList As New Dictionary(Of String, Boolean) - If PathMcFolder.Split("\").Count > 3 AndAlso Not PathMcFolder.Contains("AppData\Roaming") Then - JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录或 %APPDATA% 的话） + If McFolderSelected.Split("\").Count > 3 AndAlso Not McFolderSelected.Contains("AppData\Roaming") Then + JavaSearchFolder(GetPathFromFullPath(McFolderSelected), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录或 %APPDATA% 的话） End If - JavaSearchFolder(PathMcFolder, JavaPreList, False, True) 'Minecraft 文件夹 + JavaSearchFolder(McFolderSelected, 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) '所选版本文件夹 + If GameInstance IsNot Nothing Then JavaSearchFolder(GameInstance.PathVersion, JavaPreList, False, True) '所选版本文件夹 Dim TargetJavaList As New List(Of JavaEntry) For Each Entry In JavaPreList TargetJavaList.Add(New JavaEntry(Entry.Key, Entry.Value)) @@ -246,8 +231,8 @@ '获取版本独立设置中指定的 Java Dim VersionSelect As String = "" - If RelatedVersion IsNot Nothing Then - VersionSelect = Setup.Get("VersionArgumentJavaSelect", Version:=RelatedVersion) + If GameInstance IsNot Nothing Then + VersionSelect = Settings.Get("VersionArgumentJavaSelect", Instance:=GameInstance) If VersionSelect.StartsWithF("{") Then Try UserJava = JavaEntry.FromJson(GetJson(VersionSelect)) @@ -256,22 +241,22 @@ Throw Catch ex As Exception UserJava = Nothing - Setup.Reset("VersionArgumentJavaSelect", Version:=RelatedVersion) + Settings.Reset("VersionArgumentJavaSelect", Instance:=GameInstance) Log(ex, "版本独立设置中指定的 Java 已无法使用，此设置已重置", LogLevel.Hint) End Try End If End If '获取全局设置中指定的 Java - If UserJava Is Nothing AndAlso VersionSelect <> "" AndAlso Setup.Get("LaunchArgumentJavaSelect") <> "" Then + If UserJava Is Nothing AndAlso VersionSelect <> "" AndAlso Settings.Get("LaunchArgumentJavaSelect") <> "" Then Try - UserJava = JavaEntry.FromJson(GetJson(Setup.Get("LaunchArgumentJavaSelect"))) + UserJava = JavaEntry.FromJson(GetJson(Settings.Get("LaunchArgumentJavaSelect"))) UserJava.Check() Catch ex As ThreadInterruptedException Throw Catch ex As Exception UserJava = Nothing - Setup.Reset("LaunchArgumentJavaSelect") + Settings.Reset("LaunchArgumentJavaSelect") Log(ex, "全局设置中指定的 Java 已无法使用，此设置已重置", LogLevel.Hint) End Try End If @@ -290,7 +275,7 @@ RetryGet: Select Case JavaSearchLoader.State Case LoadState.Failed Throw JavaSearchLoader.Error - Case LoadState.Aborted + Case LoadState.Interrupted Throw New ThreadInterruptedException("Java 搜索加载器已中断") End Select @@ -344,8 +329,8 @@ RetryGet: Dim Right As String = MaxVersion.Minor & If(ShowRevision, "." & MaxVersion.MajorRevision & "." & MaxVersion.MinorRevision, "") Requirement = "需要 Java " & If(Left = Right, Left, Left & " ~ " & Right) End If - Dim JavaCurrent As String = UserJava.VersionCode & If(ShowRevision, "." & UserJava.Version.MajorRevision & "." & UserJava.Version.MinorRevision, "") - If RelatedVersion IsNot Nothing AndAlso Setup.Get("VersionAdvanceJava", RelatedVersion) Then + Dim JavaCurrent As String = UserJava.MajorVersion & If(ShowRevision, "." & UserJava.Version.MajorRevision & "." & UserJava.Version.MinorRevision, "") + If GameInstance IsNot Nothing AndAlso Settings.Get("VersionAdvanceJava", GameInstance) Then '直接跳过弹窗 Log("[Java] 设置中指定了使用 Java " & JavaCurrent & "，但当前版本" & Requirement & "，这可能会导致游戏崩溃！", LogLevel.Debug) AllowedJavaList = New List(Of JavaEntry) From {UserJava} @@ -386,7 +371,7 @@ ExitUserJavaCheck: UserPass: '对适合的 Java 进行排序 - AllowedJavaList = AllowedJavaList.Sort(AddressOf JavaSorter) + AllowedJavaList = AllowedJavaList.SortByComparison(AddressOf JavaSorter) Log($"[Java] 排序后的 Java 优先顺序：") For Each Java In AllowedJavaList Log($"[Java] - {Java}") @@ -422,12 +407,12 @@ UserPass: ''' ''' 是否强制指定了 64 位 Java。如果没有强制指定，返回是否安装了 64 位 Java。 ''' - Public Function JavaIs64Bit(Optional RelatedVersion As McVersion = Nothing) As Boolean + Public Function JavaIs64Bit(Optional GameInstance As McInstance = Nothing) As Boolean Try '检查强制指定 - Dim UserSetup As String = Setup.Get("LaunchArgumentJavaSelect") - If RelatedVersion IsNot Nothing Then - Dim UserSetupVersion As String = Setup.Get("VersionArgumentJavaSelect", Version:=RelatedVersion) + Dim UserSetup As String = Settings.Get("LaunchArgumentJavaSelect") + If GameInstance IsNot Nothing Then + Dim UserSetupVersion As String = Settings.Get("VersionArgumentJavaSelect", Instance:=GameInstance) If UserSetupVersion <> "使用全局设置" Then UserSetup = UserSetupVersion End If If UserSetup <> "" Then @@ -436,7 +421,7 @@ UserPass: UserJava = JavaEntry.FromJson(GetJson(UserSetup)) Catch ex As Exception Log(ex, "版本指定的 Java 信息已损坏，已重置版本设置中指定的 Java") - Setup.Set("VersionArgumentJavaSelect", "使用全局设置", Version:=RelatedVersion) + Settings.Set("VersionArgumentJavaSelect", "使用全局设置", Instance:=GameInstance) GoTo NoUserJava End Try For Each Java In JavaList @@ -451,7 +436,7 @@ NoUserJava: Return False Catch ex As Exception Log(ex, "检查 Java 类别时出错", LogLevel.Feedback) - Setup.Set("LaunchArgumentJavaSelect", "") + Settings.Set("LaunchArgumentJavaSelect", "") Return True End Try End Function @@ -459,13 +444,15 @@ NoUserJava: ''' 将 Java 按照适用性排序。 ''' Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean + Dim PathInfo As New DirectoryInfo(Path) + Dim PathMcInfo As New DirectoryInfo(McFolderSelected) '1. 尽量在当前文件夹或当前 Minecraft 文件夹 Dim ProgramPathParent As String, MinecraftPathParent As String = "" - ProgramPathParent = If(New DirectoryInfo(Path).Parent, New DirectoryInfo(Path)).FullName - If PathMcFolder <> "" Then MinecraftPathParent = If(New DirectoryInfo(PathMcFolder).Parent, New DirectoryInfo(PathMcFolder)).FullName + ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName + If McFolderSelected <> "" Then MinecraftPathParent = If(PathMcInfo.Parent, PathMcInfo).FullName If Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Not Right.PathFolder.StartsWithF(ProgramPathParent) Then Return True If Not Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Right.PathFolder.StartsWithF(ProgramPathParent) Then Return False - If PathMcFolder <> "" Then + If McFolderSelected <> "" Then If Left.PathFolder.StartsWithF(MinecraftPathParent) AndAlso Not Right.PathFolder.StartsWithF(MinecraftPathParent) Then Return True If Not Left.PathFolder.StartsWithF(MinecraftPathParent) AndAlso Right.PathFolder.StartsWithF(MinecraftPathParent) Then Return False End If @@ -476,10 +463,11 @@ NoUserJava: If Left.IsJre AndAlso Not Right.IsJre Then Return True If Not Left.IsJre AndAlso Right.IsJre Then Return False '4. Java 大版本 - If Left.VersionCode <> Right.VersionCode Then - ' Java 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23... - Dim Weight = {0, 1, 2, 3, 4, 5, 6, 14, 30, 10, 12, 15, 13, 9, 8, 7, 11, 31, 29, 16, 17, 28, 27, 26, 25, 24, 23, 22, 21, 20, 19, 18} - Return Weight.ElementAtOrDefault(Left.VersionCode) >= Weight.ElementAtOrDefault(Right.VersionCode) + If Left.MajorVersion <> Right.MajorVersion Then + ' Java 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + Dim Weight = {0, 1, 2, 3, 4, 5, 6, 14, 30, 10, 12, 15, 13, 9, 8, 7, 11, 31, 29, 16, 17} '更高的版本指定为 20，且越低越好 + Return If(Left.MajorVersion > 20, 20 - Left.MajorVersion * 0.0001, Weight.ElementAtOrDefault(Left.MajorVersion)) >= + If(Right.MajorVersion > 20, 20 - Right.MajorVersion * 0.0001, Weight.ElementAtOrDefault(Right.MajorVersion)) End If '5. 最次级版本号更接近 51 Return Math.Abs(Left.Version.Revision - 51) <= Math.Abs(Right.Version.Revision - 51) @@ -499,11 +487,11 @@ NoUserJava: FrmSetupLaunch.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True}) End Sub) End If - If FrmVersionSetup IsNot Nothing Then + If FrmInstanceSetup IsNot Nothing Then RunInUiWait( Sub() - FrmVersionSetup.ComboArgumentJava.Items.Clear() - FrmVersionSetup.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True}) + FrmInstanceSetup.ComboArgumentJava.Items.Clear() + FrmInstanceSetup.ComboArgumentJava.Items.Add(New ComboBoxItem With {.Content = "加载中……", .IsSelected = True}) End Sub) End If @@ -529,15 +517,14 @@ NoUserJava: If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器（#3705） JavaSearchFolder(Disk.Name, JavaPreList, False) Next - '查找 APPDATA 文件夹中的 Java - JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False) - JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False) + '查找用户文件夹中的 Java + JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile), JavaPreList, False) + JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False, IsFullSearch:=True) + JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.sdkman\candidates\java\", JavaPreList, False, IsFullSearch:=True) '查找启动器目录中的 Java JavaSearchFolder(Path, JavaPreList, False, IsFullSearch:=True) '查找所选 Minecraft 文件夹中的 Java - If Not String.IsNullOrWhiteSpace(PathMcFolder) AndAlso Path <> PathMcFolder Then - JavaSearchFolder(PathMcFolder, JavaPreList, False, IsFullSearch:=True) - End If + If Not String.IsNullOrWhiteSpace(McFolderSelected) AndAlso Path <> McFolderSelected Then JavaSearchFolder(McFolderSelected, JavaPreList, False, IsFullSearch:=True) '若不全为符号链接，则清除符号链接的地址 Dim JavaWithoutReparse As New Dictionary(Of String, Boolean) @@ -571,7 +558,7 @@ NoUserJava: #Region "添加玩家手动导入的 Java" - Dim ImportedJava As String = Setup.Get("LaunchArgumentJavaAll") + Dim ImportedJava As String = Settings.Get("LaunchArgumentJavaAll") Try For Each JavaJsonObject In GetJson(ImportedJava) Dim Entry = JavaEntry.FromJson(JavaJsonObject) @@ -579,24 +566,24 @@ NoUserJava: Next Catch ex As Exception Log(ex, "Java 列表已损坏", LogLevel.Feedback) - Setup.Set("LaunchArgumentJavaAll", "[]") + Settings.Set("LaunchArgumentJavaAll", "[]") End Try #End Region '确保可用并获取详细信息，转入正式列表 Dim NewJavaList As New List(Of JavaEntry) - For Each Entry In JavaPreList.Distinct(Function(a, b) a.Key.ToLower = b.Key.ToLower) '#794 + For Each Entry In JavaPreList.Distinct(Function(a, b) a.Key.Lower = b.Key.Lower) '#794 NewJavaList.Add(New JavaEntry(Entry.Key, Entry.Value)) Next - NewJavaList = JavaCheckList(NewJavaList).Sort(AddressOf JavaSorter) + NewJavaList = JavaCheckList(NewJavaList).SortByComparison(AddressOf JavaSorter) '修改设置项 Dim AllList As New JArray For Each Java In NewJavaList AllList.Add(Java.ToJson) Next - Setup.Set("LaunchArgumentJavaAll", AllList.ToString(Newtonsoft.Json.Formatting.None)) + Settings.Set("LaunchArgumentJavaAll", AllList.ToString(Newtonsoft.Json.Formatting.None)) JavaList = NewJavaList Catch ex As Exception @@ -605,8 +592,8 @@ NoUserJava: End Try Log("[Java] Java 搜索完成，发现 " & JavaList.Count & " 个 Java") - If FrmSetupLaunch IsNot Nothing Then RunInUi(Sub() FrmSetupLaunch.RefreshJavaComboBox()) - If FrmVersionSetup IsNot Nothing Then RunInUi(Sub() FrmVersionSetup.RefreshJavaComboBox()) + If FrmSetupLaunch IsNot Nothing Then RunInUi(Sub() FrmSetupLaunch.UpdateJavaComboBox()) + If FrmInstanceSetup IsNot Nothing Then RunInUi(Sub() FrmInstanceSetup.RefreshJavaComboBox()) End Sub ''' @@ -656,7 +643,7 @@ Wait: Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False) Try Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找：" & OriginalPath) - JavaSearchFolder(New DirectoryInfo(ShortenPath(OriginalPath)), Results, Source, IsFullSearch) + JavaSearchFolder(New DirectoryInfo(OriginalPath), Results, Source, IsFullSearch) Catch ex As UnauthorizedAccessException Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹：" & OriginalPath) Catch ex As Exception @@ -677,19 +664,19 @@ Wait: '若该目录有 Java，则加入结果 If File.Exists(Path & "javaw.exe") Then Results(Path) = Source '查找其下的所有文件夹 - '不应使用网易的 Java：https://github.com/Hex-Dragon/PCL2/issues/1279#issuecomment-2761489121 - Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon", - "soft", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net", - "游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合", - "应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot", - "runtime", "x86", "x64", "forge", "原版", "optifine", "官方", "启动", "hmcl", "mod", "高清", - "download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages", - "4297127d64ec6", "1.", "启动"} + '不应使用网易的 Java：https://github.com/Meloong-Git/PCL/issues/1279#issuecomment-2761489121 + Static Keywords As String() = { + "java", "jdk", "jre", "env", "环境", "run", "软件", "mc", "dragon", "well", "bin", "sdk", "candidate", "current", + "software", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net", + "游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合", + "应用", "运行", "前置", "mojang", "官启", "官方", "新建文件夹", "eclipse", "microsoft", "hotspot", + "runtime", "x86", "x64", "arm", "forge", "原版", "optifine", "官方", "启动", "hmcl", "mod", "forge", "fabric", + "download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages", "4297127d64ec6", "1.", "启动", "jbr"} For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接 - Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).ToLower '用于搜索的字符串 + Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).Lower '用于搜索的字符串 If IsFullSearch OrElse - OriginalPath.Name.ToLower = "users" OrElse Val(SearchEntry) > 0 OrElse Keywords.Any(Function(w) SearchEntry.Contains(w)) OrElse SearchEntry = "bin" Then + OriginalPath.Name.Lower = "users" OrElse Val(SearchEntry) > 0 OrElse Keywords.Any(Function(w) SearchEntry.Contains(w)) OrElse SearchEntry = "bin" Then JavaSearchFolder(FolderInfo, Results, Source) End If Next @@ -705,34 +692,18 @@ Wait: #Region "下载" ''' - ''' 提示 Java 缺失，并弹窗确认是否自动下载。返回玩家选择是否下载。 + ''' 获取下载 Java 的加载器。需要开启 IsForceRestart 以正常刷新 Java 列表。 ''' - Public Function JavaDownloadConfirm(VersionDescription As String, Optional ForcedManualDownload As Boolean = False) As Boolean - If ForcedManualDownload Then - MyMsgBox($"PCL 未找到 {VersionDescription}。" & vbCrLf & - $"请自行搜索并安装 {VersionDescription}，安装后在 设置 → 启动选项 → 游戏 Java 中重新搜索或导入。", - "未找到 Java") - Return False - Else - Return MyMsgBox($"PCL 未找到 {VersionDescription}，是否需要 PCL 自动下载？" & vbCrLf & - $"如果你已经安装了 {VersionDescription}，可以在 设置 → 启动选项 → 游戏 Java 中手动导入。", - "自动下载 Java？", "自动下载", "取消") = 1 - End If - End Function - - ''' - ''' 获取下载 Java 8/14/17/21 的加载器。需要开启 IsForceRestart 以正常刷新 Java 列表。 - ''' - Public Function JavaFixLoaders(Version As Integer) As LoaderCombo(Of Integer) + Public Function GetJavaDownloadLoader() As LoaderCombo(Of String) Dim JavaDownloadLoader As New LoaderDownload("下载 Java 文件", New List(Of NetFile)) With {.ProgressWeight = 10} - Dim Loader = New LoaderCombo(Of Integer)($"下载 Java {Version}", { - New LoaderTask(Of Integer, List(Of NetFile))("获取 Java 下载信息", AddressOf JavaFileList) With {.ProgressWeight = 2}, + Dim Loader = New LoaderCombo(Of String)($"下载 Java", { + New LoaderTask(Of String, List(Of NetFile))("获取 Java 下载信息", AddressOf JavaFileList) With {.ProgressWeight = 2}, JavaDownloadLoader, JavaSearchLoader }) AddHandler JavaDownloadLoader.OnStateChangedThread, Sub(Raw As LoaderBase, NewState As LoadState, OldState As LoadState) - If (NewState = LoadState.Failed OrElse NewState = LoadState.Aborted) AndAlso LastJavaBaseDir IsNot Nothing Then + If (NewState = LoadState.Failed OrElse NewState = LoadState.Interrupted) AndAlso LastJavaBaseDir IsNot Nothing Then Log($"[Java] 由于下载未完成，清理未下载完成的 Java 文件：{LastJavaBaseDir}", LogLevel.Debug) DeleteDirectory(LastJavaBaseDir) ElseIf NewState = LoadState.Finished Then @@ -743,22 +714,29 @@ Wait: Return Loader End Function Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹，防止残留只下了一半但 -version 能跑的 Java - Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile))) + Private Sub JavaFileList(Loader As LoaderTask(Of String, List(Of NetFile))) Log("[Java] 开始获取 Java 下载信息") - Dim IndexFileStr As String = NetGetCodeByLoader(DlVersionListOrder( + Dim IndexFileStr As String = NetRequestByLoader(DlVersionListOrder( {"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"}, {"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"} ), IsJson:=True) - '获取下载地址 - Dim MainEntry As JObject = CType(GetJson(IndexFileStr), JObject)($"windows-x{If(Is32BitSystem, "86", "64")}") - Dim Entries = MainEntry.Children.Reverse. '选择最靠后的一项（最新） - SelectMany(Function(e As JProperty) CType(e.Value, JArray).Select(Function(v) New KeyValuePair(Of String, JObject)(e.Name, v))) - Dim TargetEntry = Entries.First(Function(t) t.Value("version")("name").ToString.StartsWithF(Loader.Input)) - Dim Address As String = TargetEntry.Value("manifest")("url") - Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}（{TargetEntry.Key}）：{Address}") + '查找要下载的目标 Java + Dim TargetEntry As JProperty = Nothing + Dim Components As JObject = CType(GetJson(IndexFileStr), JObject)($"windows-x{If(Is32BitSystem, "86", "64")}") + If Components.ContainsKey(Loader.Input) Then '精确匹配 + TargetEntry = Components.Property(Loader.Input) + Else '模糊匹配 + TargetEntry = Components.Properties.FirstOrDefault( + Function(c) c.Value IsNot Nothing AndAlso c.Value.ToArray.FirstOrDefault()?("version")("name").ToString.StartsWithF(Loader.Input)) + If TargetEntry Is Nothing Then Throw New Exception($"未能找到所需的 Java {Loader.Input}") + End If + Dim TargetComponent = TargetEntry.Value.ToArray.FirstOrDefault + If TargetComponent Is Nothing Then Throw New Exception($"Mojang 未提供所需的 Java {Loader.Input}") '获取文件列表 - Dim ListFileStr As String = NetGetCodeByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), IsJson:=True) - LastJavaBaseDir = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Key & "\" + Dim Address As String = TargetComponent("manifest")("url") + McLaunchLog($"准备下载 Java {TargetComponent("version")("name")}（{TargetEntry.Name}）：{Address}") + Dim ListFileStr As String = NetRequestByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), IsJson:=True) + LastJavaBaseDir = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Name & "\" Dim Results As New List(Of NetFile) For Each File As JProperty In CType(GetJson(ListFileStr), JObject)("files") If CType(File.Value, JObject)("downloads")?("raw") Is Nothing Then Continue For diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb index 00469b8..c684380 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb @@ -18,13 +18,13 @@ Public Module ModLaunch Public SaveBatch As String = Nothing ''' ''' 强行指定启动的 MC 版本。 - ''' 默认值：Nothing。使用 McVersionCurrent。 + ''' 默认值：Nothing。使用 McInstanceCurrent。 ''' - Public Version As McVersion = Nothing + Public Instance As McInstance = Nothing ''' ''' 额外的启动参数。 ''' - Public ExtraArgs As New List(Of String) + Public ExtraGameArgs As New List(Of String) End Class ''' ''' 尝试启动 Minecraft。必须在 UI 线程调用。 @@ -35,27 +35,33 @@ Public Module ModLaunch '预检查 If Not RunInUi() Then Throw New Exception("McLaunchStart 必须在 UI 线程调用！") If McLaunchLoader.State = LoadState.Loading Then - Hint("已有游戏正在启动中！", HintType.Critical) + Hint("已有游戏正在启动中！", HintType.Red) Return False End If '强制切换需要启动的版本 - If CurrentLaunchOptions.Version IsNot Nothing AndAlso McVersionCurrent <> CurrentLaunchOptions.Version Then - McLaunchLog("在启动前切换到版本 " & CurrentLaunchOptions.Version.Name) + If CurrentLaunchOptions.Instance IsNot Nothing AndAlso McInstanceSelected <> CurrentLaunchOptions.Instance Then + McLaunchLog("在启动前切换到版本 " & CurrentLaunchOptions.Instance.Name) + '检查版本是否存在 + Try + CurrentLaunchOptions.Instance.GetJsonPath() + Catch + Hint($"无法启动 {CurrentLaunchOptions.Instance.Name}：当前 Minecraft 文件夹中尚未安装该版本！", HintType.Red) + Return False + End Try '检查版本 - CurrentLaunchOptions.Version.Load() - If CurrentLaunchOptions.Version.State = McVersionState.Error Then - Hint("无法启动 Minecraft：" & CurrentLaunchOptions.Version.Info, HintType.Critical) + CurrentLaunchOptions.Instance.Load() + If CurrentLaunchOptions.Instance.State = McInstanceState.Error Then + Hint($"无法启动 {CurrentLaunchOptions.Instance.Name}：{CurrentLaunchOptions.Instance.Info}", HintType.Red) Return False End If '切换版本 - McVersionCurrent = CurrentLaunchOptions.Version - Setup.Set("LaunchVersionSelect", McVersionCurrent.Name) + McInstanceSelected = CurrentLaunchOptions.Instance FrmLaunchLeft.RefreshButtonsUI() FrmLaunchLeft.RefreshPage(False, False) End If FrmMain.AprilGiveup() - '禁止进入版本选择页面（否则就可以在启动中切换 McVersionCurrent 了） - FrmMain.PageStack = FrmMain.PageStack.Where(Function(p) p.Page <> FormMain.PageType.VersionSelect).ToList + '禁止进入版本选择页面（否则就可以在启动中切换 McInstanceSelected 了） + FrmMain.PageStack = FrmMain.PageStack.Where(Function(p) p.Page <> FormMain.PageType.InstanceSelect).ToList '实际启动加载器 McLaunchLoader.Start(Options, IsForceRestart:=True) Return True @@ -66,7 +72,7 @@ Public Module ModLaunch ''' Public Sub McLaunchLog(Text As String) Text = FilterUserName(FilterAccessToken(Text, "*"), "*") - RunInUi(Sub() FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text) + RunInUi(Sub() FrmLaunchRight.LabLog.Text += $"{vbCrLf}[{GetTimeNow()}] {Text}") Log("[Launch] " & Text) End Sub @@ -77,7 +83,7 @@ Public Module ModLaunch Public McLaunchWatcher As Watcher Private Sub McLaunchState(Loader As LoaderTask(Of McLaunchOptions, Object)) Select Case McLaunchLoader.State - Case LoadState.Finished, LoadState.Failed, LoadState.Waiting, LoadState.Aborted + Case LoadState.Finished, LoadState.Failed, LoadState.Waiting, LoadState.Interrupted FrmLaunchLeft.PageChangeToLogin() Case LoadState.Loading '在预检测结束后再触发动画 @@ -87,7 +93,7 @@ Public Module ModLaunch ''' ''' 指定启动中断时的提示文本。若不为 Nothing 则会显示为绿色。 ''' - Private AbortHint As String = Nothing + Private InterruptHint As String = Nothing '实际的启动方法 Private Sub McLaunchStart(Loader As LoaderTask(Of McLaunchOptions, Object)) @@ -98,18 +104,20 @@ Public Module ModLaunch McLaunchPrecheck() McLaunchLog("预检测已通过") Catch ex As Exception - If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical) + If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Red) Throw End Try + Dim IsSavingBatch As Boolean = CurrentLaunchOptions?.SaveBatch IsNot Nothing + '正式加载 Try '构造主加载器 Dim Loaders As New List(Of LoaderBase) From { New LoaderTask(Of Integer, Integer)("获取 Java", AddressOf McLaunchJava) With {.ProgressWeight = 4, .Block = False}, McLoginLoader, '.ProgressWeight = 15, .Block = False - New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground)) With {.ProgressWeight = 15, .Show = False}, - New LoaderTask(Of String, List(Of McLibToken))("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2}, - New LoaderTask(Of List(Of McLibToken), Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2}, + New LoaderCombo(Of String)("补全文件", DlClientFix(McInstanceSelected, False, AssetsIndexExistsBehaviour.DownloadInBackground)) With {.ProgressWeight = 15, .Show = False}, + New LoaderTask(Of String, Integer)("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2}, + New LoaderTask(Of Integer, Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2}, New LoaderTask(Of Integer, Integer)("预启动处理", AddressOf McLaunchPrerun) With {.ProgressWeight = 1}, New LoaderTask(Of Integer, Integer)("执行自定义命令", AddressOf McLaunchCustom) With {.ProgressWeight = 1}, New LoaderTask(Of Integer, Process)("启动进程", AddressOf McLaunchRun) With {.ProgressWeight = 2}, @@ -117,9 +125,9 @@ Public Module ModLaunch New LoaderTask(Of Integer, Integer)("结束处理", AddressOf McLaunchEnd) With {.ProgressWeight = 1} } '内存优化 - Select Case Setup.Get("VersionRamOptimize", Version:=McVersionCurrent) + Select Case Settings.Get("VersionRamOptimize", Instance:=McInstanceSelected) Case 0 '全局 - If Setup.Get("LaunchArgumentRam") Then '使用全局设置 + If Settings.Get("LaunchArgumentRam") Then '使用全局设置 CType(Loaders(2), LoaderCombo(Of String)).Block = False Loaders.Insert(3, New LoaderTask(Of Integer, Integer)("内存优化", AddressOf McLaunchMemoryOptimize) With {.ProgressWeight = 30}) End If @@ -132,24 +140,30 @@ Public Module ModLaunch If McLoginLoader.State = LoadState.Finished Then McLoginLoader.State = LoadState.Waiting '要求重启登录主加载器，它会自行决定是否启动副加载器 '等待加载器执行并更新 UI McLaunchLoaderReal = LaunchLoader - AbortHint = Nothing + InterruptHint = Nothing LaunchLoader.Start() '任务栏进度条 LoaderTaskbarAdd(LaunchLoader) Do While LaunchLoader.State = LoadState.Loading FrmLaunchLeft.Dispatcher.Invoke(AddressOf FrmLaunchLeft.LaunchingRefresh) - Thread.Sleep(200) + Thread.Sleep(100) Loop FrmLaunchLeft.Dispatcher.Invoke(AddressOf FrmLaunchLeft.LaunchingRefresh) '成功与失败处理 Select Case LaunchLoader.State Case LoadState.Finished - Hint(McVersionCurrent.Name & " 启动成功！", HintType.Finish) - Case LoadState.Aborted - If AbortHint Is Nothing Then - Hint(If(CurrentLaunchOptions?.SaveBatch Is Nothing, "已取消启动！", "已取消导出启动脚本！"), HintType.Info) + Hint(McInstanceSelected.Name & " 启动成功！", HintType.Green) + '上报 + If Not IsSavingBatch Then + Telemetry("Minecraft 启动成功", + "Version", McInstanceSelected.VersionDisplayName, + "LoginType", GetStringFromEnum(CType(Settings.Get("LoginType"), McLoginType))) + End If + Case LoadState.Interrupted + If InterruptHint Is Nothing Then + Hint(If(IsSavingBatch, "已取消导出启动脚本！", "已取消启动！"), HintType.Blue) Else - Hint(AbortHint, HintType.Finish) + Hint(InterruptHint, HintType.Green) End If Case LoadState.Failed Throw LaunchLoader.Error @@ -162,7 +176,7 @@ NextInner: If CurrentEx.Message.StartsWithF("$") Then '若有以 $ 开头的错误信息，则以此为准显示提示 '若错误信息为 $$，则不提示 - If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败")) + If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(IsSavingBatch, "导出启动脚本失败", "启动失败")) Throw ElseIf CurrentEx.InnerException IsNot Nothing Then '检查下一级错误 @@ -170,10 +184,17 @@ NextInner: GoTo NextInner Else '没有特殊处理过的错误信息 - McLaunchLog("错误：" & GetExceptionDetail(ex)) + McLaunchLog("错误：" & ex.GetDetail()) Log(ex, - If(CurrentLaunchOptions?.SaveBatch Is Nothing, "Minecraft 启动失败", "导出启动脚本失败"), LogLevel.Msgbox, - If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败")) + If(IsSavingBatch, "导出启动脚本失败", "Minecraft 启动失败"), LogLevel.Msgbox, + If(IsSavingBatch, "导出启动脚本失败", "启动失败")) + '上报 + If Not IsSavingBatch Then + Telemetry("Minecraft 启动失败", + "Version", McInstanceSelected.VersionDisplayName, + "LoginType", GetStringFromEnum(CType(Settings.Get("LoginType"), McLoginType)), + "Exception", FilterUserName(FilterAccessToken(ex.GetDetail(), "*"), "*")) + End If Throw End If End Try @@ -191,7 +212,7 @@ NextInner: PageOtherTest.MemoryOptimize(False) Finished = True End Sub, "Launch Memory Optimize") - Do While Not Finished AndAlso Not Loader.IsAborted + Do While Not Finished AndAlso Not Loader.IsInterrupted If Loader.Progress < 0.7 Then Loader.Progress += 0.007 '10s Else @@ -206,14 +227,14 @@ NextInner: #Region "预检测" Private Sub McLaunchPrecheck() - If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) + If Settings.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) '检查路径 - If McVersionCurrent.PathIndie.Contains("!") OrElse McVersionCurrent.PathIndie.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;（" & McVersionCurrent.PathIndie & "）") - If McVersionCurrent.Path.Contains("!") OrElse McVersionCurrent.Path.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;（" & McVersionCurrent.Path & "）") + If McInstanceSelected.PathIndie.Contains("!") OrElse McInstanceSelected.PathIndie.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;（" & McInstanceSelected.PathIndie & "）") + If McInstanceSelected.PathVersion.Contains("!") OrElse McInstanceSelected.PathVersion.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;（" & McInstanceSelected.PathVersion & "）") '检查版本 - If McVersionCurrent Is Nothing Then Throw New Exception("未选择 Minecraft 版本！") - McVersionCurrent.Load() - If McVersionCurrent.State = McVersionState.Error Then Throw New Exception("Minecraft 存在问题：" & McVersionCurrent.Info) + If McInstanceSelected Is Nothing Then Throw New Exception("未选择 Minecraft 版本！") + McInstanceSelected.Load() + If McInstanceSelected.State = McInstanceState.Error Then Throw New Exception("Minecraft 存在问题：" & McInstanceSelected.Info) '检查输入信息 Dim CheckResult As String = "" RunInUiWait(Sub() CheckResult = McLoginAble(McLoginInput())) @@ -223,13 +244,13 @@ NextInner: If CurrentLaunchOptions?.SaveBatch Is Nothing Then '保存脚本时不提示 RunInNewThread( Sub() - Select Case Setup.Get("SystemLaunchCount") + Select Case Settings.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 & + If MyMsgBox("PCL 已经为你启动了 " & Settings.Get("SystemLaunchCount") & " 次游戏啦！" & vbCrLf & "如果 PCL 还算好用的话，能不能考虑赞助一下 PCL……" & vbCrLf & "如果没有大家的支持，PCL 很难在免费、无任何广告的情况下维持数年的更新（磕头）……！", - Setup.Get("SystemLaunchCount") & " 次启动！", "支持 PCL！", "但是我拒绝") = 1 Then - OpenWebsite("https://afdian.com/a/LTCat") + Settings.Get("SystemLaunchCount") & " 次启动！", "支持 PCL！", "但是我拒绝") = 1 Then + OpenWebsite("https://meloong.com/afd/a/LTCat") End If End Select End Sub, "Donate") @@ -237,13 +258,13 @@ NextInner: #End If '正版购买提示 If CurrentLaunchOptions?.SaveBatch Is Nothing AndAlso '保存脚本时不提示 - Not Setup.Get("HintBuy") AndAlso Setup.Get("LoginType") <> McLoginType.Ms Then + Not Settings.Get("HintBuy") AndAlso Settings.Get("LoginType") <> McLoginType.Ms Then If IsSystemLanguageChinese() Then RunInNewThread( Sub() - Select Case Setup.Get("SystemLaunchCount") + Select Case Settings.Get("SystemLaunchCount") Case 3, 8, 15, 30, 50, 70, 90, 110, 130, 180, 220, 280, 330, 380, 450, 550, 660, 750, 880, 950, 1100, 1300, 1500, 1700, 1900 - If MyMsgBox("你已经启动了 " & Setup.Get("SystemLaunchCount") & " 次 Minecraft 啦！" & vbCrLf & + If MyMsgBox("你已经启动了 " & Settings.Get("SystemLaunchCount") & " 次 Minecraft 啦！" & vbCrLf & "如果觉得 Minecraft 还不错，可以购买正版支持一下，毕竟开发游戏也真的很不容易……不要一直白嫖啦。" & vbCrLf & vbCrLf & "在登录一次正版账号后，就不会再出现这个提示了！", "考虑一下正版？", "支持正版游戏！", "下次一定") = 1 Then @@ -251,12 +272,12 @@ NextInner: End If End Select End Sub, "Buy Minecraft") - ElseIf Setup.Get("LoginType") = McLoginType.Legacy Then + ElseIf Settings.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") + Hint("游戏将以试玩模式启动！", HintType.Red) + CurrentLaunchOptions.ExtraGameArgs.Add("--demo") Case 3 Throw New Exception("$$") End Select @@ -382,30 +403,30 @@ NextInner: ''' Public Function McLoginName() As String '根据当前登录方式优先返回 - Select Case Setup.Get("LoginType") + Select Case Settings.Get("LoginType") Case McLoginType.Ms - If Setup.Get("CacheMsV2Name") <> "" Then Return Setup.Get("CacheMsV2Name") + If Settings.Get("CacheMsV2Name") <> "" Then Return Settings.Get("CacheMsV2Name") Case McLoginType.Legacy - If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.BeforeFirst("¨") + If Settings.Get("LoginLegacyName") <> "" Then Return Settings.Get("LoginLegacyName").ToString.BeforeFirst("¨") Case McLoginType.Nide - If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName") + If Settings.Get("CacheNideName") <> "" Then Return Settings.Get("CacheNideName") Case McLoginType.Auth - If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName") + If Settings.Get("CacheAuthName") <> "" Then Return Settings.Get("CacheAuthName") End Select '查找所有可能的项 - If Setup.Get("CacheMsV2Name") <> "" Then Return Setup.Get("CacheMsV2Name") - If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName") - If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName") - If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.BeforeFirst("¨") + If Settings.Get("CacheMsV2Name") <> "" Then Return Settings.Get("CacheMsV2Name") + If Settings.Get("CacheNideName") <> "" Then Return Settings.Get("CacheNideName") + If Settings.Get("CacheAuthName") <> "" Then Return Settings.Get("CacheAuthName") + If Settings.Get("LoginLegacyName") <> "" Then Return Settings.Get("LoginLegacyName").ToString.BeforeFirst("¨") Return Nothing End Function ''' ''' 当前是否可以进行登录。若不可以则会返回错误原因。 ''' Public Function McLoginAble() As String - Select Case Setup.Get("LoginType") + Select Case Settings.Get("LoginType") Case McLoginType.Ms - If Setup.Get("CacheMsV2OAuthRefresh") = "" Then + If Settings.Get("CacheMsV2OAuthRefresh") = "" Then Return FrmLoginMs.IsVaild() Else Return "" @@ -413,13 +434,13 @@ NextInner: Case McLoginType.Legacy Return FrmLoginLegacy.IsVaild() Case McLoginType.Nide - If Setup.Get("CacheNideAccess") = "" Then + If Settings.Get("CacheNideAccess") = "" Then Return FrmLoginNide.IsVaild() Else Return "" End If Case McLoginType.Auth - If Setup.Get("CacheAuthAccess") = "" Then + If Settings.Get("CacheAuthAccess") = "" Then Return FrmLoginAuth.IsVaild() Else Return "" @@ -450,25 +471,25 @@ NextInner: Public McLoginLoader As New LoaderTask(Of McLoginData, McLoginResult)("登录", AddressOf McLoginStart, AddressOf McLoginInput, ThreadPriority.BelowNormal) With {.ReloadTimeout = 1, .ProgressWeight = 15, .Block = False} Public Function McLoginInput() As McLoginData Dim LoginData As McLoginData = Nothing - Dim LoginType As McLoginType = Setup.Get("LoginType") + Dim LoginType As McLoginType = Settings.Get("LoginType") Try Select Case LoginType Case McLoginType.Legacy LoginData = PageLoginLegacy.GetLoginData() Case McLoginType.Ms - If Setup.Get("CacheMsV2OAuthRefresh") = "" Then + If Settings.Get("CacheMsV2OAuthRefresh") = "" Then LoginData = PageLoginMs.GetLoginData() Else LoginData = PageLoginMsSkin.GetLoginData() End If Case McLoginType.Nide - If Setup.Get("CacheNideAccess") = "" Then + If Settings.Get("CacheNideAccess") = "" Then LoginData = PageLoginNide.GetLoginData() Else LoginData = PageLoginNideSkin.GetLoginData() End If Case McLoginType.Auth - If Setup.Get("CacheAuthAccess") = "" Then + If Settings.Get("CacheAuthAccess") = "" Then LoginData = PageLoginAuth.GetLoginData() Else LoginData = PageLoginAuthSkin.GetLoginData() @@ -522,7 +543,7 @@ NextInner: '检查是否已经登录完成 If Not Data.IsForceRestarting AndAlso '不要求强行重启 Input.AccessToken <> "" AndAlso '已经登录过了 - (McLoginMsRefreshTime > 0 AndAlso GetTimeTick() - McLoginMsRefreshTime < 1000 * 60 * 10) Then '完成时间在 10 分钟内 + (McLoginMsRefreshTime > 0 AndAlso GetTimeMs() - 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 @@ -538,41 +559,41 @@ Relogin: OAuthTokens = MsLoginStep1Refresh(Input.OAuthRefreshToken) If OAuthTokens(0) = "Relogin" Then GoTo Relogin '要求重新打开登录网页认证 End If - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException Data.Progress = 0.25 - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException Dim OAuthAccessToken As String = OAuthTokens(0) Dim OAuthRefreshToken As String = OAuthTokens(1) Dim XBLToken As String = MsLoginStep2(OAuthAccessToken) Data.Progress = 0.4 - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException Dim Tokens = MsLoginStep3(XBLToken) Data.Progress = 0.55 - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException Dim AccessToken As String = MsLoginStep4(Tokens) Data.Progress = 0.7 - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException MsLoginStep5(AccessToken) Data.Progress = 0.85 - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException Dim Result = MsLoginStep6(AccessToken) Data.Progress = 0.98 '输出登录结果 - Setup.Set("CacheMsV2OAuthRefresh", OAuthRefreshToken) - Setup.Set("CacheMsV2Access", AccessToken) - Setup.Set("CacheMsV2Uuid", Result(0)) - Setup.Set("CacheMsV2Name", Result(1)) - Setup.Set("CacheMsV2ProfileJson", Result(2)) - Dim MsJson As JObject = GetJson(Setup.Get("LoginMsJson")) + Settings.Set("CacheMsV2OAuthRefresh", OAuthRefreshToken) + Settings.Set("CacheMsV2Access", AccessToken) + Settings.Set("CacheMsV2Uuid", Result(0)) + Settings.Set("CacheMsV2Name", Result(1)) + Settings.Set("CacheMsV2ProfileJson", Result(2)) + Dim MsJson As JObject = GetJson(Settings.Get("LoginMsJson")) MsJson.Remove(Input.UserName) '如果更改了玩家名…… MsJson(Result(1)) = OAuthRefreshToken - Setup.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None)) + Settings.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)} '结束 - McLoginMsRefreshTime = GetTimeTick() + McLoginMsRefreshTime = GetTimeMs() McLaunchLog("微软登录完成") SkipLogin: - Setup.Set("HintBuy", True) '关闭正版购买提示 + Settings.Set("HintBuy", True) '关闭正版购买提示 If ThemeUnlock(10, False) Then MyMsgBox("感谢你对正版游戏的支持！" & vbCrLf & "隐藏主题 跳票红 已解锁！", "提示") End Sub Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult)) @@ -582,44 +603,40 @@ SkipLogin: Data.Progress = 0.05 '尝试登录 If (Not Data.Input.ForceReselectProfile) AndAlso - Setup.Get("Cache" & Input.Token & "Username") = Data.Input.UserName AndAlso - Setup.Get("Cache" & Input.Token & "Pass") = Data.Input.Password AndAlso - Setup.Get("Cache" & Input.Token & "Access") <> "" AndAlso - Setup.Get("Cache" & Input.Token & "Client") <> "" AndAlso - Setup.Get("Cache" & Input.Token & "Uuid") <> "" AndAlso - Setup.Get("Cache" & Input.Token & "Name") <> "" Then + Settings.Get("Cache" & Input.Token & "Username") = Data.Input.UserName AndAlso + Settings.Get("Cache" & Input.Token & "Pass") = Data.Input.Password AndAlso + Settings.Get("Cache" & Input.Token & "Access") <> "" AndAlso + Settings.Get("Cache" & Input.Token & "Client") <> "" AndAlso + Settings.Get("Cache" & Input.Token & "Uuid") <> "" AndAlso + Settings.Get("Cache" & Input.Token & "Name") <> "" Then '尝试验证登录 Try - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException McLoginRequestValidate(Data) GoTo LoginFinish Catch ex As Exception - Dim AllMessage = GetExceptionDetail(ex) - McLaunchLog("验证登录失败：" & AllMessage) - If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then - McLaunchLog("已触发超时登录失败") - Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。") - End If + Log(ex, "验证登录失败") + If IsNetworkRelated(ex) Then Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。") End Try Data.Progress = 0.25 '尝试刷新登录 Refresh: Try - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException McLoginRequestRefresh(Data, NeedRefresh) GoTo LoginFinish Catch ex As Exception - McLaunchLog("刷新登录失败：" & GetExceptionDetail(ex)) + McLaunchLog("刷新登录失败：" & ex.GetDetail()) If WasRefreshed Then Throw New Exception("二轮刷新登录失败", ex) End Try Data.Progress = If(NeedRefresh, 0.85, 0.45) End If '尝试普通登录 Try - If Data.IsAborted Then Throw New ThreadInterruptedException + If Data.IsInterrupted Then Throw New ThreadInterruptedException NeedRefresh = McLoginRequestLogin(Data) Catch ex As Exception - McLaunchLog("登录失败：" & GetExceptionDetail(ex)) + McLaunchLog("登录失败：" & ex.GetDetail()) Throw End Try If NeedRefresh Then @@ -635,8 +652,8 @@ LoginFinish: Dim Emails As New List(Of String) Dim Passwords As New List(Of String) Try - If Not Setup.Get("Login" & Input.Token & "Email") = "" Then Emails.AddRange(Setup.Get("Login" & Input.Token & "Email").ToString.Split("¨")) - If Not Setup.Get("Login" & Input.Token & "Pass") = "" Then Passwords.AddRange(Setup.Get("Login" & Input.Token & "Pass").ToString.Split("¨")) + If Not Settings.Get("Login" & Input.Token & "Email") = "" Then Emails.AddRange(Settings.Get("Login" & Input.Token & "Email").ToString.Split("¨")) + If Not Settings.Get("Login" & Input.Token & "Pass") = "" Then Passwords.AddRange(Settings.Get("Login" & Input.Token & "Pass").ToString.Split("¨")) For i = 0 To Emails.Count - 1 Dict.Add(Emails(i), Passwords(i)) Next @@ -645,12 +662,12 @@ LoginFinish: Emails.Insert(0, Input.UserName) Passwords = New List(Of String)(Dict.Values) Passwords.Insert(0, Input.Password) - Setup.Set("Login" & Input.Token & "Email", Join(Emails, "¨")) - Setup.Set("Login" & Input.Token & "Pass", Join(Passwords, "¨")) + Settings.Set("Login" & Input.Token & "Email", Emails.Join("¨"c)) + Settings.Set("Login" & Input.Token & "Pass", Passwords.Join("¨"c)) Catch ex As Exception Log(ex, "保存启动记录失败", LogLevel.Hint) - Setup.Set("Login" & Input.Token & "Email", "") - Setup.Set("Login" & Input.Token & "Pass", "") + Settings.Set("Login" & Input.Token & "Email", "") + Settings.Set("Login" & Input.Token & "Pass", "") End Try End Sub Private Sub McLoginLegacyStart(Data As LoaderTask(Of McLoginLegacy, McLoginResult)) @@ -667,28 +684,27 @@ LoginFinish: Data.Output.ClientToken = Data.Output.Uuid '保存启动记录 Dim Names As New List(Of String) - If Not Setup.Get("LoginLegacyName") = "" Then Names.AddRange(Setup.Get("LoginLegacyName").ToString.Split("¨")) + If Not Settings.Get("LoginLegacyName") = "" Then Names.AddRange(Settings.Get("LoginLegacyName").ToString.Split("¨")) Names.Remove(Input.UserName) Names.Insert(0, Input.UserName) - Setup.Set("LoginLegacyName", Join(Names.ToArray, "¨")) + Settings.Set("LoginLegacyName", Names.Join("¨"c)) End Sub 'Server 登录：三种验证方式的请求 Private Sub McLoginRequestValidate(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult)) McLaunchLog("验证登录开始（Validate, " & Data.Input.Token & "）") '提前缓存信息，否则如果在登录请求过程中退出登录，设置项目会被清空，导致输出存在空值 - Dim AccessToken As String = Setup.Get("Cache" & Data.Input.Token & "Access") - Dim ClientToken As String = Setup.Get("Cache" & Data.Input.Token & "Client") - Dim Uuid As String = Setup.Get("Cache" & Data.Input.Token & "Uuid") - Dim Name As String = Setup.Get("Cache" & Data.Input.Token & "Name") + Dim AccessToken As String = Settings.Get("Cache" & Data.Input.Token & "Access") + Dim ClientToken As String = Settings.Get("Cache" & Data.Input.Token & "Client") + Dim Uuid As String = Settings.Get("Cache" & Data.Input.Token & "Uuid") + Dim Name As String = Settings.Get("Cache" & Data.Input.Token & "Name") '发送登录请求 Dim RequestData As New JObject( New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True)) - NetRequestRetry( - Url:=Data.Input.BaseUrl & "/validate", - Method:="POST", - Data:=RequestData.ToString(0), - Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}}, + NetRequestByClientRetry( + Data.Input.BaseUrl & "/validate", HttpMethod.Post, + Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None), + Headers:={{"Accept-Language", "zh-CN"}}, ContentType:="application/json; charset=utf-8") '没有返回值的 '将登录结果输出 Data.Output.AccessToken = AccessToken @@ -701,33 +717,32 @@ LoginFinish: End Sub Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean) McLaunchLog("刷新登录开始（Refresh, " & Data.Input.Token & "）") - Dim LoginJson As JObject = GetJson(NetRequestRetry( - Url:=Data.Input.BaseUrl & "/refresh", - Method:="POST", - Data:=New JObject( + Dim LoginJson As JObject = GetJson(NetRequestByClientRetry( + Data.Input.BaseUrl & "/refresh", HttpMethod.Post, + Content:=New JObject( New JProperty("selectedProfile", New JObject( - New JProperty("name", Setup.Get($"Cache{Data.Input.Token}Name")), - New JProperty("id", Setup.Get($"Cache{Data.Input.Token}Uuid")) + New JProperty("name", Settings.Get($"Cache{Data.Input.Token}Name")), + New JProperty("id", Settings.Get($"Cache{Data.Input.Token}Uuid")) )), - New JProperty("accessToken", Setup.Get($"Cache{Data.Input.Token}Access")), + New JProperty("accessToken", Settings.Get($"Cache{Data.Input.Token}Access")), New JProperty("requestUser", True) ).ToString(Newtonsoft.Json.Formatting.None), - Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}}, - ContentType:="application/json; charset=utf-8")) + Headers:={{"Accept-Language", "zh-CN"}}, + ContentType:="application/json; charset=utf-8", RequireJson:=True)) '将登录结果输出 - If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效！") + If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Settings.Get("Cache" & Data.Input.Token & "Name") & " 无效！") Data.Output.AccessToken = LoginJson("accessToken").ToString Data.Output.ClientToken = LoginJson("clientToken").ToString Data.Output.Uuid = LoginJson("selectedProfile")("id").ToString Data.Output.Name = LoginJson("selectedProfile")("name").ToString Data.Output.Type = Data.Input.Token '保存缓存 - Setup.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken) - Setup.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken) - Setup.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid) - Setup.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name) - Setup.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName) - Setup.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password) + Settings.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken) + Settings.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken) + Settings.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid) + Settings.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name) + Settings.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName) + Settings.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password) McLaunchLog("刷新登录成功（Refresh, " & Data.Input.Token & "）") End Sub Private Function McLoginRequestLogin(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult)) As Boolean @@ -739,25 +754,24 @@ LoginFinish: New JProperty("username", Data.Input.UserName), New JProperty("password", Data.Input.Password), New JProperty("requestUser", True)) - Dim LoginJson As JObject = GetJson(NetRequestRetry( - 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")) + Dim LoginJson As JObject = GetJson(NetRequestByClientRetry( + Data.Input.BaseUrl & "/authenticate", HttpMethod.Post, + Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None), + Headers:={{"Accept-Language", "zh-CN"}}, + ContentType:="application/json; charset=utf-8", RequireJson:=True)) '检查登录结果 If LoginJson("availableProfiles").Count = 0 Then - If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色，无法更换！", HintType.Critical) + If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色，无法更换！", HintType.Red) Throw New Exception("$你还没有创建角色，请在创建角色后再试！") - ElseIf Data.Input.ForceReselectProfile AndAlso LoginJson("availableProfiles").Count = 1 Then - Hint("你的账户中只有一个角色，无法更换！", HintType.Critical) + ElseIf Data.Input.ForceReselectProfile AndAlso LoginJson("availableProfiles").IsSingle Then + Hint("你的账户中只有一个角色，无法更换！", HintType.Red) End If Dim SelectedName As String = Nothing Dim SelectedId As String = Nothing If (LoginJson("selectedProfile") Is Nothing OrElse Data.Input.ForceReselectProfile) AndAlso LoginJson("availableProfiles").Count > 1 Then '要求选择档案；优先从缓存读取 NeedRefresh = True - Dim CacheId As String = Setup.Get("Cache" & Data.Input.Token & "Uuid") + Dim CacheId As String = Settings.Get("Cache" & Data.Input.Token & "Uuid") For Each Profile In LoginJson("availableProfiles") If Profile("id").ToString = CacheId Then SelectedName = Profile("name").ToString @@ -793,22 +807,23 @@ LoginFinish: Data.Output.Uuid = SelectedId Data.Output.Type = Data.Input.Token '保存缓存 - Setup.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken) - Setup.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken) - Setup.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid) - Setup.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name) - Setup.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName) - Setup.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password) + Settings.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken) + Settings.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken) + Settings.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid) + Settings.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name) + Settings.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName) + Settings.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password) McLaunchLog("登录成功（Login, " & Data.Input.Token & "）") Return NeedRefresh Catch ex As Exception - Dim AllMessage As String = GetExceptionSummary(ex) + Dim AllMessage As String = ex.GetBrief() Log(ex, "登录失败原始错误信息", LogLevel.Normal) '读取服务器返回的错误 If TypeOf ex Is ResponsedWebException Then Dim ErrorMessage As String = Nothing Try - ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage") + Dim Response = DirectCast(ex, ResponsedWebException).Response + If Response.ContainsF("errorMessage", True) Then ErrorMessage = GetJson(Response)("errorMessage").ToString() Catch End Try If Not String.IsNullOrWhiteSpace(ErrorMessage) Then @@ -826,7 +841,7 @@ LoginFinish: End If End If '通用关键字检测 - If AllMessage.Contains("403") Then + If AllMessage.Contains("(403)") Then Select Case Data.Input.Type Case McLoginType.Auth Throw New Exception("$登录失败，以下为可能的原因：" & vbCrLf & @@ -840,8 +855,8 @@ LoginFinish: If(Data.Input.UserName.Contains("@"), "", " - 登录账号应为邮箱或统一通行证账号，而非游戏角色 ID。" & vbCrLf) & " - 只注册了账号，但没有加入对应服务器。") End Select - ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then - Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。") + ElseIf ex.IsNetworkRelated() Then + Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。") ElseIf ex.Message.StartsWithF("$") Then Throw Else @@ -858,8 +873,9 @@ LoginFinish: '初始请求 Retry: McLaunchLog("开始微软登录步骤 1/6（原始登录）") - Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST", - $"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded")) + Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post, + Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", + ContentType:="application/x-www-form-urlencoded", RequireJson:=True)) McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString) '弹窗 @@ -888,13 +904,23 @@ Retry: Dim Result As String Try - Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST", - $"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access", - "application/x-www-form-urlencoded", 2) - Catch ex As Exception - If ex.Message.ContainsF("must sign in again", True) OrElse ex.Message.ContainsF("password expired", True) OrElse - (ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269 + Result = NetRequestByClientMultiple("https://login.live.com/oauth20_token.srf", HttpMethod.Post, + Content:=$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access", + ContentType:="application/x-www-form-urlencoded", + Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}}, + ThreadCount:=2) + Catch ex As ResponsedWebException + '修改错误列表时，同时检查 MyMsgLogin.xaml.vb 中的对应代码 + Dim Response = ex.Response + If Response.ContainsF("must sign in again", True) OrElse Response.ContainsF("password expired", True) OrElse + (Response.Contains("refresh_token") AndAlso Response.Contains("is not valid")) Then '#269 Return {"Relogin", ""} + ElseIf Response.Contains("Account security interrupt") Then + MyMsgBox("该账号由于安全问题无法登陆，请前往微软账户页获取更多信息。", "登录失败", "我知道了", IsWarn:=True) + Throw New Exception("$$") + ElseIf Response.Contains("service abuse") Then + MyMsgBox("非常抱歉，该账号已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True) + Throw New Exception("$$") Else Throw End If @@ -918,43 +944,40 @@ Retry: ""RelyingParty"": ""http://auth.xboxlive.com"", ""TokenType"": ""JWT"" }" - Dim Result As String = NetRequestMultiple("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3) - - Dim ResultJson As JObject = GetJson(Result) - Dim XBLToken As String = ResultJson("Token").ToString - Return XBLToken + Dim Result As String = NetRequestByClientMultiple("https://user.auth.xboxlive.com/user/authenticate", HttpMethod.Post, + Content:=Request, ContentType:="application/json", RequireJson:=True) + Return GetJson(Result)("Token").ToString End Function '微软登录步骤 3：从 XBLToken 获取 {XSTSToken, UHS} Private Function MsLoginStep3(XBLToken As String) As String() McLaunchLog("开始微软登录步骤 3/6") Dim Request As String = "{ - ""Properties"": { - ""SandboxId"": ""RETAIL"", - ""UserTokens"": [ - """ & XBLToken & """ - ] - }, - ""RelyingParty"": ""rp://api.minecraftservices.com/"", - ""TokenType"": ""JWT"" - }" + ""Properties"": { + ""SandboxId"": ""RETAIL"", + ""UserTokens"": [""" & XBLToken & """] + }, + ""RelyingParty"": ""rp://api.minecraftservices.com/"", + ""TokenType"": ""JWT"" + }" Dim Result As String Try - Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3) - Catch ex As Net.WebException + Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post, + Content:=Request, ContentType:="application/json", RequireJson:=True) + Catch ex As ResponsedWebException '参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js - If ex.Message.Contains("2148916227") Then + If ex.Response.Contains("2148916227") Then MyMsgBox("该账号似乎已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True) Throw New Exception("$$") - ElseIf ex.Message.Contains("2148916233") Then + ElseIf ex.Response.Contains("2148916233") Then If MyMsgBox("你尚未注册 Xbox 账户，请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then OpenWebsite("https://signup.live.com/signup") End If Throw New Exception("$$") - ElseIf ex.Message.Contains("2148916235") Then - MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN。", "登录失败", "我知道了") + ElseIf ex.Response.Contains("2148916235") Then + MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN，然后再试。", "登录失败", "我知道了") Throw New Exception("$$") - ElseIf ex.Message.Contains("2148916238") Then + ElseIf ex.Response.Contains("2148916238") Then If MyMsgBox("该账号年龄不足，你需要先修改出生日期，然后才能登录。" & vbCrLf & "该账号目前填写的年龄是否在 13 岁以上？", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then OpenWebsite("https://account.live.com/editprof.aspx") @@ -972,9 +995,10 @@ Retry: End Try Dim ResultJson As JObject = GetJson(Result) - Dim XSTSToken As String = ResultJson("Token").ToString - Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString - Return {XSTSToken, UHS} + Return { + ResultJson("Token"), 'XSTSToken + ResultJson("DisplayClaims")("xui")(0)("uhs") 'UHS + } End Function '微软登录步骤 4：从 {XSTSToken, UHS} 获取 Minecraft AccessToken Private Function MsLoginStep4(Tokens As String()) As String @@ -983,29 +1007,29 @@ Retry: Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0) Dim Result As String Try - Result = NetRequestRetry("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json") + Result = NetRequestByClientRetry("https://api.minecraftservices.com/authentication/login_with_xbox", HttpMethod.Post, + Content:=Request, ContentType:="application/json", RequireJson:=True) Catch ex As Net.WebException - Dim Message As String = GetExceptionSummary(ex) + Dim Message As String = ex.GetBrief() If Message.Contains("(429)") Then - Log(ex, "微软登录第 5 步汇报 429") + Log(ex, "微软登录第 4 步汇报 429") Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！") ElseIf Message.Contains("(403)") Then - Log(ex, "微软登录第 5 步汇报 403") + Log(ex, "微软登录第 4 步汇报 403") Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器，请把它们关掉或更换节点后再试！") Else Throw End If End Try - Dim ResultJson As JObject = GetJson(Result) - Dim AccessToken As String = ResultJson("access_token").ToString - Return AccessToken + Return GetJson(Result)("access_token").ToString End Function '微软登录步骤 5：验证微软账号是否持有 MC，这也会刷新 XGP Private Sub MsLoginStep5(AccessToken As String) McLaunchLog("开始微软登录步骤 5/6") - Dim Result As String = NetRequestMultiple("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}}) + Dim Result As String = NetRequestByClientMultiple("https://api.minecraftservices.com/entitlements/mcstore", + ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True) Try Dim ResultJson As JObject = GetJson(Result) If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then @@ -1016,7 +1040,7 @@ Retry: Throw New Exception("$$") End If Catch ex As Exception - Log(ex, "微软登录第 6 步异常：" & Result) + Log(ex, "微软登录第 5 步异常：" & Result) Throw End Try End Sub @@ -1026,14 +1050,15 @@ Retry: Dim Result As String Try - Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}}) - Catch ex As Net.WebException - Dim Message As String = GetExceptionSummary(ex) + Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile", + ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True) + Catch ex As WebException + Dim Message As String = ex.GetBrief() If Message.Contains("(429)") Then - Log(ex, "微软登录第 7 步汇报 429") + Log(ex, "微软登录第 6 步汇报 429") Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！") ElseIf Message.Contains("(404)") Then - Log(ex, "微软登录第 7 步汇报 404") + Log(ex, "微软登录第 6 步汇报 404") RunInNewThread( Sub() Select Case MyMsgBox("请先创建 Minecraft 玩家档案，然后再重新登录。", "登录失败", "创建档案", "取消") @@ -1075,7 +1100,7 @@ Retry: '使用正版用户名 Try If SkinName <> "" AndAlso - McVersionCurrent IsNot Nothing AndAlso McVersionCurrent.Version.McCodeMain < 20 Then '1.20+ 或快照版不能使用该项（#3746） + McInstanceSelected IsNot Nothing AndAlso McInstanceSelected.Version.Vanilla.Major < 20 Then '1.20+ 或快照版不能使用该项（#3746） Log("[Skin] 由于离线皮肤设置，使用正版 UUID：" & SkinName) Uuid = McLoginMojangUuid(SkinName, False) End If @@ -1084,7 +1109,7 @@ Retry: End Try Case 4 '自定义 - Do Until McSkinSex(Uuid) = If(Setup.Get("LaunchSkinSlim"), "Alex", "Steve") + Do Until McSkinSex(Uuid) = If(Settings.Get("LaunchSkinSlim"), "Alex", "Steve") If Uuid.EndsWithF("FFFFF") Then Uuid = Uuid.Substring(0, 27) & "00000" Uuid = Uuid.Substring(0, 27) & (Long.Parse(Uuid.Substring(27), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X").PadLeft(5, "0") Loop @@ -1099,7 +1124,7 @@ Retry: If Len(Uuid) = 32 Then Return Uuid '从官网获取 Try - Dim GotJson As JObject = NetGetCodeByRequestRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, IsJson:=True) + Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, RequireJson:=True)) If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在（" & Name & "）") Uuid = If(GotJson("id"), "") Catch ex As Exception @@ -1128,85 +1153,121 @@ Retry: Private Sub McLaunchJava(Task As LoaderTask(Of Integer, Integer)) Dim MinVer As New Version(0, 0, 0, 0), MaxVer As New Version(999, 999, 999, 999) - 'MC 大版本检测 - If (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2024, 4, 2)) OrElse - (McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 20, 5)) Then + '原版 26-：通过版本号判断 + If (Not McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.ReleaseTime >= New Date(2024, 4, 2)) OrElse + (McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.Version.Vanilla >= New Version(20, 0, 5)) Then '1.20.5+（24w14a+）：至少 Java 21 MinVer = New Version(1, 21, 0, 0) - ElseIf (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16)) OrElse - (McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 18)) Then + ElseIf (Not McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.ReleaseTime >= New Date(2021, 11, 16)) OrElse + (McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.Version.Vanilla.Major >= 18) Then '1.18 pre2+：至少 Java 17 MinVer = New Version(1, 17, 0, 0) - ElseIf (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2021, 5, 11)) OrElse - (McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 17)) Then + ElseIf (Not McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.ReleaseTime >= New Date(2021, 5, 11)) OrElse + (McInstanceSelected.Version.Vaild AndAlso McInstanceSelected.Version.Vanilla.Major >= 17) Then '1.17+ (21w19a+)：至少 Java 16 MinVer = New Version(1, 16, 0, 0) - ElseIf McVersionCurrent.ReleaseTime.Year >= 2017 Then 'Minecraft 1.12 与 1.11 的分界线正好是 2017 年，太棒了 + ElseIf McInstanceSelected.ReleaseTime.Year >= 2017 Then 'Minecraft 1.12 与 1.11 的分界线正好是 2017 年，太棒了 '1.12+：至少 Java 8 MinVer = New Version(1, 8, 0, 0) - ElseIf McVersionCurrent.ReleaseTime <= New Date(2013, 5, 1) AndAlso McVersionCurrent.ReleaseTime.Year >= 2001 Then '避免某些版本写个 1960 年 - '1.5.2-：最高 Java 12 - MaxVer = New Version(1, 12, 999, 999) + ElseIf McInstanceSelected.ReleaseTime <= New Date(2013, 5, 1) AndAlso McInstanceSelected.ReleaseTime.Year >= 2001 Then '避免某些版本写个 1960 年 + '1.5.2-：最高 Java 8 + MaxVer = New Version(1, 8, 999, 999) End If - If McVersionCurrent.JsonVersion?("java_version") IsNot Nothing Then - Dim RecommendedJava As Integer = McVersionCurrent.JsonVersion("java_version").ToObject(Of Integer) - McLaunchLog("Mojang 推荐使用 Java " & RecommendedJava) - If RecommendedJava >= 22 Then MinVer = New Version(1, RecommendedJava, 0, 0) '潜在的向后兼容 + + '原版 26+：获取 Mojang 要求的 Java 版本 + Dim RecommendedComponent As String = Nothing + Dim RecommendedCode As Integer = + If(McInstanceSelected.JsonObject?("javaVersion")?("majorVersion")?.ToObject(Of Integer), + If(McInstanceSelected.JsonVersion?("java_version")?.ToObject(Of Integer), 0)) + If RecommendedCode >= 22 Then + McLaunchLog("Mojang 要求至少使用 Java " & RecommendedCode) + MinVer = New Version(1, RecommendedCode, 0, 0) + RecommendedComponent = + If(McInstanceSelected.JsonObject?("javaVersion")?("component")?.ToString, + McInstanceSelected.JsonVersion?("java_component")?.ToString) + If RecommendedComponent = "" Then RecommendedComponent = Nothing End If 'OptiFine 检测 - If McVersionCurrent.Version.HasOptiFine AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本 - If McVersionCurrent.Version.McVersion < New Version(1, 7) Then + If McInstanceSelected.Version.HasOptiFine AndAlso McInstanceSelected.Version.Vaild Then '不管非标准版本 + If McInstanceSelected.Version.Vanilla.Major < 7 Then '<1.7：至多 Java 8 MaxVer = New Version(1, 8, 999, 999) - ElseIf McVersionCurrent.Version.McVersion >= New Version(1, 8) AndAlso McVersionCurrent.Version.McVersion < New Version(1, 12) Then + ElseIf McInstanceSelected.Version.Vanilla.Major >= 8 AndAlso McInstanceSelected.Version.Vanilla.Major < 12 Then '1.8 - 1.11：必须恰好 Java 8 MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 8, 999, 999) - ElseIf McVersionCurrent.Version.McCodeMain = 12 Then + ElseIf McInstanceSelected.Version.Vanilla.Major = 12 Then '1.12：最高 Java 8 MaxVer = New Version(1, 8, 999, 999) End If End If - 'Forge 检测 - If McVersionCurrent.Version.HasForge Then - If McVersionCurrent.Version.McVersion >= New Version(1, 6, 1) AndAlso McVersionCurrent.Version.McVersion <= New Version(1, 7, 2) Then + 'Forge 检测（部分测试结果见 #8432） + If McInstanceSelected.Version.HasForge Then + If McInstanceSelected.Version.Vanilla >= New Version(6, 0, 1) AndAlso McInstanceSelected.Version.Vanilla <= New Version(7, 0, 2) Then '1.6.1 - 1.7.2：必须 Java 7 MinVer = If(New Version(1, 7, 0, 0) > MinVer, New Version(1, 7, 0, 0), MinVer) MaxVer = If(New Version(1, 7, 999, 999) < MaxVer, New Version(1, 7, 999, 999), MaxVer) - ElseIf McVersionCurrent.Version.McCodeMain <= 12 OrElse Not McVersionCurrent.Version.IsStandardVersion Then '非标准版本 + ElseIf McInstanceSelected.Version.Vanilla.Major <= 12 OrElse Not McInstanceSelected.Version.Vaild Then '非标准版本 '<=1.12：Java 8 MaxVer = New Version(1, 8, 999, 999) - ElseIf McVersionCurrent.Version.McCodeMain <= 14 Then + ElseIf McInstanceSelected.Version.Vanilla.Major <= 14 Then '1.13 - 1.14：Java 8 - 10 MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer) MaxVer = If(New Version(1, 10, 999, 999) < MaxVer, New Version(1, 10, 999, 999), MaxVer) - ElseIf McVersionCurrent.Version.McCodeMain = 15 Then + ElseIf McInstanceSelected.Version.Vanilla.Major = 15 Then '1.15：Java 8 - 15 MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer) MaxVer = If(New Version(1, 15, 999, 999) < MaxVer, New Version(1, 15, 999, 999), MaxVer) - ElseIf VersionSortBoolean(McVersionCurrent.Version.ForgeVersion, "34.0.0") AndAlso VersionSortBoolean("36.2.25", McVersionCurrent.Version.ForgeVersion) Then - '1.16，Forge 34.X ~ 36.2.25：最高 Java 8u320 + ElseIf CompareVersionGE(McInstanceSelected.Version.Forge, "34.0.0") AndAlso CompareVersionGE("36.2.25", McInstanceSelected.Version.Forge) Then + '1.16.3~5，Forge 34.0.0 ~ 36.2.25：最高 Java 8u320 MaxVer = If(New Version(1, 8, 0, 320) < MaxVer, New Version(1, 8, 0, 320), MaxVer) - ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 19 AndAlso McVersionCurrent.Version.HasOptiFine Then '#305 + ElseIf CompareVersionGE(McInstanceSelected.Version.Forge, "36.2.26") AndAlso CompareVersionGE("36.999.999", McInstanceSelected.Version.Forge) Then + '1.16.5，Forge 36.2.26+，<37.0.0：最高 Java 23 + MaxVer = If(New Version(1, 23, 999, 999) < MaxVer, New Version(1, 23, 999, 999), MaxVer) + ElseIf CompareVersionGE(McInstanceSelected.Version.Forge, "37.0.0") AndAlso CompareVersionGE("37.0.79", McInstanceSelected.Version.Forge) Then + '1.17.1，Forge 37.0.0 ~ 37.0.79：最高 Java 16 + MaxVer = If(New Version(1, 16, 999, 999) < MaxVer, New Version(1, 16, 999, 999), MaxVer) + ElseIf McInstanceSelected.Version.Vanilla.Major = 18 AndAlso McInstanceSelected.Version.HasOptiFine Then '#305 '1.18：若安装了 OptiFine，最高 Java 18 MaxVer = If(New Version(1, 18, 999, 999) < MaxVer, New Version(1, 18, 999, 999), MaxVer) + ElseIf CompareVersionGE(McInstanceSelected.Version.Forge, "45.0.21") AndAlso CompareVersionGE("45.0.65", McInstanceSelected.Version.Forge) Then + '1.19.4，Forge 45.0.21 ~ 45.0.65：最高 Java 19 + MaxVer = If(New Version(1, 19, 999, 999) < MaxVer, New Version(1, 19, 999, 999), MaxVer) + ElseIf CompareVersionGE(McInstanceSelected.Version.Forge, "45.0.66") AndAlso CompareVersionGE("47.4.8", McInstanceSelected.Version.Forge) Then + '1.19.4~1.20.1，Forge 45.0.66 ~ 47.4.8：最高 Java 21 + MaxVer = If(New Version(1, 21, 999, 999) < MaxVer, New Version(1, 21, 999, 999), MaxVer) + End If + End If + + 'NeoForge 检测 + If McInstanceSelected.Version.HasNeoForge Then + If McInstanceSelected.Version.Vanilla = New Version(20, 0, 1) OrElse + (CompareVersionGE("20.2.62-beta", McInstanceSelected.Version.NeoForge) AndAlso Not McInstanceSelected.Version.NeoForge.Contains("25w14craftmine")) Then + '1.20.1，以及 1.20.2 的 20.2.62-beta 之前：最高 Java 21 + MaxVer = If(New Version(1, 21, 999, 999) < MaxVer, New Version(1, 21, 999, 999), MaxVer) End If End If 'Fabric 检测 - If McVersionCurrent.Version.HasFabric AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本 - If McVersionCurrent.Version.McCodeMain >= 15 AndAlso McVersionCurrent.Version.McCodeMain <= 16 Then + If McInstanceSelected.Version.HasFabric AndAlso McInstanceSelected.Version.Vaild Then '不管非标准版本 + If McInstanceSelected.Version.Vanilla.Major >= 15 AndAlso McInstanceSelected.Version.Vanilla.Major <= 16 Then '1.15 - 1.16：Java 8+ MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer) - ElseIf McVersionCurrent.Version.McCodeMain >= 18 Then + ElseIf McInstanceSelected.Version.Vanilla.Major >= 18 Then '1.18+：Java 17+ MinVer = If(New Version(1, 17, 0, 0) > MinVer, New Version(1, 17, 0, 0), MinVer) End If End If + 'LiteLoader 检测 + If McInstanceSelected.Version.HasLiteLoader AndAlso McInstanceSelected.Version.Vaild Then '不管非标准版本 + '最高 Java 8 + MaxVer = If(New Version(1, 8, 999, 999) < MaxVer, New Version(1, 8, 999, 999), MaxVer) + End If + '统一通行证检测 - If Setup.Get("LoginType") = McLoginType.Nide Then + If Settings.Get("LoginType") = McLoginType.Nide Then '至少 Java 8u101 MinVer = If(New Version(1, 8, 0, 141) > MinVer, New Version(1, 8, 0, 141), MinVer) End If @@ -1215,67 +1276,52 @@ Retry: '选择 Java McLaunchLog("Java 版本需求：最低 " & MinVer.ToString & "，最高 " & MaxVer.ToString) - McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent) - If Task.IsAborted Then Return + McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McInstanceSelected) + If Task.IsInterrupted Then Return If McLaunchJavaSelected IsNot Nothing Then McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString) Return End If '无合适的 Java - If Task.IsAborted Then Return '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java - McLaunchLog("无合适的 Java，需要确认是否自动下载") + If Task.IsInterrupted Then Return '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java + McLaunchLog("无合适的 Java，准备自动下载") Dim JavaCode As String - If MinVer >= New Version(1, 22) Then '潜在的向后兼容 + If MinVer >= New Version(1, 9) Then JavaCode = MinVer.Minor - If Not JavaDownloadConfirm("Java " & JavaCode) Then Throw New Exception("$$") - ElseIf MinVer >= New Version(1, 21) Then - JavaCode = 21 - If Not JavaDownloadConfirm("Java 21") Then Throw New Exception("$$") - ElseIf MinVer >= New Version(1, 9) Then - JavaCode = 17 - If Not JavaDownloadConfirm("Java 17") Then Throw New Exception("$$") ElseIf MaxVer < New Version(1, 8) Then - JavaCode = 7 - If McVersionCurrent.Version.HasForge Then - MyMsgBox("你需要先安装 LegacyJavaFixer Mod，或自行安装 Java 7，然后才能启动该版本。", "未找到 Java") - Else - If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$") - End If + MyMsgBox($"你需要安装 Java 7 才能启动该版本。{vbCrLf}请自行搜索并安装 Java 7，安装后在 设置 → 启动选项 → 游戏 Java 中重新搜索或导入。", "未找到 Java") + 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("$$") + MyMsgBox($"你需要安装 Java 8u141 ~ 8u320 才能启动该版本。{vbCrLf}请自行搜索并安装，安装后在 设置 → 启动选项 → 游戏 Java 中重新搜索或导入。", "未找到 Java") + 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("$$") + MyMsgBox($"你需要安装 Java 8u141 或更高版本的 Java 8 才能启动该版本。{vbCrLf}请自行搜索并安装，安装后在 设置 → 启动选项 → 游戏 Java 中重新搜索或导入。", "未找到 Java") + Throw New Exception("$$") Else JavaCode = 8 - If Not JavaDownloadConfirm("Java 8") Then Throw New Exception("$$") End If '开始自动下载 - Dim JavaLoader = JavaFixLoaders(JavaCode) + Dim JavaLoader = GetJavaDownloadLoader() Try - JavaLoader.Start(JavaCode, IsForceRestart:=True) - Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsAborted + JavaLoader.Start(If(RecommendedComponent, JavaCode), IsForceRestart:=True) '在 Java 22+ 时优先使用 Mojang 提供的 Component 字段 + Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsInterrupted Task.Progress = JavaLoader.Progress Thread.Sleep(10) Loop Finally - JavaLoader.Abort() '确保取消时中止 Java 下载 + JavaLoader.Interrupt() '确保取消时中止 Java 下载 End Try '检查下载结果 If JavaSearchLoader.State <> LoadState.Loading Then JavaSearchLoader.State = LoadState.Waiting '2872# - McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent) - If Task.IsAborted Then Return + McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McInstanceSelected) + If Task.IsInterrupted Then Return If McLaunchJavaSelected IsNot Nothing Then McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString) Else - Hint("没有可用的 Java，已取消启动！", HintType.Critical) + Hint("没有可用的 Java，已取消启动！", HintType.Red) Throw New Exception("$$") End If @@ -1285,447 +1331,456 @@ Retry: #End Region #Region "启动参数" - Private McLaunchArgument As String - ''' - ''' 释放 Java Wrapper 并返回完整文件路径。 - ''' - Public Function ExtractJavaWrapper() As String - Dim WrapperPath As String = PathPure & "JavaWrapper.jar" - Log("[Java] 选定的 Java Wrapper 路径：" & WrapperPath) - SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突 - Try - WriteFile(WrapperPath, GetResources("JavaWrapper")) - Catch ex As Exception - If File.Exists(WrapperPath) Then - '因为未知原因 Java Wrapper 可能变为只读文件（#4243） - Log(ex, "Java Wrapper 文件释放失败，但文件已存在，将在删除后尝试重新生成", LogLevel.Developer) - Try - File.Delete(WrapperPath) - WriteFile(WrapperPath, GetResources("JavaWrapper")) - Catch ex2 As Exception - Log(ex2, "Java Wrapper 文件重新释放失败，将尝试更换文件名重新生成", LogLevel.Developer) - WrapperPath = PathPure & "JavaWrapper2.jar" - Try - WriteFile(WrapperPath, GetResources("JavaWrapper")) - Catch ex3 As Exception - Throw New FileNotFoundException("释放 Java Wrapper 最终尝试失败", ex3) - End Try - End Try - Else - Throw New FileNotFoundException("释放 Java Wrapper 失败", ex) - End If - End Try - End SyncLock - Return WrapperPath - End Function - Private ExtractJavaWrapperLock As New Object + '主方法 + Private Sub McLaunchArgumentMain(Loader As LoaderTask(Of String, Integer)) + '获取基础参数 + Dim Arguments As New List(Of String) + McLaunchLog("参数获取开始") + Arguments.AddRange(McLaunchArgumentsJVM()) 'JVM 参数 + Arguments.Add(McInstanceSelected.JsonObject("mainClass")) 'mainClass + Arguments.AddRange(McLaunchArgumentsGame()) '游戏参数 + '替换 + McLaunchLog("=================== 启动参数开始 ===================") + Dim Replacements = McLaunchArgumentsReplace(Arguments).ToList + Dim Argument As String = "" + For Each Arg In Arguments + '应用替换标记 + For Each Replacement In Replacements + Arg = Arg.Replace(Replacement.Key, Replacement.Value) + Next + '为带空格的参数添加双引号 + If Arg.Contains(" ") AndAlso Not Arg.StartsWithF("""") AndAlso Not Arg.EndsWithF("""") Then + Arg = $"""{Arg.Replace("""", "\""")}""" '转义在原本参数中间的双引号 + End If + '输出 + McLaunchLog(Arg) + Argument &= Arg & " " + Next + McLaunchLog("=================== 启动参数结束 ===================") + '输出 + McLaunchArgument = Argument.TrimEnd + End Sub - '主方法，合并 Jvm、Game、Replace 三部分的参数数据 - Private Sub McLaunchArgumentMain(Loader As LoaderTask(Of String, List(Of McLibToken))) - McLaunchLog("开始获取 Minecraft 启动参数") - '获取基准字符串与参数信息 - Dim Arguments As String - If McVersionCurrent.JsonObject("arguments") IsNot Nothing AndAlso McVersionCurrent.JsonObject("arguments")("jvm") IsNot Nothing Then - McLaunchLog("获取新版 JVM 参数") - Arguments = McLaunchArgumentsJvmNew(McVersionCurrent) - McLaunchLog("新版 JVM 参数获取成功：") - McLaunchLog(Arguments) + 'JVM 部分 + Private Function McLaunchArgumentsJVM() As List(Of String) + Dim Args As New List(Of String) + + 'Minecraft 参数 + If McInstanceSelected.JsonObject("arguments") IsNot Nothing AndAlso McInstanceSelected.JsonObject("arguments")("jvm") IsNot Nothing Then + '新版 MC：从版本 JSON 获取参数 + Dim CurrentInstance As McInstance = McInstanceSelected +NextInstance: + McLaunchLog($"新版 JVM 参数：从版本 JSON 获取（{CurrentInstance.Name}）") + If CurrentInstance.JsonObject("arguments") IsNot Nothing AndAlso CurrentInstance.JsonObject("arguments")("jvm") IsNot Nothing Then + For Each SubJson As JToken In CurrentInstance.JsonObject("arguments")("jvm") + Select Case SubJson.Type + Case JTokenType.String + Args.Add(SubJson.ToString.Trim) + Case JTokenType.Object + Dim Argument As JObject = CType(SubJson, JObject) + If Argument.ContainsKey("rules") AndAlso Not McJsonRuleCheck(Argument("rules")) Then Continue For '不满足准则 + If Not Argument.ContainsKey("value") Then Continue For '没有 value 字段 + If Argument("value").Type = JTokenType.String Then + Args.Add(Argument("value").ToString.Trim) + Else + For Each value As JToken In Argument("value") + Args.Add(value.ToString.Trim) + Next + End If + End Select + Next + End If + If CurrentInstance.InheritName <> "" Then + CurrentInstance = New McInstance(CurrentInstance.InheritName) + GoTo NextInstance + End If + '1.17.1 中有个 "-Dos.name=Windows 10"，不立即加双引号会导致 10 被隔开 + Args = Args.Select(Function(a) If(a.Contains(" ") AndAlso Not a.StartsWithF("""") AndAlso Not a.EndsWithF(""""), $"""{a.Replace("""", "\""")}""", a)).ToList Else - McLaunchLog("获取旧版 JVM 参数") - Arguments = McLaunchArgumentsJvmOld(McVersionCurrent) - McLaunchLog("旧版 JVM 参数获取成功：") - McLaunchLog(Arguments) + '旧版 MC：直接添加参数 + McLaunchLog($"旧版 JVM 参数") + Args.Add("-XX:HeapDumpPath=MojangTricksIntelDriversForPerformance_javaw.exe_minecraft.exe.heapdump") + Args.Add("-Djava.library.path=${natives_directory}") + Args.Add("-cp") : Args.Add("${classpath}") End If - If Not String.IsNullOrEmpty(McVersionCurrent.JsonObject("minecraftArguments")) Then '有的版本是空字符串 - McLaunchLog("获取旧版 Game 参数") - Arguments += " " & McLaunchArgumentsGameOld(McVersionCurrent) - McLaunchLog("旧版 Game 参数获取成功") + + '设置里自定义的参数 + Dim CustomArg As String = Settings.Get("VersionAdvanceJvm", Instance:=McInstanceSelected) + If CustomArg = "" Then CustomArg = Settings.Get("LaunchAdvanceJvm") + + '重新分割字符串并去重 + Args = DeduplicateJavaArguments(SplitJavaArguments(Args.Join(" "c).Replace("McEmu= ", "McEmu=") & " " & CustomArg).ToList, True) + + '统一通行证 + If McLoginLoader.Output.Type = "Nide" Then + Args.Add("-javaagent:""${pure_directory}\nide8auth.jar""=""" & Settings.Get("VersionServerNide", Instance:=McInstanceSelected) & """") End If - If McVersionCurrent.JsonObject("arguments") IsNot Nothing AndAlso McVersionCurrent.JsonObject("arguments")("game") IsNot Nothing Then - McLaunchLog("获取新版 Game 参数") - Arguments += " " & McLaunchArgumentsGameNew(McVersionCurrent) - McLaunchLog("新版 Game 参数获取成功") + 'Authlib-Injector + If McLoginLoader.Output.Type = "Auth" Then + If McLaunchJavaSelected.MajorVersion >= 6 Then Args.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#） + Dim Server As String = Settings.Get("VersionServerAuthServer", Instance:=McInstanceSelected) + Try + McLaunchLog($"开始 Authlib Injector Prefetch") + Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8) + Args.Add("-javaagent:""${pure_directory}\authlib-injector.jar""=""" & Server & """") + Args.Add("-Dauthlibinjector.side=client") + Args.Add("-Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response))) + Catch ex As Exception + Throw New Exception("无法连接到第三方登录服务器（" & If(Server, Nothing) & "）", ex) + End Try End If - '编码参数（#4700、#5892、#5909） - If McLaunchJavaSelected.VersionCode > 8 Then - If Not Arguments.Contains("-Dstdout.encoding=") Then Arguments = "-Dstdout.encoding=UTF-8 " & Arguments - If Not Arguments.Contains("-Dstderr.encoding=") Then Arguments = "-Dstderr.encoding=UTF-8 " & Arguments + + 'JLW + Dim UseJLW As Boolean = + Not Settings.Get("LaunchAdvanceDisableJLW") AndAlso Not Settings.Get("VersionAdvanceDisableJLW", McInstanceSelected) AndAlso + McLaunchJavaSelected.MajorVersion <= 18 + If UseJLW Then + If McLaunchJavaSelected.MajorVersion >= 9 Then + Args.Add("--add-exports") : Args.Add("cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED") + End If + Args.Add("-Doolloo.jlw.tmpdir=${pure_directory}") '这里需要不以 \ 结尾 End If - If McLaunchJavaSelected.VersionCode >= 18 Then - If Not Arguments.Contains("-Dfile.encoding=") Then Arguments = "-Dfile.encoding=COMPAT " & Arguments + McLaunchLog("使用 JLW：" & UseJLW) + + 'LUA + Dim UseLUA As Boolean = + Not Settings.Get("LaunchAdvanceDisableLUA") AndAlso Not Settings.Get("VersionAdvanceDisableLUA", McInstanceSelected) AndAlso + McLaunchJavaSelected.MajorVersion >= 25 AndAlso McInstanceSelected.Version.Drop >= 261 + If UseLUA Then Args.Add($"-javaagent:""{ExtractPatch("LUA")}""") + McLaunchLog("使用 LUA：" & UseLUA) + +#Region "内存管理" + + McLaunchLog("当前剩余内存：" & Math.Round(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024 / 1024 * 10) / 10 & "G") + Dim TargetRam As Integer = Math.Floor(PageInstanceSetup.GetRam(McInstanceSelected, Not McLaunchJavaSelected.Is64Bit) * 1024) + Args.Add("-Xmx" & TargetRam & "m") + + '获取设置的管理方式 + '0：在 Java 21+ 使用分代 ZGC，20~15 使用非分代的 ZGC，14- 使用 G1GC + '1：在 Java 21+ 使用分代 ZGC，20- 使用 G1GC + '2：仅 G1GC + '3：不指定，玩家自定义 + Dim SetupType As Integer = Settings.Get("LaunchAdvanceGC") + If McInstanceSelected IsNot Nothing AndAlso Settings.Get("VersionAdvanceGC", McInstanceSelected) > 0 Then SetupType = Settings.Get("VersionAdvanceGC", McInstanceSelected) - 1 '去掉默认 + If SetupType <> 3 Then + '确定是使用 G1GC 还是 ZGC + Dim UseG1GC As Boolean = False + If (SetupType = 0 AndAlso McLaunchJavaSelected.MajorVersion < 15) OrElse + (SetupType = 1 AndAlso McLaunchJavaSelected.MajorVersion < 21) OrElse + (SetupType = 2 OrElse SetupType = 4) Then UseG1GC = True '检查 Java 版本，ZGC 在 Java 15+ 可用，分代 ZGC 在 Java 21+ 可用 + If Is32BitSystem OrElse Environment.OSVersion.Version.Major < 10 OrElse Environment.OSVersion.Version.Build < 17763 Then UseG1GC = True '检查系统兼容性，ZGC 需要 Windows 10 1809+ + McLaunchLog($"GC 设置：{SetupType}，选取 {If(UseG1GC, "G1GC", "ZGC")}，Java 版本：{McLaunchJavaSelected.MajorVersion}") + '移除已有的 GC 参数 + Args = Args.Where(Function(a) Not RegexCheck(a, + "( )*-XX:[+-]?(Use\w+GC|ZGenerational|UseCompactObjectHeaders|G1\w+Percent|G1\w+Size|(Max|Min)(GCPauseMillis|HeapFreeRatio))")).ToList + '添加 GC 参数 + Args.Add("-XX:+UnlockExperimentalVMOptions") + If McLaunchJavaSelected.MajorVersion >= 24 AndAlso McLaunchJavaSelected.Is64Bit Then Args.Add("-XX:+UseCompactObjectHeaders") + If UseG1GC AndAlso SetupType = 4 Then + '优化的 G1GC + Args.Add("-XX:+UseG1GC") + Args.Add("-XX:G1NewSizePercent=20") + Args.Add("-XX:G1ReservePercent=20") + Args.Add("-XX:G1HeapRegionSize=32M") + Args.Add("-XX:MaxGCPauseMillis=50") + If Not ModeDebug Then Args.Add("-XX:+PerfDisableSharedMem") + If McLaunchJavaSelected.MajorVersion <= 7 Then Args.Add("-XX:MaxPermSize=512m") '#8286 + If McLaunchJavaSelected.MajorVersion = 8 Then Args.Add("-XX:+ParallelRefProcEnabled") + If McLaunchJavaSelected.MajorVersion >= 12 Then Args.Add("-XX:MinHeapFreeRatio=25") '需要比 G1NewSizePercent 大一点 + If McLaunchJavaSelected.MajorVersion >= 12 Then Args.Add("-XX:MaxHeapFreeRatio=40") '需要比 MinHeapFreeRatio 大一些 + ElseIf UseG1GC Then + 'Mojang G1GC + Args.Add("-XX:+UseG1GC") + Args.Add("-XX:G1NewSizePercent=20") + Args.Add("-XX:G1ReservePercent=20") + Args.Add("-XX:G1HeapRegionSize=32M") + Args.Add("-XX:MaxGCPauseMillis=50") + If McLaunchJavaSelected.MajorVersion <= 7 Then Args.Add("-XX:MaxPermSize=512m") '#8286 + Else + 'ZGC + Args.Add("-XX:+UseZGC") + If McLaunchJavaSelected.MajorVersion = 21 OrElse McLaunchJavaSelected.MajorVersion = 22 Then Args.Add("-XX:+ZGenerational") 'Java 23 起默认启用分代 ZGC，不需要再添加参数 + End If End If - '替换参数 - Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader) - If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then - '若自定义信息为空，则去掉该部分 - Arguments = Arguments.Replace(" --versionType ${version_type}", "") - ReplaceArguments("${version_type}") = """""" + + Args.Remove("-XX:MaxDirectMemorySize=256M") '#3511 的清理 + +#End Region + + 'Log4j 漏洞防御参数 + Args.Add("-Dlog4j2.formatMsgNoLookups=true") + + '编码（#4700、#5892、#5909） + If McLaunchJavaSelected.MajorVersion > 8 AndAlso Not Args.Any(Function(a) a.StartsWithF("-Dstdout.encoding=")) Then Args.Add("-Dstdout.encoding=UTF-8") + If McLaunchJavaSelected.MajorVersion > 8 AndAlso Not Args.Any(Function(a) a.StartsWithF("-Dstderr.encoding=")) Then Args.Add("-Dstderr.encoding=UTF-8") + If McLaunchJavaSelected.MajorVersion >= 18 AndAlso Not Args.Any(Function(a) a.StartsWithF("-Dfile.encoding=")) Then Args.Add("-Dfile.encoding=COMPAT") 'Dfile.encoding 需要放在 Dstdout.encoding 后面（#6934） + + '为 JLW 添加 -jar，它必须放在最后 + If UseJLW Then + Args.Add("-jar") : Args.Add(ExtractPatch("JavaWrapper")) End If - For Each entry As KeyValuePair(Of String, String) In ReplaceArguments - Arguments = Arguments.Replace(entry.Key, If(entry.Value.Contains(" ") OrElse entry.Value.Contains(":\"), """" & entry.Value & """", entry.Value)) - Next - 'MJSB - Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""") + + '再次去重并输出 + Return DeduplicateJavaArguments(Args, True) + End Function + '游戏参数部分 + Private Function McLaunchArgumentsGame() As List(Of String) + Dim Arg As String = "" + + 'Minecraft 参数 + '旧版 MC：直接添加参数 + If McInstanceSelected.JsonObject("minecraftArguments")?.ToString.Any Then + Dim BasicString As String = McInstanceSelected.JsonObject("minecraftArguments").ToString + McLaunchLog($"旧版游戏参数：" & BasicString) + BasicString += " --height ${resolution_height} --width ${resolution_width}" '总是添加宽高选项，之后去重的时候会覆盖 MC 自带的 + Arg &= " " & BasicString + End If + '新版 MC：从版本 JSON 获取参数 + If McInstanceSelected.JsonObject("arguments") IsNot Nothing AndAlso McInstanceSelected.JsonObject("arguments")("game") IsNot Nothing Then + Dim CurrentInstance As McInstance = McInstanceSelected + Dim AppendArg = Sub(a As String) Arg &= " " & If(a.Contains(" ") AndAlso Not a.StartsWithF("""") AndAlso Not a.EndsWithF(""""), $"""{a.Replace("""", "\""")}""", a) +NextInstance: + McLaunchLog($"新版游戏参数：从版本 JSON 获取（{CurrentInstance.Name}）") + If CurrentInstance.JsonObject("arguments") IsNot Nothing AndAlso CurrentInstance.JsonObject("arguments")("game") IsNot Nothing Then + For Each SubJson As JToken In CurrentInstance.JsonObject("arguments")("game") + Select Case SubJson.Type + Case JTokenType.String + AppendArg(SubJson.ToString) + Case JTokenType.Object + Dim Argument As JObject = CType(SubJson, JObject) + If Argument.ContainsKey("rules") AndAlso Not McJsonRuleCheck(Argument("rules")) Then Continue For '不满足准则 + If Not Argument.ContainsKey("value") Then Continue For '没有 value 字段 + If Argument("value").Type = JTokenType.String Then + AppendArg(Argument("value").ToString) + Else + For Each value As JToken In Argument("value") + AppendArg(value.ToString) + Next + End If + End Select + Next + End If + If CurrentInstance.InheritName <> "" Then + CurrentInstance = New McInstance(CurrentInstance.InheritName) + GoTo NextInstance + End If + End If + + '设置里自定义的参数 + Dim CustomArg As String = Settings.Get("VersionAdvanceGame", Instance:=McInstanceSelected) + If CustomArg = "" Then CustomArg = Settings.Get("LaunchAdvanceGame") + Arg &= " " & CustomArg + + '把 OptiFineForgeTweaker 放在参数的末尾 + If (McInstanceSelected.Version.HasForge OrElse McInstanceSelected.Version.HasLiteLoader) AndAlso McInstanceSelected.Version.HasOptiFine Then + If Arg.Contains("--tweakClass optifine.OptiFineForgeTweaker") Then + McLaunchLog("发现正确的 OptiFineForge TweakClass，目前的游戏参数：" & Arg) + Arg = Arg.Replace(" --tweakClass optifine.OptiFineForgeTweaker", "") & " --tweakClass optifine.OptiFineForgeTweaker" + End If + If Arg.Contains("--tweakClass optifine.OptiFineTweaker") Then + McLaunchLog("发现错误的 OptiFineForge TweakClass，目前的游戏参数：" & Arg) + Arg = Arg.Replace(" --tweakClass optifine.OptiFineTweaker", "") & " --tweakClass optifine.OptiFineForgeTweaker" + Try + WriteFile(McInstanceSelected.PathVersion & McInstanceSelected.Name & ".json", ReadFile(McInstanceSelected.PathVersion & McInstanceSelected.Name & ".json").Replace("optifine.OptiFineTweaker", "optifine.OptiFineForgeTweaker")) + Catch ex As Exception + Log(ex, "替换 OptiFineForge TweakClass 失败") + End Try + End If + End If + + '重新分割字符串并去重 + Dim Args As List(Of String) = DeduplicateJavaArguments(SplitJavaArguments(Arg).ToList, False) + + '额外传入的参数 + Args.AddRange(CurrentLaunchOptions.ExtraGameArgs) + '全屏 - 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(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp) - If Server.Length > 0 Then - If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then + If Settings.Get("LaunchArgumentWindowType") = 0 Then Args.Add("--fullscreen") + + '自动进入服务器 + Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Settings.Get("VersionServerEnter", McInstanceSelected), CurrentLaunchOptions.ServerIp) + If Server.Any Then + If McInstanceSelected.ReleaseTime > New Date(2023, 4, 4) Then 'QuickPlay - Arguments += $" --quickPlayMultiplayer ""{Server}""" + Args.Add($"--quickPlayMultiplayer") : Args.Add(Server) Else '老版本 If Server.Contains(":") Then '包含端口号 - Arguments += " --server " & Server.Split(":")(0) & " --port " & Server.Split(":")(1) + Args.Add("--server") : Args.Add(Server.Split(":")(0)) + Args.Add("--port") : Args.Add(Server.Split(":")(1)) Else '不包含端口号 - Arguments += " --server " & Server & " --port 25565" + Args.Add("--server") : Args.Add(Server) + Args.Add("--port") : Args.Add("25565") End If - If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Critical) + If McInstanceSelected.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Red) End If End If - '自定义 - Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent) - Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame) - '输出 - McLaunchLog("Minecraft 启动参数：") - McLaunchLog(Arguments) - McLaunchArgument = Arguments - End Sub - 'Jvm 部分（第一段） - Private Function McLaunchArgumentsJvmOld(Version As McVersion) As String - '存储以空格为间隔的启动参数列表 - Dim DataList As New List(Of String) - - '输出固定参数 - DataList.Add("-XX:HeapDumpPath=MojangTricksIntelDriversForPerformance_javaw.exe_minecraft.exe.heapdump") - Dim ArgumentJvm As String = Setup.Get("VersionAdvanceJvm", Version:=McVersionCurrent) - If ArgumentJvm = "" Then ArgumentJvm = Setup.Get("LaunchAdvanceJvm") - If Not ArgumentJvm.Contains("-Dlog4j2.formatMsgNoLookups=true") Then ArgumentJvm += " -Dlog4j2.formatMsgNoLookups=true" - ArgumentJvm = ArgumentJvm.Replace(" -XX:MaxDirectMemorySize=256M", "") '#3511 的清理 - DataList.Insert(0, ArgumentJvm) '可变 JVM 参数 - DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024 * 0.15) & "m") - DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & "m") - DataList.Add("""-Djava.library.path=" & GetNativesFolder() & """") - DataList.Add("-cp ${classpath}") '把支持库添加进启动参数表 - - '统一通行证 - If McLoginLoader.Output.Type = "Nide" Then - DataList.Insert(0, "-Dnide8auth.client=true -javaagent:""" & PathAppdata & "nide8auth.jar""=" & Setup.Get("VersionServerNide", Version:=McVersionCurrent)) - End If - 'Authlib-Injector - If McLoginLoader.Output.Type = "Auth" Then - If (McLaunchJavaSelected.VersionCode >= 6) Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") - Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy, - "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 - Setup.Get("VersionServerAuthServer", McVersionCurrent)) - Try - Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8) - DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server & - " -Dauthlibinjector.side=client" & - " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response))) - Catch ex As Exception - Throw New Exception("无法连接到第三方登录服务器（" & If(Server, Nothing) & "）", ex) - End Try - End If - - '添加 Java Wrapper 作为主 Jar - If Not Setup.Get("LaunchAdvanceDisableJLW") AndAlso Not Setup.Get("VersionAdvanceDisableJLW", McVersionCurrent) Then - If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED") - DataList.Add("-Doolloo.jlw.tmpdir=""" & PathPure.TrimEnd("\") & """") - DataList.Add("-jar """ & ExtractJavaWrapper() & """") - End If - - '添加 MainClass - If Version.JsonObject("mainClass") Is Nothing Then - Throw New Exception("版本 json 中没有 mainClass 项！") - Else - DataList.Add(Version.JsonObject("mainClass")) - End If - - Return Join(DataList, " ") + '再次去重并输出 + Return DeduplicateJavaArguments(Args, False) End Function - Private Function McLaunchArgumentsJvmNew(Version As McVersion) As String - Dim DataList As New List(Of String) - - '获取 Json 中的 DataList - Dim CurrentVersion As McVersion = Version -NextVersion: - If CurrentVersion.JsonObject("arguments") IsNot Nothing AndAlso CurrentVersion.JsonObject("arguments")("jvm") IsNot Nothing Then - For Each SubJson As JToken In CurrentVersion.JsonObject("arguments")("jvm") - If SubJson.Type = JTokenType.String Then - '字符串类型 - DataList.Add(SubJson.ToString) - Else - '非字符串类型 - If McJsonRuleCheck(SubJson("rules")) Then - '满足准则 - If SubJson("value").Type = JTokenType.String Then - DataList.Add(SubJson("value").ToString) - Else - For Each value As JToken In SubJson("value") - DataList.Add(value.ToString) - Next - End If - End If - End If - Next - End If - If CurrentVersion.InheritVersion <> "" Then - CurrentVersion = New McVersion(CurrentVersion.InheritVersion) - GoTo NextVersion - End If - - '内存、Log4j 防御参数等 - SecretLaunchJvmArgs(DataList) - - '统一通行证 - If McLoginLoader.Output.Type = "Nide" Then - DataList.Insert(0, "-javaagent:""" & PathAppdata & "nide8auth.jar""=" & Setup.Get("VersionServerNide", Version:=McVersionCurrent)) - End If - 'Authlib-Injector - If McLoginLoader.Output.Type = "Auth" Then - If (McLaunchJavaSelected.VersionCode >= 6) Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") - Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy, - "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 - Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)) - Try - Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8) - DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server & - " -Dauthlibinjector.side=client" & - " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response))) - Catch ex As Exception - Throw New Exception("无法连接到第三方登录服务器（" & If(Server, Nothing) & "）", ex) - End Try - End If - - '添加 Java Wrapper 作为主 Jar - If Not Setup.Get("LaunchAdvanceDisableJLW") AndAlso Not Setup.Get("VersionAdvanceDisableJLW", McVersionCurrent) Then - If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED") - DataList.Add("-Doolloo.jlw.tmpdir=""" & PathPure.TrimEnd("\") & """") - DataList.Add("-jar """ & ExtractJavaWrapper() & """") - End If - - '将 "-XXX" 与后面 "XXX" 合并到一起 - '如果不合并，会导致 Forge 1.17 启动无效，它有两个 --add-exports，进一步导致其中一个在后面被去重 - Dim DeDuplicateDataList As New List(Of String) - For i = 0 To DataList.Count - 1 - Dim CurrentEntry As String = DataList(i) - If DataList(i).StartsWithF("-") Then - Do While i < DataList.Count - 1 - If DataList(i + 1).StartsWithF("-") Then - Exit Do - Else - i += 1 - CurrentEntry += " " + DataList(i) - End If - Loop - End If - DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu=")) - Next - - '#3511 的清理 - DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M") - - '去重 - Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ") - - '添加 MainClass - If Version.JsonObject("mainClass") Is Nothing Then - Throw New Exception("版本 json 中没有 mainClass 项！") - Else - Result += " " & Version.JsonObject("mainClass").ToString - End If - - Return Result - End Function - - 'Game 部分（第二段） - Private Function McLaunchArgumentsGameOld(Version As McVersion) As String - Dim DataList As New List(Of String) - - '本地化 Minecraft 启动信息 - Dim BasicString As String = Version.JsonObject("minecraftArguments").ToString - If Not BasicString.Contains("--height") Then BasicString += " --height ${resolution_height} --width ${resolution_width}" - DataList.Add(BasicString) - - Dim Result As String = Join(DataList, " ") - - '特别改变 OptiFineTweaker - If (Version.Version.HasForge OrElse Version.Version.HasLiteLoader) AndAlso Version.Version.HasOptiFine Then - '把 OptiFineForgeTweaker 放在最后，不然会导致崩溃！ - If Result.Contains("--tweakClass optifine.OptiFineForgeTweaker") Then - Log("[Launch] 发现正确的 OptiFineForge TweakClass，目前参数：" & Result) - Result = Result.Replace(" --tweakClass optifine.OptiFineForgeTweaker", "").Replace("--tweakClass optifine.OptiFineForgeTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker" - End If - If Result.Contains("--tweakClass optifine.OptiFineTweaker") Then - Log("[Launch] 发现错误的 OptiFineForge TweakClass，目前参数：" & Result) - Result = Result.Replace(" --tweakClass optifine.OptiFineTweaker", "").Replace("--tweakClass optifine.OptiFineTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker" - Try - WriteFile(Version.Path & Version.Name & ".json", ReadFile(Version.Path & Version.Name & ".json").Replace("optifine.OptiFineTweaker", "optifine.OptiFineForgeTweaker")) - Catch ex As Exception - Log(ex, "替换 OptiFineForge TweakClass 失败") - End Try - End If - End If - - Return Result - End Function - Private Function McLaunchArgumentsGameNew(Version As McVersion) As String - Dim DataList As New List(Of String) - - '获取 Json 中的 DataList - Dim CurrentVersion As McVersion = Version -NextVersion: - If CurrentVersion.JsonObject("arguments") IsNot Nothing AndAlso CurrentVersion.JsonObject("arguments")("game") IsNot Nothing Then - For Each SubJson As JToken In CurrentVersion.JsonObject("arguments")("game") - If SubJson.Type = JTokenType.String Then - '字符串类型 - DataList.Add(SubJson.ToString) - Else - '非字符串类型 - If McJsonRuleCheck(SubJson("rules")) Then - '满足准则 - If SubJson("value").Type = JTokenType.String Then - DataList.Add(SubJson("value").ToString) - Else - For Each value As JToken In SubJson("value") - DataList.Add(value.ToString) - Next - End If - End If - End If - Next - End If - If CurrentVersion.InheritVersion <> "" Then - CurrentVersion = New McVersion(CurrentVersion.InheritVersion) - GoTo NextVersion - End If - - '将 "-XXX" 与后面 "XXX" 合并到一起 - '如果不进行合并 Impact 会启动无效，它有两个 --tweakclass - Dim DeDuplicateDataList As New List(Of String) - For i = 0 To DataList.Count - 1 - Dim CurrentEntry As String = DataList(i) - If DataList(i).StartsWithF("-") Then - Do While i < DataList.Count - 1 - If DataList(i + 1).StartsWithF("-") Then - Exit Do - Else - i += 1 - CurrentEntry += " " + DataList(i) - End If - Loop - End If - DeDuplicateDataList.Add(CurrentEntry) - Next - '去重 - McLaunchArgumentsGameNew = Join(DeDuplicateDataList.Distinct.ToList, " ") - - '特别改变 OptiFineTweaker - If (Version.Version.HasForge OrElse Version.Version.HasLiteLoader) AndAlso Version.Version.HasOptiFine Then - '把 OptiFineForgeTweaker 放在最后，不然会导致崩溃！ - If McLaunchArgumentsGameNew.Contains("--tweakClass optifine.OptiFineForgeTweaker") Then - Log("[Launch] 发现正确的 OptiFineForge TweakClass，目前参数：" & McLaunchArgumentsGameNew) - McLaunchArgumentsGameNew = McLaunchArgumentsGameNew.Replace(" --tweakClass optifine.OptiFineForgeTweaker", "").Replace("--tweakClass optifine.OptiFineForgeTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker" - End If - If McLaunchArgumentsGameNew.Contains("--tweakClass optifine.OptiFineTweaker") Then - Log("[Launch] 发现错误的 OptiFineForge TweakClass，目前参数：" & McLaunchArgumentsGameNew) - McLaunchArgumentsGameNew = McLaunchArgumentsGameNew.Replace(" --tweakClass optifine.OptiFineTweaker", "").Replace("--tweakClass optifine.OptiFineTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker" - Try - WriteFile(Version.Path & Version.Name & ".json", ReadFile(Version.Path & Version.Name & ".json").Replace("optifine.OptiFineTweaker", "optifine.OptiFineForgeTweaker")) - Catch ex As Exception - Log(ex, "替换 OptiFineForge TweakClass 失败") - End Try - End If - End If - End Function - - '替换 Arguments - Private Function McLaunchArgumentsReplace(Version As McVersion, ByRef Loader As LoaderTask(Of String, List(Of McLibToken))) As Dictionary(Of String, String) - Dim GameArguments As New Dictionary(Of String, String) - + '获取替换标记 + Private Iterator Function McLaunchArgumentsReplace(Arguments As List(Of String)) As IEnumerable(Of (Key As String, Value As String)) '基础参数 - GameArguments.Add("${classpath_separator}", ";") - GameArguments.Add("${natives_directory}", ShortenPath(GetNativesFolder())) - GameArguments.Add("${library_directory}", ShortenPath(PathMcFolder & "libraries")) - GameArguments.Add("${libraries_directory}", ShortenPath(PathMcFolder & "libraries")) - GameArguments.Add("${launcher_name}", "PCL") - GameArguments.Add("${launcher_version}", VersionCode) - GameArguments.Add("${version_name}", Version.Name) - Dim ArgumentInfo As String = Setup.Get("VersionArgumentInfo", Version:=McVersionCurrent) - GameArguments.Add("${version_type}", If(ArgumentInfo = "", Setup.Get("LaunchArgumentInfo"), ArgumentInfo)) - GameArguments.Add("${game_directory}", ShortenPath(Left(McVersionCurrent.PathIndie, McVersionCurrent.PathIndie.Count - 1))) - GameArguments.Add("${assets_root}", ShortenPath(PathMcFolder & "assets")) - GameArguments.Add("${user_properties}", "{}") - GameArguments.Add("${auth_player_name}", McLoginLoader.Output.Name) - GameArguments.Add("${auth_uuid}", McLoginLoader.Output.Uuid) - GameArguments.Add("${auth_access_token}", McLoginLoader.Output.AccessToken) - GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken) - GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken) - GameArguments.Add("${user_type}", "msa") '#1221 + Yield ("${classpath_separator}", ";") + Yield ("${natives_directory}", ShortenPath(GetNativesFolder())) + Yield ("${library_directory}", ShortenPath(McFolderSelected & "libraries")) + Yield ("${libraries_directory}", ShortenPath(McFolderSelected & "libraries")) + Yield ("${pure_directory}", PathPure.TrimEnd("\"c)) '由 PCL 添加，这会允许在分割参数并去重后再替换路径，防止路径中的特殊字符影响参数分割和去重 + Yield ("${launcher_name}", "PCL") + Yield ("${launcher_version}", VersionCode) + Yield ("${version_name}", McInstanceSelected.Name) + Yield ("${game_directory}", ShortenPath(Left(McInstanceSelected.PathIndie, McInstanceSelected.PathIndie.Count - 1))) + Yield ("${assets_root}", ShortenPath(McFolderSelected & "assets")) + Yield ("${user_properties}", "{}") + Yield ("${auth_player_name}", McLoginLoader.Output.Name) + Yield ("${auth_uuid}", McLoginLoader.Output.Uuid) + Yield ("${auth_access_token}", McLoginLoader.Output.AccessToken) + Yield ("${access_token}", McLoginLoader.Output.AccessToken) + Yield ("${auth_session}", McLoginLoader.Output.AccessToken) + Yield ("${user_type}", "msa") '#1221 + Yield ("${primary_jar}", ShortenPath(McInstanceSelected.PathVersion & McInstanceSelected.Name & ".jar")) '#6942 + Yield ("${game_assets}", ShortenPath(McFolderSelected & "assets\virtual\legacy")) '1.5.2 的 pre-1.6 资源索引应与 legacy 合并 + Yield ("${assets_index_name}", McAssetsGetIndexName(McInstanceSelected)) - '窗口尺寸参数 - Dim GameSize As Size - Select Case Setup.Get("LaunchArgumentWindowType") + '自定义信息 + Dim ArgumentInfo As String + ArgumentInfo = Settings.Get("VersionArgumentInfo", Instance:=McInstanceSelected) + If ArgumentInfo = "" Then ArgumentInfo = Settings.Get("LaunchArgumentInfo") + If ArgumentInfo = "" Then '若自定义信息为空，则必须从参数中去掉该部分，不然 MC 会显示 ${version_type} 或者一个空字符串 + If Arguments.Contains("--versionType") Then + Dim Index As Integer = Arguments.IndexOf("--versionType") + Arguments.RemoveAt(Index) + If Index < Arguments.Count Then Arguments.RemoveAt(Index) + End If + Yield ("${version_type}", """""") + Else + Yield ("${version_type}", ArgumentReplace(ArgumentInfo)) + End If + + '窗口尺寸 + Dim TargetSize As Size + Select Case Settings.Get("LaunchArgumentWindowType") Case 2 '与启动器尺寸一致 Dim Result As Size RunInUiWait(Sub() Result = New Size(GetPixelSize(FrmMain.PanForm.ActualWidth), GetPixelSize(FrmMain.PanForm.ActualHeight))) - GameSize = Result - GameSize.Height -= 29.5 * DPI / 96 '标题栏高度 + TargetSize = Result + TargetSize.Height -= 29.5 * DPI / 96 '标题栏高度 Case 3 '自定义 - GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth")), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight"))) + TargetSize = New Size(Math.Max(100, Settings.Get("LaunchArgumentWindowWidth")), Math.Max(100, Settings.Get("LaunchArgumentWindowHeight"))) Case Else - GameSize = New Size(854, 480) + TargetSize = New Size(854, 480) End Select - If McVersionCurrent.Version.McCodeMain <= 12 AndAlso - McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso - Not McVersionCurrent.Version.HasOptiFine AndAlso Not McVersionCurrent.Version.HasForge Then - '修复 #3463：1.12.2-，JRE 8u200~321 下窗口大小为设置大小的 DPI% 倍 + If McInstanceSelected.Version.Vanilla.Major <= 12 AndAlso + McLaunchJavaSelected.MajorVersion <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso + Not McInstanceSelected.Version.HasOptiFine AndAlso Not McInstanceSelected.Version.HasForge Then '修复 1.12.2- 下 JRE 8u200~321 下窗口大小为设置大小的 DPI% 倍（#3463） McLaunchLog($"已应用窗口大小过大修复（{McLaunchJavaSelected.Version.Revision}）") - GameSize.Width /= DPI / 96 - GameSize.Height /= DPI / 96 + TargetSize.Width /= DPI / 96 + TargetSize.Height /= DPI / 96 End If - GameArguments.Add("${resolution_width}", Math.Round(GameSize.Width)) - GameArguments.Add("${resolution_height}", Math.Round(GameSize.Height)) + Yield ("${resolution_width}", Math.Round(TargetSize.Width)) + Yield ("${resolution_height}", Math.Round(TargetSize.Height)) - 'Assets 相关参数 - GameArguments.Add("${game_assets}", ShortenPath(PathMcFolder & "assets\virtual\legacy")) '1.5.2 的 pre-1.6 资源索引应与 legacy 合并 - GameArguments.Add("${assets_index_name}", McAssetsGetIndexName(Version)) - - '支持库参数 - Dim LibList As List(Of McLibToken) = McLibListGet(Version, True) - Loader.Output = LibList - Dim CpStrings As New List(Of String) + '支持库 + Dim Cps As New List(Of String) Dim OptiFineCp As String = Nothing - For Each Library As McLibToken In LibList + For Each Library As McLibToken In McLibListGet(McInstanceSelected, True) If Library.IsNatives Then Continue For If Library.Name IsNot Nothing AndAlso Library.Name = "optifine:OptiFine" Then OptiFineCp = Library.LocalPath Else - CpStrings.Add(Library.LocalPath) + Cps.Add(Library.LocalPath) End If Next - If OptiFineCp IsNot Nothing Then CpStrings.Insert(CpStrings.Count - 2, OptiFineCp) 'OptiFine 的总是需要放到倒数第二位 - GameArguments.Add("${classpath}", Join(CpStrings.Select(Function(c) ShortenPath(c)), ";")) + If OptiFineCp IsNot Nothing Then Cps.Insert(Cps.Count - 2, OptiFineCp) 'OptiFine 的总是需要放到倒数第二位 + Yield ("${classpath}", Cps.Select(Function(c) ShortenPath(c)).Join(";"c)) + End Function - Return GameArguments + ''' + ''' 分割 Java 参数字符串。 + ''' + Private Iterator Function SplitJavaArguments(Arg As String) As IEnumerable(Of String) + Arg = Arg.Replace(vbLf, " ").Replace(vbCr, " ").Trim '预处理换行符 + If String.IsNullOrWhiteSpace(Arg) Then Return + Dim Current As New StringBuilder + Dim InQuotes As Boolean = False + Dim i As Integer = 0 + While i < Arg.Length + Dim c As Char = Arg(i) + If c = "\"c AndAlso i + 1 < Arg.Length AndAlso Arg(i + 1) = """"c Then '检测 \" + '转义的双引号：保留反斜杠和引号，不切换 InQuotes + Current.Append("\""") + i += 1 '额外跳过下一个字符（双引号） + ElseIf c = """"c Then + '未转义的双引号：切换 InQuotes + InQuotes = Not InQuotes + Current.Append(c) + ElseIf c = " "c AndAlso Not InQuotes Then + '不在双引号内的空格：一个参数结束 + If Current.Length > 0 Then + Yield Current.ToString() + Current.Clear() + End If + Else + '普通字符，直接添加 + Current.Append(c) + End If + i += 1 + End While + If Current.Length > 0 Then Yield Current.ToString '添加剩余的 + End Function + ''' + ''' 对 Java 参数进行去重。 + ''' + Private Function DeduplicateJavaArguments(Args As List(Of String), IsJVMArgs As Boolean) As List(Of String) + Dim Result As New List(Of String) + Dim i As Integer = 0 + While i < Args.Count + Dim Key As String = Args(i) + If Not Key.StartsWithF("-") OrElse + (i + 1 >= Args.Count OrElse (Args(i + 1).StartsWithF("-") AndAlso Val(Args(i + 1).AfterFirst("-")) = 0)) Then '避免 -xPos 23 -xPos -50 中后面的 -50 被识别为参数 + '单参数 + i += 1 + If Result.Contains(Key) Then + McLaunchLog($"已去重单个{If(IsJVMArgs, " JVM ", "游戏")}参数：{Key}") + Continue While + End If + Result.Add(Key) + Else + '以空格间隔的键值对（例如 --width 233） + Dim Value As String = Args(i + 1) + i += 2 + For j = 0 To Result.Count - 2 '向前寻找相同的键 + If Result(j) <> Key Then Continue For + '仅当是游戏参数且不是 tweakClass 时，用新的值覆盖旧的值 + '据测试，如果包含多个相同 --width 或 --uuid 等参数，两个都会直接失效，如果这发生在关键参数上会导致崩溃 + If Not IsJVMArgs AndAlso Key <> "--tweakClass" Then + McLaunchLog($"已覆盖重复的{If(IsJVMArgs, " JVM ", "游戏")}参数：{Key} {Result(j + 1)} → {Key} {Value}") + Result(j + 1) = Value + Continue While + End If + '键和值完全相同，直接抛弃 + If Result(j + 1) = Value Then + McLaunchLog($"已去重{If(IsJVMArgs, " JVM ", "游戏")}参数对：{Key} {Value}") + Continue While + End If + Next + Result.Add(Key) + Result.Add(Value) + End If + End While + Return Result End Function #End Region #Region "解压 Natives" - Private Sub McLaunchNatives(Loader As LoaderTask(Of List(Of McLibToken), Integer)) + Private Sub McLaunchNatives(Loader As LoaderTask(Of Integer, Integer)) '创建文件夹 Dim Target As String = GetNativesFolder() & "\" @@ -1734,11 +1789,11 @@ NextVersion: '解压文件 McLaunchLog("正在解压 Natives 文件") Dim ExistFiles As New List(Of String) - For Each Native As McLibToken In Loader.Input + For Each Native As McLibToken In McLibListGet(McInstanceSelected, True) If Not Native.IsNatives Then Continue For Dim Zip As ZipArchive Try - Zip = New ZipArchive(New FileStream(Native.LocalPath, FileMode.Open)) + Zip = New ZipArchive(New FileStream(Native.LocalPath, FileMode.Open, FileAccess.Read, FileShare.Read)) Catch ex As InvalidDataException Log(ex, "打开 Natives 文件失败（" & Native.LocalPath & "）") File.Delete(Native.LocalPath) @@ -1761,7 +1816,7 @@ NextVersion: File.Delete(FilePath) Catch ex As UnauthorizedAccessException McLaunchLog("删除原 dll 访问被拒绝，这通常代表有一个 MC 正在运行，跳过解压：" & FilePath) - McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex)) + McLaunchLog("实际的错误信息：" & ex.GetDetail()) Exit For End Try End If @@ -1781,7 +1836,7 @@ NextVersion: File.Delete(FileName) Catch ex As UnauthorizedAccessException McLaunchLog("删除多余文件访问被拒绝，跳过删除步骤") - McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex)) + McLaunchLog("实际的错误信息：" & ex.GetDetail()) Return End Try Next @@ -1791,11 +1846,15 @@ NextVersion: ''' 获取 Natives 文件夹路径，不以 \ 结尾。 ''' Private Function GetNativesFolder() As String - Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives" - If IsGBKEncoding OrElse Result.IsASCII() Then Return Result - Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives" - If Result.IsASCII() Then Return Result - Return OsDrive & "ProgramData\PCL\natives" + Dim Result As String = ShortenPath(McInstanceSelected.PathVersion) & McInstanceSelected.Name & "-natives" + If Not (IsGBKEncoding OrElse Result.IsASCII()) Then + Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives" + If Not Result.IsASCII() Then + Result = OsDrive & "ProgramData\PCL\natives" + End If + End If + Directory.CreateDirectory(Result) '提前创建，这样 ShortenPath 才有结果（否则在长路径下首次启动 Forge 会崩溃） + Return ShortenPath(Result) End Function #End Region @@ -1804,10 +1863,10 @@ NextVersion: Private Sub McLaunchPrerun() - '要求 Java 使用高性能显卡 - If Setup.Get("LaunchAdvanceGraphicCard") Then + '使用高性能显卡 + If Settings.Get("LaunchAdvanceGraphicCard") Then Try - SetGPUPreference(McLaunchJavaSelected.PathJavaw) + SetGPUPreference(McLaunchJavaSelected.PathJava) SetGPUPreference(PathWithName) Catch ex As Exception If IsAdmin() Then @@ -1815,7 +1874,7 @@ NextVersion: Else Log(ex, "直接调整显卡设置失败，将以管理员权限重启 PCL 再次尝试") Try - If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJavaw}""") = ProcessReturnValues.TaskDone Then + If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJava}""") = ProcessReturnValues.TaskDone Then McLaunchLog("以管理员权限重启 PCL 并调整显卡设置成功") Else Throw New Exception("调整过程中出现异常") @@ -1831,7 +1890,7 @@ NextVersion: Try '确保可用 If Not McLoginLoader.Output.Type = "Microsoft" Then Exit Try - McFolderLauncherProfilesJsonCreate(PathMcFolder) + McFolderLauncherProfilesJsonCreate(McFolderSelected) '构建需要替换的 Json 对象 Dim ReplaceJsonString As String = " { @@ -1853,15 +1912,15 @@ NextVersion: }" Dim ReplaceJson As JObject = GetJson(ReplaceJsonString) '更新文件 - Dim Profiles As JObject = GetJson(ReadFile(PathMcFolder & "launcher_profiles.json")) + Dim Profiles As JObject = GetJson(ReadFile(McFolderSelected & "launcher_profiles.json")) Profiles.Merge(ReplaceJson) - WriteFile(PathMcFolder & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.GetEncoding("GB18030")) + WriteFile(McFolderSelected & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.GetEncoding("GB18030")) McLaunchLog("已更新 launcher_profiles.json") Catch ex As Exception Log(ex, "更新 launcher_profiles.json 失败，将在删除文件后重试") Try - File.Delete(PathMcFolder & "launcher_profiles.json") - McFolderLauncherProfilesJsonCreate(PathMcFolder) + File.Delete(McFolderSelected & "launcher_profiles.json") + McFolderLauncherProfilesJsonCreate(McFolderSelected) '构建需要替换的 Json 对象 Dim ReplaceJsonString As String = " { @@ -1883,9 +1942,9 @@ NextVersion: }" Dim ReplaceJson As JObject = GetJson(ReplaceJsonString) '更新文件 - Dim Profiles As JObject = GetJson(ReadFile(PathMcFolder & "launcher_profiles.json")) + Dim Profiles As JObject = GetJson(ReadFile(McFolderSelected & "launcher_profiles.json")) Profiles.Merge(ReplaceJson) - WriteFile(PathMcFolder & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.GetEncoding("GB18030")) + WriteFile(McFolderSelected & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.GetEncoding("GB18030")) McLaunchLog("已在删除后更新 launcher_profiles.json") Catch exx As Exception Log(exx, "更新 launcher_profiles.json 失败", LogLevel.Feedback) @@ -1893,10 +1952,10 @@ NextVersion: End Try '更新 options.txt - Dim SetupFileAddress As String = McVersionCurrent.PathIndie & "options.txt" + Dim SetupFileAddress As String = McInstanceSelected.PathIndie & "options.txt" If Not File.Exists(SetupFileAddress) Then 'Yosbr Mod 兼容（#2385）：https://www.curseforge.com/minecraft/mc-mods/yosbr - Dim YosbrFileAddress As String = McVersionCurrent.PathIndie & "config\yosbr\options.txt" + Dim YosbrFileAddress As String = McInstanceSelected.PathIndie & "config\yosbr\options.txt" If File.Exists(YosbrFileAddress) Then McLaunchLog("将修改 Yosbr Mod 中的 options.txt") SetupFileAddress = YosbrFileAddress @@ -1911,11 +1970,11 @@ NextVersion: '1.11 ~ 12：zh_cn 时正常，zh_CN 时虽然显示了中文但语言设置会错误地显示选择英文 '1.13+ ：zh_cn 时正常，zh_CN 时自动切换为英文 Dim CurrentLang As String = ReadIni(SetupFileAddress, "lang", "none") - Dim RequiredLang As String = If(CurrentLang = "none" OrElse Not Directory.Exists(McVersionCurrent.PathIndie & "saves"), '#3844，整合包可能已经自带了 options.txt - If(Setup.Get("ToolHelpChinese"), "zh_cn", "en_us"), CurrentLang.ToLower) - If McVersionCurrent.Version.McCodeMain < 12 Then '注意老版本（包含 MC 1.1）的 McCodeMain 可能为 -1 + Dim RequiredLang As String = If(CurrentLang = "none" OrElse Not Directory.Exists(McInstanceSelected.PathIndie & "saves"), '#3844，整合包可能已经自带了 options.txt + If(Settings.Get("ToolHelpChinese"), "zh_cn", "en_us"), CurrentLang.Lower) + If Not McInstanceSelected.Version.Vaild OrElse McInstanceSelected.Version.Vanilla.Major <= 10 Then '将最后两位改为大写，前面的部分保留 - RequiredLang = RequiredLang.Substring(0, RequiredLang.Length - 2) & RequiredLang.Substring(RequiredLang.Length - 2).ToUpper + RequiredLang = RequiredLang.Substring(0, RequiredLang.Length - 2) & RequiredLang.Substring(RequiredLang.Length - 2).Upper End If If CurrentLang = RequiredLang Then McLaunchLog($"需要的语言为 {RequiredLang}，当前语言为 {CurrentLang}，无需修改") @@ -1925,12 +1984,12 @@ NextVersion: McLaunchLog($"已将语言从 {CurrentLang} 修改为 {RequiredLang}") End If ''如果是初次设置，一并修改 forceUnicodeFont - 'If Setup.Get("ToolHelpChinese") AndAlso (CurrentLang = "none" OrElse Not Directory.Exists(McVersionCurrent.PathIndie & "saves")) Then + 'If Settings.Get("ToolHelpChinese") AndAlso (CurrentLang = "none" OrElse Not Directory.Exists(McInstanceSelected.PathIndie & "saves")) Then ' WriteIni(SetupFileAddress, "forceUnicodeFont", "true") ' McLaunchLog("已开启 forceUnicodeFont") 'End If '窗口 - Select Case Setup.Get("LaunchArgumentWindowType") + Select Case Settings.Get("LaunchArgumentWindowType") Case 0 '全屏 WriteIni(SetupFileAddress, "fullscreen", "true") Case 1 '默认 @@ -1942,26 +2001,26 @@ NextVersion: End Try '离线皮肤 Alex 警告 - If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.2 ~ 1.7 + If McInstanceSelected.Version.Vanilla.Major <= 7 AndAlso McInstanceSelected.Version.Vanilla.Major >= 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) + (Settings.Get("LaunchSkinType") = 2 OrElse '强制 Alex + (Settings.Get("LaunchSkinType") = 4 AndAlso Settings.Get("LaunchSkinSlim"))) Then '或选用 Alex 皮肤 + Hint("此 Minecraft 版本尚不支持 Alex 皮肤，你的皮肤可能会显示为 Steve！", HintType.Red) End If '离线皮肤资源包 Try - Directory.CreateDirectory(McVersionCurrent.PathIndie & "resourcepacks\") - Dim ZipFileAddress As String = McVersionCurrent.PathIndie & "resourcepacks\PCL2 Skin.zip" - Dim NewTypeSetup As Boolean = McVersionCurrent.Version.McCodeMain >= 13 OrElse McVersionCurrent.Version.McCodeMain < 6 - If McLoginLoader.Input.Type = McLoginType.Legacy AndAlso Setup.Get("LaunchSkinType") = 4 AndAlso File.Exists(PathAppdata & "CustomSkin.png") Then + Directory.CreateDirectory(McInstanceSelected.PathIndie & "resourcepacks\") + Dim ZipFileAddress As String = McInstanceSelected.PathIndie & "resourcepacks\PCL2 Skin.zip" + Dim NewTypeSetup As Boolean = McInstanceSelected.Version.Vanilla.Major >= 13 OrElse McInstanceSelected.Version.Vanilla.Major < 6 + If McLoginLoader.Input.Type = McLoginType.Legacy AndAlso Settings.Get("LaunchSkinType") = 4 AndAlso File.Exists(PathAppdata & "CustomSkin.png") Then Directory.CreateDirectory(PathTemp) Dim MetaFileAddress As String = PathTemp & "pack.mcmeta" Dim PackPicAddress As String = PathTemp & "pack.png" Dim PackFormat As Integer - Select Case McVersionCurrent.Version.McCodeMain + Select Case McInstanceSelected.Version.Vanilla.Major Case 0, 1, 2, 3, 4, 5 - '更早的版本没有资源包；如果判断失败该值为 -1，不会跑到这 + '更早的版本没有资源包 McLaunchLog("Minecraft 版本过老，尚不支持自定义离线皮肤") GoTo IgnoreCustomSkin Case 6, 7, 8 @@ -1979,24 +2038,24 @@ NextVersion: Case 17 PackFormat = 7 Case 18 - If McVersionCurrent.Version.McCodeSub <= 2 Then + If McInstanceSelected.Version.Vanilla.Minor <= 2 Then PackFormat = 8 Else PackFormat = 9 End If Case 19 - If McVersionCurrent.Version.McCodeSub <= 3 Then + If McInstanceSelected.Version.Vanilla.Minor <= 3 Then PackFormat = 9 Else PackFormat = 12 End If Case 20 - If McVersionCurrent.Version.McCodeSub <= 1 Then + If McInstanceSelected.Version.Vanilla.Minor <= 1 Then PackFormat = 15 Else PackFormat = 17 End If - Case Else '快照版是 99 + Case Else '快照版是 9999 PackFormat = 17 'https://zh.minecraft.wiki/w/数据包#数据包版本 End Select @@ -2006,7 +2065,7 @@ NextVersion: Bit.Save(PackPicAddress) WriteFile(MetaFileAddress, "{""pack"":{""pack_format"":" & PackFormat & ",""description"":""PCL 自定义离线皮肤资源包""}}") Dim Skin As New MyBitmap(PathAppdata & "CustomSkin.png") - If (McVersionCurrent.Version.McCodeMain = 6 OrElse McVersionCurrent.Version.McCodeMain = 7) AndAlso Skin.Pic.Height = 64 Then + If (McInstanceSelected.Version.Vanilla.Major = 6 OrElse McInstanceSelected.Version.Vanilla.Major = 7) AndAlso Skin.Pic.Height = 64 Then McLaunchLog("该 Minecraft 版本不支持双层皮肤，已进行裁剪") Skin = Skin.Clip(0, 0, 64, 32) End If @@ -2017,22 +2076,13 @@ NextVersion: ZipAr.CreateEntryFromFile(MetaFileAddress, "pack.mcmeta") ZipAr.CreateEntryFromFile(PackPicAddress, "pack.png") '1.19.3+ 使用复杂版本的替换 - Dim IsOldType As Boolean - Select Case McVersionCurrent.Version.McCodeMain - Case Is < 19 - IsOldType = True - Case 19 - IsOldType = McVersionCurrent.Version.McCodeSub <= 2 - Case Else - IsOldType = False - End Select - If IsOldType Then - ZipAr.CreateEntryFromFile(Path & "PCL\CustomSkin_Cliped.png", "assets/minecraft/textures/entity/" & If(Setup.Get("LaunchSkinSlim"), "alex.png", "steve.png")) - Else + If McInstanceSelected.Version.Vanilla >= New Version(19, 0, 3) Then For Each SkinName In {"alex", "ari", "efe", "kai", "makena", "noor", "steve", "sunny", "zuri"} ZipAr.CreateEntryFromFile(Path & "PCL\CustomSkin_Cliped.png", - $"assets/minecraft/textures/entity/player/{If(Setup.Get("LaunchSkinSlim"), "slim", "wide")}/{SkinName}.png") + $"assets/minecraft/textures/entity/player/{If(Settings.Get("LaunchSkinSlim"), "slim", "wide")}/{SkinName}.png") Next + Else + ZipAr.CreateEntryFromFile(Path & "PCL\CustomSkin_Cliped.png", "assets/minecraft/textures/entity/" & If(Settings.Get("LaunchSkinSlim"), "alex.png", "steve.png")) End If End Using End Using @@ -2048,7 +2098,7 @@ NextVersion: If Res <> """file/PCL2 Skin.zip""" AndAlso Res <> "" Then NewResourcePacks.Add(Res) Next NewResourcePacks.Add("""file/PCL2 Skin.zip""") - Dim Result As String = "[" & Join(NewResourcePacks, ",") & "]" + Dim Result As String = "[" & NewResourcePacks.Join(","c) & "]" WriteIni(SetupFileAddress, "resourcePacks", Result) Else Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(",")) @@ -2057,7 +2107,7 @@ NextVersion: If Res <> """PCL2 Skin.zip""" AndAlso Res <> "" Then NewResourcePacks.Add(Res) Next NewResourcePacks.Add("""PCL2 Skin.zip""") - Dim Result As String = "[" & Join(NewResourcePacks, ",") & "]" + Dim Result As String = "[" & NewResourcePacks.Join(","c) & "]" WriteIni(SetupFileAddress, "resourcePacks", Result) End If IgnoreCustomSkin: @@ -2072,12 +2122,12 @@ IgnoreCustomSkin: If EnabledResourcePack = "" Then EnabledResourcePack = """vanilla""" Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(",")) EnabledResourcePacks.Remove("""file/PCL2 Skin.zip""") - Dim Result As String = "[" & Join(EnabledResourcePacks, ",") & "]" + Dim Result As String = "[" & EnabledResourcePacks.Join(","c) & "]" WriteIni(SetupFileAddress, "resourcePacks", Result) Else Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(",")) EnabledResourcePacks.Remove("""PCL2 Skin.zip""") - Dim Result As String = "[" & Join(EnabledResourcePacks, ",") & "]" + Dim Result As String = "[" & EnabledResourcePacks.Join(","c) & "]" WriteIni(SetupFileAddress, "resourcePacks", Result) End If End If @@ -2089,31 +2139,31 @@ IgnoreCustomSkin: Private Sub McLaunchCustom(Loader As LoaderTask(Of Integer, Integer)) '获取自定义命令 - Dim CustomCommandGlobal As String = Setup.Get("LaunchAdvanceRun") - If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal, True) - Dim CustomCommandVersion As String = Setup.Get("VersionAdvanceRun", Version:=McVersionCurrent) - If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion, True) + Dim CustomCommandGlobal As String = Settings.Get("LaunchAdvanceRun") + If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal) + Dim CustomCommandVersion As String = Settings.Get("VersionAdvanceRun", Instance:=McInstanceSelected) + If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion) '输出 bat Try Dim CmdString As String = - $"{If(McLaunchJavaSelected.VersionCode > 8, "chcp 65001>nul" & vbCrLf, "")}" & + $"{If(McLaunchJavaSelected.MajorVersion > 8, "chcp 65001>nul" & vbCrLf, "")}" & "@echo off" & vbCrLf & - $"title 启动 - {McVersionCurrent.Name}" & vbCrLf & + $"title 启动 - {McInstanceSelected.Name}" & vbCrLf & "echo 游戏正在启动，请稍候。" & vbCrLf & - $"cd /D ""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf & + $"cd /D ""{ShortenPath(McInstanceSelected.PathIndie)}""" & vbCrLf & CustomCommandGlobal & vbCrLf & CustomCommandVersion & vbCrLf & $"""{McLaunchJavaSelected.PathJava}"" {McLaunchArgument}" & vbCrLf & "echo 游戏已退出。" & vbCrLf & "pause" WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), FilterAccessToken(CmdString, "F"), - Encoding:=If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Encoding.Default)) + Encoding:=If(McLaunchJavaSelected.MajorVersion > 8, Encoding.UTF8, Encoding.Default)) If CurrentLaunchOptions.SaveBatch IsNot Nothing Then McLaunchLog("导出启动脚本完成，强制结束启动过程") - AbortHint = "导出启动脚本成功！" + InterruptHint = "导出启动脚本成功！" OpenExplorer(CurrentLaunchOptions.SaveBatch) - Loader.Parent.Abort() + Loader.Parent.Interrupt() Return '导出脚本完成 End If Catch ex As Exception @@ -2124,23 +2174,24 @@ IgnoreCustomSkin: '执行自定义命令 If CustomCommandGlobal <> "" Then McLaunchLog("正在执行全局自定义命令：" & CustomCommandGlobal) - Dim CustomProcess As New Process + Dim CustomProcess As Process = Nothing Try - CustomProcess.StartInfo.FileName = "cmd.exe" - CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandGlobal & """" - CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) - CustomProcess.StartInfo.UseShellExecute = False - CustomProcess.StartInfo.CreateNoWindow = True - CustomProcess.Start() - If Setup.Get("LaunchAdvanceRunWait") Then - Do Until CustomProcess.HasExited OrElse Loader.IsAborted + CustomProcess = StartProcess(New ProcessStartInfo With { + .FileName = "cmd.exe", + .Arguments = $"/c ""{CustomCommandGlobal}""", + .WorkingDirectory = McFolderSelected, + .UseShellExecute = False, + .CreateNoWindow = True + }) + If Settings.Get("LaunchAdvanceRunWait") Then + Do Until CustomProcess.HasExited OrElse Loader.IsInterrupted Thread.Sleep(10) Loop End If Catch ex As Exception Log(ex, "执行全局自定义命令失败", LogLevel.Hint) Finally - If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then + If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsInterrupted Then McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183 CustomProcess.Kill() End If @@ -2148,23 +2199,24 @@ IgnoreCustomSkin: End If If CustomCommandVersion <> "" Then McLaunchLog("正在执行版本自定义命令：" & CustomCommandVersion) - Dim CustomProcess As New Process + Dim CustomProcess As Process = Nothing Try - CustomProcess.StartInfo.FileName = "cmd.exe" - CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandVersion & """" - CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) - CustomProcess.StartInfo.UseShellExecute = False - CustomProcess.StartInfo.CreateNoWindow = True - CustomProcess.Start() - If Setup.Get("VersionAdvanceRunWait", Version:=McVersionCurrent) Then - Do Until CustomProcess.HasExited OrElse Loader.IsAborted + CustomProcess = StartProcess(New ProcessStartInfo With { + .FileName = "cmd.exe", + .Arguments = $"/c ""{CustomCommandVersion}""", + .WorkingDirectory = McFolderSelected, + .UseShellExecute = False, + .CreateNoWindow = True + }) + If Settings.Get("VersionAdvanceRunWait", Instance:=McInstanceSelected) Then + Do Until CustomProcess.HasExited OrElse Loader.IsInterrupted Thread.Sleep(10) Loop End If Catch ex As Exception Log(ex, "执行版本自定义命令失败", LogLevel.Hint) Finally - If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then + If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsInterrupted Then McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183 CustomProcess.Kill() End If @@ -2175,28 +2227,28 @@ IgnoreCustomSkin: Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process)) '启动信息 - Dim GameProcess = New Process() - Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJavaw) + Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263 '设置环境变量 - Dim Paths As New List(Of String)(StartInfo.EnvironmentVariables("Path").Split(";")) + Dim PathEnv As String = StartInfo.EnvironmentVariables("Path") + Dim Paths As New List(Of String) + If Not String.IsNullOrEmpty(PathEnv) Then Paths.AddRange(PathEnv.Split(";")) Paths.Add(ShortenPath(McLaunchJavaSelected.PathFolder)) - StartInfo.EnvironmentVariables("Path") = Join(Paths.Distinct.ToList, ";") - StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder) + StartInfo.EnvironmentVariables("Path") = Paths.Distinct.Join(";"c) + StartInfo.EnvironmentVariables("appdata") = ShortenPath(McFolderSelected) '设置其他参数 - StartInfo.WorkingDirectory = ShortenPath(McVersionCurrent.PathIndie) + StartInfo.WorkingDirectory = McInstanceSelected.PathIndie StartInfo.UseShellExecute = False StartInfo.RedirectStandardOutput = True StartInfo.RedirectStandardError = True - StartInfo.CreateNoWindow = False + StartInfo.CreateNoWindow = True StartInfo.Arguments = McLaunchArgument - GameProcess.StartInfo = StartInfo '开始进程 - GameProcess.Start() - McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJavaw) - If Loader.IsAborted Then + Dim GameProcess = StartProcess(StartInfo) + McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJava) + If Loader.IsInterrupted Then McLaunchLog("由于取消启动，已强制结束游戏进程") '#1631 GameProcess.Kill() Return @@ -2207,7 +2259,7 @@ IgnoreCustomSkin: '进程优先级处理 Try GameProcess.PriorityBoostEnabled = True - Select Case Setup.Get("LaunchArgumentPriority") + Select Case Settings.Get("LaunchArgumentPriority") Case 0 '高 GameProcess.PriorityClass = ProcessPriorityClass.AboveNormal Case 2 '低 @@ -2225,14 +2277,14 @@ IgnoreCustomSkin: McLaunchLog("") McLaunchLog("~ 基础参数 ~") McLaunchLog("PCL 版本：" & VersionDisplayName & " (" & VersionCode & ")") - McLaunchLog("游戏版本：" & McVersionCurrent.Version.ToString & "（识别为 1." & McVersionCurrent.Version.McCodeMain & "." & McVersionCurrent.Version.McCodeSub & "）") - McLaunchLog("资源版本：" & McAssetsGetIndexName(McVersionCurrent)) - McLaunchLog("版本继承：" & If(McVersionCurrent.InheritVersion = "", "无", McVersionCurrent.InheritVersion)) - McLaunchLog("分配的内存：" & PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) & " GB（" & Math.Round(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & " MB）") - McLaunchLog("MC 文件夹：" & PathMcFolder) - McLaunchLog("版本文件夹：" & McVersionCurrent.Path) - McLaunchLog("版本隔离：" & (McVersionCurrent.PathIndie = McVersionCurrent.Path)) - McLaunchLog("HMCL 格式：" & McVersionCurrent.IsHmclFormatJson) + McLaunchLog($"游戏版本：{McInstanceSelected.VersionDisplayName}（{McInstanceSelected.Version.Vanilla}，Drop {McInstanceSelected.Version.Drop}{If(McInstanceSelected.Version.Reliable, "", "，无法完全确定")}）") + McLaunchLog("资源版本：" & McAssetsGetIndexName(McInstanceSelected)) + McLaunchLog("版本继承：" & If(McInstanceSelected.InheritName = "", "无", McInstanceSelected.InheritName)) + McLaunchLog("分配的内存：" & PageInstanceSetup.GetRam(McInstanceSelected, Not McLaunchJavaSelected.Is64Bit) & " GB（" & Math.Round(PageInstanceSetup.GetRam(McInstanceSelected, Not McLaunchJavaSelected.Is64Bit) * 1024) & " MB）") + McLaunchLog("MC 文件夹：" & McFolderSelected) + McLaunchLog("版本文件夹：" & McInstanceSelected.PathVersion) + McLaunchLog("版本隔离：" & (McInstanceSelected.PathIndie = McInstanceSelected.PathVersion)) + McLaunchLog("HMCL 格式：" & McInstanceSelected.IsHmclFormatJson) McLaunchLog("Java 信息：" & If(McLaunchJavaSelected IsNot Nothing, McLaunchJavaSelected.ToString, "无可用 Java")) McLaunchLog("环境变量：" & If(McLaunchJavaSelected IsNot Nothing, If(McLaunchJavaSelected.HasEnvironment, "已设置", "未设置"), "未设置")) McLaunchLog("Natives 文件夹：" & GetNativesFolder()) @@ -2246,12 +2298,12 @@ IgnoreCustomSkin: McLaunchLog("") '获取窗口标题 - Dim WindowTitle As String = Setup.Get("VersionArgumentTitle", Version:=McVersionCurrent) - If WindowTitle = "" Then WindowTitle = Setup.Get("LaunchArgumentTitle") - WindowTitle = ArgumentReplace(WindowTitle, False) + Dim WindowTitle As String = Settings.Get("VersionArgumentTitle", Instance:=McInstanceSelected) + If WindowTitle = "" Then WindowTitle = Settings.Get("LaunchArgumentTitle") + WindowTitle = ArgumentReplace(WindowTitle, ReplaceTime:=False) '初始化等待 - Dim Watcher As New Watcher(Loader, McVersionCurrent, WindowTitle) + Dim Watcher As New Watcher(Loader, McInstanceSelected, WindowTitle) McLaunchWatcher = Watcher '等待 @@ -2267,15 +2319,15 @@ IgnoreCustomSkin: McLaunchLog("开始启动结束处理") '暂停或开始音乐播放 - If Setup.Get("UiMusicStop") Then + If Settings.Get("UiMusicStop") Then RunInUi(Sub() If MusicPause() Then Log("[Music] 已根据设置，在启动后暂停音乐播放")) - ElseIf Setup.Get("UiMusicStart") Then + ElseIf Settings.Get("UiMusicStart") Then RunInUi(Sub() If MusicResume() Then Log("[Music] 已根据设置，在启动后开始音乐播放")) End If '启动器可见性 - McLaunchLog("启动器可见性：" & Setup.Get("LaunchArgumentVisible")) - Select Case Setup.Get("LaunchArgumentVisible") + McLaunchLog("启动器可见性：" & Settings.Get("LaunchArgumentVisible")) + Select Case Settings.Get("LaunchArgumentVisible") Case 0 '直接关闭 McLaunchLog("已根据设置，在启动后关闭启动器") @@ -2293,51 +2345,10 @@ IgnoreCustomSkin: End Select '启动计数 - Setup.Set("SystemLaunchCount", Setup.Get("SystemLaunchCount") + 1) + Settings.Set("SystemLaunchCount", Settings.Get("SystemLaunchCount") + 1) End Sub - ''' - ''' 在启动结束时，对 PCL 约定的替换标记进行处理。 - ''' - Private Function ArgumentReplace(Raw As String, ReplaceTimeAndDate As Boolean) As String - If Raw Is Nothing Then Return Nothing - '路径替换 - Raw = Raw.Replace("{minecraft}", PathMcFolder) - Raw = Raw.Replace("{verpath}", McVersionCurrent.Path) - Raw = Raw.Replace("{verindie}", McVersionCurrent.PathIndie) - Raw = Raw.Replace("{java}", McLaunchJavaSelected.PathFolder) - '普通替换 - Raw = Raw.Replace("{user}", McLoginLoader.Output.Name) - Raw = Raw.Replace("{uuid}", McLoginLoader.Output.Uuid) - If ReplaceTimeAndDate Then '设置窗口标题时需要动态替换日期和时间 - Raw = Raw.Replace("{date}", Date.Now.ToString("yyyy/M/d")) - Raw = Raw.Replace("{time}", Date.Now.ToString("HH:mm:ss")) - End If - Select Case McLoginLoader.Input.Type - Case McLoginType.Legacy - If PageLinkHiper.HiperState = LoadState.Finished Then - Raw = Raw.Replace("{login}", "联机离线") - Else - Raw = Raw.Replace("{login}", "离线") - End If - Case McLoginType.Ms - Raw = Raw.Replace("{login}", "正版") - Case McLoginType.Nide - Raw = Raw.Replace("{login}", "统一通行证") - Case McLoginType.Auth - Raw = Raw.Replace("{login}", "Authlib-Injector") - End Select - Raw = Raw.Replace("{name}", McVersionCurrent.Name) - If {"unknown", "old", "pending"}.Contains(McVersionCurrent.Version.McName.ToLower) Then - Raw = Raw.Replace("{version}", McVersionCurrent.Name) - Else - Raw = Raw.Replace("{version}", McVersionCurrent.Version.McName) - End If - Raw = Raw.Replace("{path}", Path) - Return Raw - End Function - #End Region End Module diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb index 1bdad51..5d5ba60 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb @@ -5,32 +5,52 @@ Public Module ModMinecraft #Region "文件夹" ''' - ''' 当前的 Minecraft 文件夹路径，以“\”结尾。 + ''' 当前的 Minecraft 文件夹路径，以 \ 结尾。 ''' - Public PathMcFolder As String + Public Property McFolderSelected As String + Get + If _McFolderSelected Is Nothing Then SetMcFolder(Settings.Get("LaunchFolderSelect")) '不能使用 McFolderSelected 触发 Set，这会被视为为 Get 设置返回值 + Return _McFolderSelected + End Get + Set(Value As String) + SetMcFolder(Value) + End Set + End Property + Private Sub SetMcFolder(Value As String) '等同 McFolderSelected.Set + If _McFolderSelected = Value Then Return + _McFolderSelected = Value.Replace("$", Path) + Settings.Set("LaunchFolderSelect", Value.Replace(Path, "$")) + Log("[Minecraft] 当前选择的 Minecraft 文件夹：" & _McFolderSelected) + End Sub + Private _McFolderSelected As String ''' ''' 当前的 Minecraft 文件夹列表。 ''' Public McFolderList As New List(Of McFolder) - Public Class McFolder '必须是 Class，否则不是引用类型，在 ForEach 中不会得到刷新 + Public Class McFolder Public Name As String - Public Path As String - Public Type As McFolderType + ''' + ''' 文件夹路径。 + ''' 以 \ 结尾，例如 "D:\Game\MC\.minecraft\"。 + ''' + Public Location As String + Public Type As Types + Public Enum Types + Vanilla + RenamedVanilla + Custom + End Enum + Public Overrides Function Equals(obj As Object) As Boolean If Not (TypeOf obj Is McFolder) Then Return False - Dim folder = DirectCast(obj, McFolder) - Return Name = folder.Name AndAlso Path = folder.Path AndAlso Type = folder.Type + Dim Folder = DirectCast(obj, McFolder) + Return Name = Folder.Name AndAlso Location = Folder.Location AndAlso Type = Folder.Type End Function Public Overrides Function ToString() As String - Return Path + Return Location End Function End Class - Public Enum McFolderType - Original - RenamedOriginal - Custom - End Enum ''' ''' 加载 Minecraft 文件夹列表。 @@ -45,9 +65,9 @@ Public Module ModMinecraft '扫描当前文件夹 Try - If Directory.Exists(Path & "versions\") Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Path, .Type = McFolderType.Original}) + If Directory.Exists(Path & "versions\") Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Location = Path, .Type = McFolder.Types.Vanilla}) For Each Folder As DirectoryInfo In New DirectoryInfo(Path).GetDirectories - If Directory.Exists(Folder.FullName & "versions\") OrElse Folder.Name = ".minecraft" Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Folder.FullName & "\", .Type = McFolderType.Original}) + If Directory.Exists(Folder.FullName & "versions\") OrElse Folder.Name = ".minecraft" Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Location = Folder.FullName & "\", .Type = McFolder.Types.Vanilla}) Next Catch ex As Exception Log(ex, "扫描 PCL 所在文件夹中是否有 MC 文件夹失败") @@ -55,9 +75,9 @@ Public Module ModMinecraft '扫描官启文件夹 Dim MojangPath As String = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\" - If (Not CacheMcFolderList.Any OrElse MojangPath <> CacheMcFolderList(0).Path) AndAlso '当前文件夹不是官启文件夹 + If (Not CacheMcFolderList.Any OrElse MojangPath <> CacheMcFolderList(0).Location) AndAlso '当前文件夹不是官启文件夹 Directory.Exists(MojangPath & "versions\") Then '具有权限且存在 versions 文件夹 - CacheMcFolderList.Add(New McFolder With {.Name = "官方启动器文件夹", .Path = MojangPath, .Type = McFolderType.Original}) + CacheMcFolderList.Add(New McFolder With {.Name = "官方启动器文件夹", .Location = MojangPath, .Type = McFolder.Types.Vanilla}) End If #End Region @@ -65,54 +85,51 @@ Public Module ModMinecraft #Region "读取自定义（Custom）文件夹，可能没有结果" '格式：TMZ 12>C://xxx/xx/|Test>D://xxx/xx/|名称>路径 - For Each Folder As String In Setup.Get("LaunchFolders").Split("|") + For Each Folder As String In Settings.Get("LaunchFolders").ToString.Split({"|"c}, StringSplitOptions.RemoveEmptyEntries) If Folder = "" Then Continue For If Not Folder.Contains(">") OrElse Not Folder.EndsWithF("\") Then - Hint("无效的 Minecraft 文件夹：" & Folder, HintType.Critical) + Hint("无效的 Minecraft 文件夹：" & Folder, HintType.Red) Continue For End If - Dim Name As String = Folder.Split(">")(0) - Dim Path As String = Folder.Split(">")(1) + Dim FolderName As String = Folder.BeforeFirst(">"), FolderPath As String = Folder.AfterFirst(">") Try - CheckPermissionWithException(Path) + CheckPermissionWithException(FolderPath) '若已有该文件夹，则直接重命名；没有则添加 Dim Renamed As Boolean = False For Each OriginalFolder As McFolder In CacheMcFolderList - If OriginalFolder.Path = Path Then - OriginalFolder.Name = Name - OriginalFolder.Type = McFolderType.RenamedOriginal + If OriginalFolder.Location = FolderPath Then + OriginalFolder.Name = FolderName + OriginalFolder.Type = McFolder.Types.RenamedVanilla Renamed = True End If Next - If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = Name, .Path = Path, .Type = McFolderType.Custom}) + If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = FolderName, .Location = FolderPath, .Type = McFolder.Types.Custom}) Catch ex As Exception - MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & Path & vbCrLf & vbCrLf & GetExceptionSummary(ex), "Minecraft 文件夹失效", IsWarn:=True) - Log(ex, $"无法访问 Minecraft 文件夹 {Path}") + MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & FolderPath & vbCrLf & vbCrLf & ex.GetBrief(), "Minecraft 文件夹失效", IsWarn:=True) + Log(ex, $"无法访问 Minecraft 文件夹 {FolderPath}") End Try Next '将自定义文件夹情况同步到设置 Dim NewSetup As New List(Of String) For Each Folder As McFolder In CacheMcFolderList - If Not Folder.Type = McFolderType.Original Then NewSetup.Add(Folder.Name & ">" & Folder.Path) + If Not Folder.Type = McFolder.Types.Vanilla Then NewSetup.Add(Folder.Name & ">" & Folder.Location) Next If Not NewSetup.Any() Then NewSetup.Add("") '防止 0 元素 Join 返回 Nothing - Setup.Set("LaunchFolders", Join(NewSetup, "|")) + Settings.Set("LaunchFolders", NewSetup.Join("|"c)) #End Region '若没有可用文件夹，则创建 .minecraft If Not CacheMcFolderList.Any() Then Directory.CreateDirectory(Path & ".minecraft\versions\") - CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Path & ".minecraft\", .Type = McFolderType.Original}) + CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Location = Path & ".minecraft\", .Type = McFolder.Types.Vanilla}) End If For Each Folder As McFolder In CacheMcFolderList -#Region "更新 launcher_profiles.json" - McFolderLauncherProfilesJsonCreate(Folder.Path) -#End Region + McFolderLauncherProfilesJsonCreate(Folder.Location) Next - If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 2000)) + If Settings.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 2000)) '回设 McFolderList = CacheMcFolderList @@ -153,81 +170,85 @@ Public Module ModMinecraft #Region "版本处理" - Public Const McVersionCacheVersion As Integer = 30 + Public Const McInstanceCacheVersion As Integer = 35 - Private _McVersionCurrent As McVersion - Private _McVersionLast = 0 '为 0 以保证与 Nothing 不相同，使得 UI 显示可以正常初始化 + Private _McInstanceSelected As McInstance ''' ''' 当前的 Minecraft 版本。 ''' - Public Property McVersionCurrent As McVersion + Public Property McInstanceSelected As McInstance Get - Return _McVersionCurrent + Return _McInstanceSelected End Get - Set(value As McVersion) - If ReferenceEquals(_McVersionLast, value) Then Return - _McVersionCurrent = value '由于有可能是 Nothing，导致无法初始化，才得这样弄一圈 - _McVersionLast = value + Set(value As McInstance) + Static _McInstanceSelectedLast = 0 '为 0 以保证与 Nothing 不相同，使得 UI 显示可以正常初始化 + If ReferenceEquals(_McInstanceSelectedLast, value) Then Return + _McInstanceSelected = value '由于有可能是 Nothing，导致无法初始化，才得这样弄一圈 + _McInstanceSelectedLast = value + Settings.MakeInstanceDirty() + '更新 MC 文件夹所选取的 Minecraft 版本 + Log("[Launch] 当前选择的 Minecraft 版本：" & If(value?.PathVersion, "无")) + WriteIni(McFolderSelected & "PCL.ini", "Version", If(value?.Name, "")) If value Is Nothing Then Return - '重置缓存的 Mod 文件夹 - PageDownloadCompDetail.CachedFolder = Nothing + '重置缓存的下载文件夹 + PageDownloadCompDetail.CachedFolder.Clear() '统一通行证重判 If AniControlEnabled = 0 AndAlso - Setup.Get("VersionServerNide", Version:=value) <> Setup.Get("CacheNideServer") AndAlso - Setup.Get("VersionServerLogin", Version:=value) = 3 Then - Setup.Set("CacheNideAccess", "") + Settings.Get("VersionServerNide", Instance:=value) <> Settings.Get("CacheNideServer") AndAlso + Settings.Get("VersionServerLogin", Instance:=value) = 3 Then + Settings.Set("CacheNideAccess", "") Log("[Launch] 服务器改变，要求重新登录统一通行证") End If - If Setup.Get("VersionServerLogin", Version:=value) = 3 Then - Setup.Set("CacheNideServer", Setup.Get("VersionServerNide", Version:=value)) + If Settings.Get("VersionServerLogin", Instance:=value) = 3 Then + Settings.Set("CacheNideServer", Settings.Get("VersionServerNide", Instance:=value)) End If 'Authlib-Injector 重判 If AniControlEnabled = 0 AndAlso - Setup.Get("VersionServerAuthServer", Version:=value) <> Setup.Get("CacheAuthServerServer") AndAlso - Setup.Get("VersionServerLogin", Version:=value) = 4 Then - Setup.Set("CacheAuthAccess", "") + Settings.Get("VersionServerAuthServer", Instance:=value) <> Settings.Get("CacheAuthServerServer") AndAlso + Settings.Get("VersionServerLogin", Instance:=value) = 4 Then + Settings.Set("CacheAuthAccess", "") Log("[Launch] 服务器改变，要求重新登录 Authlib-Injector") End If - If Setup.Get("VersionServerLogin", Version:=value) = 4 Then - Setup.Set("CacheAuthServerServer", Setup.Get("VersionServerAuthServer", Version:=value)) - Setup.Set("CacheAuthServerName", Setup.Get("VersionServerAuthName", Version:=value)) - Setup.Set("CacheAuthServerRegister", Setup.Get("VersionServerAuthRegister", Version:=value)) + If Settings.Get("VersionServerLogin", Instance:=value) = 4 Then + Settings.Set("CacheAuthServerServer", Settings.Get("VersionServerAuthServer", Instance:=value)) + Settings.Set("CacheAuthServerName", Settings.Get("VersionServerAuthName", Instance:=value)) + Settings.Set("CacheAuthServerRegister", Settings.Get("VersionServerAuthRegister", Instance:=value)) End If End Set End Property - Public Class McVersion + Public Class McInstance ''' - ''' 该版本的版本文件夹，以“\”结尾。 + ''' 版本文件夹路径，以 \ 结尾。 ''' - Public ReadOnly Property Path As String + Public ReadOnly Property PathVersion As String ''' - ''' 应用版本隔离后，该版本所对应的 Minecraft 根文件夹，以“\”结尾。 + ''' 应用版本隔离后，该版本所对应的 Minecraft 根文件夹，以 \ 结尾。 ''' Public ReadOnly Property PathIndie As String Get - If Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then + If Not Settings.HasSaved("VersionArgumentIndieV2", Instance:=Me) Then If Not IsLoaded Then Load() '决定该版本是否应该被隔离 Dim ShouldBeIndie = Function() As Boolean '从老的版本独立设置中迁移：-1 未决定，0 使用全局设置，1 手动开启，2 手动关闭 - If Not Setup.IsUnset("VersionArgumentIndie", Version:=Me) AndAlso Setup.Get("VersionArgumentIndie", Version:=Me) > 0 Then + If Settings.HasSaved("VersionArgumentIndie", Instance:=Me) AndAlso Settings.Get("VersionArgumentIndie", Instance:=Me) > 0 Then Log($"[Minecraft] 版本隔离初始化（{Name}）：从老的版本独立设置中迁移") - Return Setup.Get("VersionArgumentIndie", Version:=Me) = 1 + Return Settings.Get("VersionArgumentIndie", Instance:=Me) = 1 End If '若版本文件夹下包含 mods 或 saves 文件夹，则自动开启版本隔离 - Dim ModFolder As New DirectoryInfo(Path & "mods\") - Dim SaveFolder As New DirectoryInfo(Path & "saves\") + Dim ModFolder As New DirectoryInfo(PathVersion & "mods\") + Dim SaveFolder As New DirectoryInfo(PathVersion & "saves\") If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Any) OrElse (SaveFolder.Exists AndAlso SaveFolder.EnumerateDirectories.Any) Then Log($"[Minecraft] 版本隔离初始化（{Name}）：版本文件夹下存在 mods 或 saves 文件夹，自动开启") Return True End If '根据全局的默认设置决定是否隔离 - Dim IsRelease As Boolean = State <> McVersionState.Fool AndAlso State <> McVersionState.Old AndAlso State <> McVersionState.Snapshot - Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Setup.Get("LaunchArgumentIndieV2")}）判断，State {GetStringFromEnum(State)}，IsRelease {IsRelease}，Modable {Modable}") - Select Case Setup.Get("LaunchArgumentIndieV2") + Dim IsRelease As Boolean = State <> McInstanceState.Fool AndAlso State <> McInstanceState.Old AndAlso State <> McInstanceState.Snapshot + Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Settings.Get("LaunchArgumentIndieV2")}）判断，State {GetStringFromEnum(State)}，IsRelease {IsRelease}，Modable {Modable}") + Select Case Settings.Get("LaunchArgumentIndieV2") Case 0 '关闭 Return False Case 1 '仅隔离可安装 Mod 的版本 @@ -240,9 +261,9 @@ Public Module ModMinecraft Return True End Select End Function - Setup.Set("VersionArgumentIndieV2", ShouldBeIndie(), Version:=Me) + Settings.Set("VersionArgumentIndieV2", ShouldBeIndie(), Instance:=Me) End If - Return If(Setup.Get("VersionArgumentIndieV2", Version:=Me), Path, PathMcFolder) + Return If(Settings.Get("VersionArgumentIndieV2", Instance:=Me), PathVersion, McFolderSelected) End Get End Property @@ -251,7 +272,7 @@ Public Module ModMinecraft ''' Public ReadOnly Property Name As String Get - If _Name Is Nothing AndAlso Not Path = "" Then _Name = GetFolderNameFromPath(Path) + If _Name Is Nothing AndAlso Not PathVersion = "" Then _Name = GetFolderNameFromPath(PathVersion) Return _Name End Get End Property @@ -261,10 +282,11 @@ Public Module ModMinecraft ''' 显示的描述文本。 ''' Public Info As String = "该版本未被加载，请向作者反馈此问题" + ''' ''' 该版本的列表检查原始结果，不受自定义影响。 ''' - Public State As McVersionState = McVersionState.Error + Public State As McInstanceState = McInstanceState.Error ''' ''' 显示的版本图标。 ''' @@ -276,174 +298,194 @@ Public Module ModMinecraft ''' ''' 强制版本分类，0 为未启用，1 为隐藏，2 及以上为其他普通分类。 ''' - Public DisplayType As McVersionCardType = McVersionCardType.Auto + Public DisplayType As McInstanceCardType = McInstanceCardType.Auto ''' ''' 该版本是否可以安装 Mod。 ''' Public ReadOnly Property Modable As Boolean Get If Not IsLoaded Then Load() - Return Version.HasFabric OrElse Version.HasForge OrElse Version.HasLiteLoader OrElse Version.HasNeoForge OrElse - DisplayType = McVersionCardType.API '#223 + Return Version.HasFabric OrElse Version.HasForgelike OrElse Version.HasLiteLoader OrElse + DisplayType = McInstanceCardType.API '#223 End Get End Property ''' ''' 版本信息。 ''' - Public Property Version As McVersionInfo + Public Property Version As McVersion Get - If _Version Is Nothing Then - _Version = New McVersionInfo + If _Version IsNot Nothing Then Return _Version + _Version = New McVersion #Region "获取游戏版本" + Try + '获取发布时间并判断是否为老版本 Try - - '获取发布时间并判断是否为老版本 - Try - If JsonObject("releaseTime") Is Nothing Then - ReleaseTime = New Date(1970, 1, 1, 15, 0, 0) '未知版本也可能显示为 1970 年 - Else - ReleaseTime = JsonObject("releaseTime").ToObject(Of Date) - End If - If ReleaseTime.Year > 2000 AndAlso ReleaseTime.Year < 2013 Then - _Version.McName = "Old" - GoTo VersionSearchFinish - End If - Catch - ReleaseTime = New Date(1970, 1, 1, 15, 0, 0) - End Try - '实验性快照 - If If(JsonObject("type"), "") = "pending" Then - _Version.McName = "pending" + If JsonObject("releaseTime") Is Nothing Then + ReleaseTime = New Date(1970, 1, 1, 15, 0, 0) '未知版本也可能显示为 1970 年 + Else + ReleaseTime = JsonObject("releaseTime").ToObject(Of Date) + End If + If ReleaseTime.Year > 2000 AndAlso ReleaseTime.Year < 2013 Then + _Version.VanillaName = "Old" GoTo VersionSearchFinish End If - '从 PCL 下载的版本信息中获取版本号 - If JsonObject("clientVersion") IsNot Nothing Then - _Version.McName = JsonObject("clientVersion") - GoTo VersionSearchFinish - End If - '从 HMCL 下载的版本信息中获取版本号 - If JsonObject("patches") IsNot Nothing Then - For Each Patch As JObject In JsonObject("patches") - If If(Patch("id"), "").ToString = "game" AndAlso Patch("version") IsNot Nothing Then - _Version.McName = Patch("version").ToString - GoTo VersionSearchFinish - End If - Next - End If - '从 Forge / NeoForge Arguments 中获取版本号 - If JsonObject("arguments") IsNot Nothing AndAlso JsonObject("arguments")("game") IsNot Nothing Then - Dim Mark As Boolean = False - For Each Argument In JsonObject("arguments")("game") - If Mark Then - _Version.McName = Argument.ToString - GoTo VersionSearchFinish - End If - If Argument.ToString = "--fml.mcVersion" Then Mark = True - Next - End If - '从继承版本中获取版本号 - If Not InheritVersion = "" Then - _Version.McName = If(JsonObject("jar"), "").ToString 'LiteLoader 优先使用 Jar - If _Version.McName = "" Then _Version.McName = InheritVersion - GoTo VersionSearchFinish - End If - '从下载地址中获取版本号 - Dim Regex As String = RegexSeek(If(JsonObject("downloads"), "").ToString, "(?<=launcher.mojang.com/mc/game/)[^/]*") - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '从 Forge 版本中获取版本号 - Dim LibrariesString As String = JsonObject("libraries").ToString - Regex = If(RegexSeek(LibrariesString, "(?<=net.minecraftforge:forge:)1.[0-9+.]+"), RegexSeek(LibrariesString, "(?<=net.minecraftforge:fmlloader:)1.[0-9+.]+")) - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '从 OptiFine 版本中获取版本号 - Regex = RegexSeek(LibrariesString, "(?<=optifine:OptiFine:)1.[0-9+.]+") - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '从 Fabric 版本中获取版本号 - Regex = RegexSeek(LibrariesString, "(?<=((fabricmc)|(quiltmc)):intermediary:)[^""]*") - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '从 jar 项中获取版本号 - If JsonObject("jar") IsNot Nothing Then - _Version.McName = JsonObject("jar").ToString - GoTo VersionSearchFinish - End If - '从 jar 文件的 version.json 中获取版本号 - If JsonVersion?("name") IsNot Nothing Then - Dim JsonVerName As String = JsonVersion("name").ToString - If JsonVerName.Length < 32 Then '因为 wiki 说这玩意儿可能是个 hash，虽然我没发现 - _Version.McName = JsonVerName - Log("[Minecraft] 从版本 jar 中的 version.json 获取到版本号：" & JsonVerName) - GoTo VersionSearchFinish - End If - End If - '非准确的版本判断警告 - Log("[Minecraft] 无法完全确认 MC 版本号的版本：" & Name) - '从文件夹名中获取 - Regex = RegexSeek(Name, "([0-9w]{5}[a-z]{1})|(1\.[0-9]+(\.[0-9]+)?(-(pre|rc)[1-9]?| Pre-Release( [1-9]{1})?)?)", RegularExpressions.RegexOptions.IgnoreCase) - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '从 Json 出现的版本号中获取 - Dim JsonRaw As JObject = JsonObject.DeepClone() - JsonRaw.Remove("libraries") - Dim JsonRawText As String = JsonRaw.ToString - Regex = RegexSeek(JsonRawText, "([0-9w]{5}[a-z]{1})|(1\.[0-9]+(\.[0-9]+)?(-(pre|rc)[1-9]?| Pre-Release( [1-9]{1})?)?)", RegularExpressions.RegexOptions.IgnoreCase) - If Regex IsNot Nothing Then - _Version.McName = Regex - GoTo VersionSearchFinish - End If - '无法获取 - _Version.McName = "Unknown" - Info = "PCL 无法识别该版本的 MC 版本号" - Catch ex As Exception - Log(ex, "识别 Minecraft 版本时出错") - _Version.McName = "Unknown" - Info = "无法识别：" & ex.Message + Catch + ReleaseTime = New Date(1970, 1, 1, 15, 0, 0) End Try -VersionSearchFinish: - '获取版本号 - If _Version.McName.StartsWithF("1.") Then - Dim SplitVersion = _Version.McName.Split(" "c, "_"c, "-"c, "."c) - Dim SplitResult As String - '分割获取信息 - SplitResult = If(SplitVersion.Count >= 2, SplitVersion(1), "0") - _Version.McCodeMain = If(SplitResult.Length <= 2, Val(SplitResult), "0") - SplitResult = If(SplitVersion.Count >= 3, SplitVersion(2), "0") - _Version.McCodeSub = If(SplitResult.Length <= 2, Val(SplitResult), "0") - ElseIf _Version.McName = "15w14a" '#6703 - '“15w14a由1.8.3分叉而来” —— Minecraft Wiki - _Version.McCodeMain = 8 - _Version.McCodeSub = 3 - ElseIf (Not IsVersionNameLikeRelease(_Version.McName)) OrElse _Version.McName = "pending" Then - _Version.McCodeMain = 99 - _Version.McCodeSub = 99 + '实验性快照 + If If(JsonObject("type"), "") = "pending" Then + _Version.VanillaName = "pending" + GoTo VersionSearchFinish End If + '从 PCL 下载的版本信息中获取版本号 + If JsonObject("clientVersion") IsNot Nothing Then + _Version.VanillaName = JsonObject("clientVersion") + GoTo VersionSearchFinish + End If + '从 HMCL 下载的版本信息中获取版本号 + If JsonObject("patches") IsNot Nothing Then + For Each Patch As JObject In JsonObject("patches") + If If(Patch("id"), "").ToString = "game" AndAlso Patch("version") IsNot Nothing Then + _Version.VanillaName = Patch("version").ToString + GoTo VersionSearchFinish + End If + Next + End If + '从 Forge / NeoForge Arguments 中获取版本号 + If JsonObject("arguments") IsNot Nothing AndAlso JsonObject("arguments")("game") IsNot Nothing Then + Dim Mark As Boolean = False + For Each Argument In JsonObject("arguments")("game") + If Mark Then + _Version.VanillaName = Argument.ToString + GoTo VersionSearchFinish + End If + If Argument.ToString = "--fml.mcVersion" Then Mark = True + Next + End If + '从继承版本中获取版本号 + If Not InheritName = "" Then + _Version.VanillaName = If(JsonObject("jar"), "").ToString 'LiteLoader 优先使用 Jar + If _Version.VanillaName = "" Then _Version.VanillaName = InheritName + GoTo VersionSearchFinish + End If + '从下载地址中获取版本号 + Dim Regex As String = RegexSeek(If(JsonObject("downloads"), "").ToString, "(?<=launcher.mojang.com/mc/game/)[^/]*") + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '从 Forge 版本中获取版本号 + Dim LibrariesString As String = JsonObject("libraries").ToString + Regex = If(RegexSeek(LibrariesString, "(?<=net.minecraftforge:forge:)[0-9]{1,2}.[0-9+.]+"), RegexSeek(LibrariesString, "(?<=net.minecraftforge:fmlloader:)[0-9]{1,2}.[0-9+.]+")) + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '从 OptiFine 版本中获取版本号 + Regex = RegexSeek(LibrariesString, "(?<=optifine:OptiFine:)[0-9]{1,2}.[0-9+.]+") + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '从 Fabric 版本中获取版本号 + Regex = RegexSeek(LibrariesString, "(?<=((fabricmc)|(quiltmc)):intermediary:)[^""]*") + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '从 jar 项中获取版本号 + If JsonObject("jar") IsNot Nothing Then + _Version.VanillaName = JsonObject("jar").ToString + GoTo VersionSearchFinish + End If + '从 jar 文件的 version.json 中获取版本号 + If JsonVersion?("name") IsNot Nothing Then + Dim JsonVerName As String = JsonVersion("name").ToString + If JsonVerName.Length < 32 Then '因为 wiki 说这玩意儿可能是个 hash，虽然我没发现 + _Version.VanillaName = JsonVerName + Log("[Minecraft] 从版本 jar 中的 version.json 获取到版本号：" & JsonVerName) + GoTo VersionSearchFinish + End If + End If + '从 JSON 的 ID 中获取 + Static Pattern = "(([1-9][0-9]w[0-9]{2}[a-g])|((1|[2-9][0-9])\.[0-9]+(\.[0-9]+)?(-(pre|rc|snapshot-?)[1-9]*| Pre-Release( [1-9])?)?))(_unobfuscated)?" + Regex = RegexSeek(JsonObject("id"), Pattern, RegularExpressions.RegexOptions.IgnoreCase) + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '非准确的版本判断警告 + Log("[Minecraft] 无法完全确认 MC 版本号的版本：" & Name) + _Version.Reliable = False + '从文件夹名中获取 + Regex = RegexSeek(Name, Pattern, RegularExpressions.RegexOptions.IgnoreCase) + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '从 JSON 出现的版本号中获取 + Dim JsonRaw As JObject = JsonObject.DeepClone() + JsonRaw.Remove("libraries") + Dim JsonRawText As String = JsonRaw.ToString + Regex = RegexSeek(JsonRawText, Pattern, RegularExpressions.RegexOptions.IgnoreCase) + If Regex IsNot Nothing Then + _Version.VanillaName = Regex + GoTo VersionSearchFinish + End If + '无法获取 + _Version.VanillaName = "Unknown" + Info = "PCL 无法识别该版本的 MC 版本号" + Catch ex As Exception + Log(ex, "识别 Minecraft 版本时出错") + _Version.VanillaName = "Unknown" + Info = "无法识别：" & ex.Message + End Try #End Region - End If +VersionSearchFinish: + '获取版本号 + _Version.VanillaName = _Version.VanillaName.Replace("_unobfuscated", "").Replace(" Unobfuscated", "") + _Version.Vanilla = McVersion.NameToVersion(_Version.VanillaName) Return _Version End Get - Set(value As McVersionInfo) + Set(value As McVersion) _Version = value End Set End Property - Private _Version As McVersionInfo = Nothing + Private _Version As McVersion = Nothing ''' ''' 版本的发布时间。 ''' Public ReleaseTime As New Date(1970, 1, 1, 15, 0, 0) + ''' + ''' 获取该版本的 JSON 路径。 + ''' + Public Function GetJsonPath() As String + Dim JsonPath As String = PathVersion & Name & ".json" + If Not File.Exists(JsonPath) Then + '尝试寻找 JSON 文件 + JsonPath = Nothing + For Each JsonCandidatePath In Directory.GetFiles(PathVersion, "*.json") + Try + Dim JsonCandidate As JObject = GetJson(ReadFile(JsonCandidatePath)) + If Not JsonCandidate.ContainsKey("mainClass") Then Continue For + If Not JsonCandidate.ContainsKey("type") Then Continue For + If Not JsonCandidate.ContainsKey("id") Then Continue For + Catch + Continue For + End Try + JsonPath = JsonCandidatePath + Exit For + Next + If JsonPath Is Nothing Then + Throw New Exception($"未找到版本 JSON 文件：{PathVersion}{Name}.json") + Else + Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug) + End If + End If + Return JsonPath + End Function ''' ''' 该版本的 Json 文本。 ''' @@ -456,17 +498,7 @@ VersionSearchFinish: Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}") End Function If _JsonText Is Nothing Then - Dim JsonPath As String = Path & Name & ".json" - If Not File.Exists(JsonPath) Then - '如果文件夹下只有一个 JSON 文件，则将其作为版本 JSON - Dim JsonFiles As String() = Directory.GetFiles(Path, "*.json") - If JsonFiles.Count = 1 Then - JsonPath = JsonFiles(0) - Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug) - Else - Throw New Exception($"未找到版本 JSON 文件：{Path}{Name}.json") - End If - End If + Dim JsonPath As String = GetJsonPath() _JsonText = ReadFile(JsonPath) '如果 ReadFile 失败会返回空字符串；这可能是由于文件被临时占用，故延时后重试 If Not FastJsonCheck(_JsonText) Then @@ -508,7 +540,7 @@ VersionSearchFinish: For Each Subjson As JObject In _JsonObject("patches") SubjsonList.Add(Subjson) Next - SubjsonList = SubjsonList.Sort( + SubjsonList = SubjsonList.SortByComparison( Function(Left, Right) Val(If(Left("priority"), "0").ToString) < Val(If(Right("priority"), "0").ToString)) For Each Subjson As JObject In SubjsonList Dim Id As String = Subjson("id") @@ -530,27 +562,33 @@ VersionSearchFinish: If _JsonObject.ContainsKey("inheritsFrom") Then _JsonObject.Remove("inheritsFrom") End If '与继承版本合并 - Dim InheritVersion = Nothing + Dim InstanceNameInheritFrom = Nothing Try - InheritVersion = If(_JsonObject("inheritsFrom") Is Nothing, "", _JsonObject("inheritsFrom").ToString) - If InheritVersion = Name Then + InstanceNameInheritFrom = If(_JsonObject("inheritsFrom") Is Nothing, "", _JsonObject("inheritsFrom").ToString) + If InstanceNameInheritFrom = Name Then Log("[Minecraft] 自引用的继承版本：" & Name, LogLevel.Debug) - InheritVersion = "" + InstanceNameInheritFrom = "" Exit Try End If Recheck: - If InheritVersion <> "" Then - Dim Inherit As New McVersion(InheritVersion) + If InstanceNameInheritFrom <> "" Then + Dim InheritInstance As New McInstance(InstanceNameInheritFrom) '继续循环 - If Inherit.InheritVersion = InheritVersion Then Throw New Exception("版本依赖项出现嵌套：" & InheritVersion) - InheritVersion = Inherit.InheritVersion - '合并 - Inherit.JsonObject.Merge(_JsonObject) - _JsonObject = Inherit.JsonObject + If InheritInstance.InheritName = InstanceNameInheritFrom Then Throw New Exception("版本依赖项出现嵌套：" & InstanceNameInheritFrom) + InstanceNameInheritFrom = InheritInstance.InheritName + '合并 Libraries 项：子版本放在前面，父版本放在后面（5978#：如果多个 jar 包中含有相同的类，Java 8 和之前的版本按照 -cp 指定的顺序选择第一个） + Dim CurrentLib As JArray = _JsonObject("libraries").DeepClone() + For Each LibToken In InheritInstance.JsonObject("libraries") + CurrentLib.Add(LibToken) + Next + '合并其他项：子版本优先于父版本 + InheritInstance.JsonObject.Merge(_JsonObject) + _JsonObject = InheritInstance.JsonObject + _JsonObject("libraries") = CurrentLib GoTo Recheck End If Catch ex As Exception - Log(ex, "合并版本依赖项 JSON 失败（" & If(InheritVersion, "null").ToString & "）") + Log(ex, "合并版本依赖项 JSON 失败（" & If(InstanceNameInheritFrom, "null").ToString & "）") End Try Catch ex As Exception Throw New Exception("初始化版本 JSON 时失败（" & If(Name, "null") & "）", ex) @@ -582,56 +620,55 @@ Recheck: ''' Public ReadOnly Property JsonVersion As JObject Get + Static JsonVersionInited As Boolean = False If Not JsonVersionInited Then JsonVersionInited = True - If File.Exists(Path & Name & ".jar") Then - Try - Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite)) - Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json") - If VersionJson IsNot Nothing Then - Using VersionJsonStream As New StreamReader(VersionJson.Open) - _JsonVersion = GetJson(VersionJsonStream.ReadToEnd) - End Using - End If + Try + If Not File.Exists($"{PathVersion}{Name}.jar") Then Exit Try + Using JarArchive As New ZipArchive(New FileStream(PathVersion & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite)) + Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json") + If VersionJson Is Nothing Then Exit Try + Using VersionJsonStream As New StreamReader(VersionJson.Open) + _JsonVersion = GetJson(VersionJsonStream.ReadToEnd) End Using - Catch ex As Exception - Log(ex, "从版本 jar 中读取 version.json 失败") - End Try - End If + End Using + Catch ex As Exception + Log(ex, $"从版本 jar 中读取 version.json 失败（{PathVersion}{Name}.jar）") + End Try End If Return _JsonVersion End Get End Property - Private JsonVersionInited As Boolean = False Private _JsonVersion As JObject = Nothing ''' ''' 该版本的依赖版本。若无依赖版本则为空字符串。 ''' - Public ReadOnly Property InheritVersion As String + Public ReadOnly Property InheritName As String Get - If _InheritVersion Is Nothing Then - _InheritVersion = If(JsonObject("inheritsFrom"), "").ToString + If _InheritName Is Nothing Then + _InheritName = If(JsonObject("inheritsFrom"), "").ToString '由于过老的 LiteLoader 中没有 Inherits（例如 1.5.2），需要手动判断以获取真实继承版本 '此外，由于这里的加载早于版本种类判断，所以需要手动判断是否为 LiteLoader '如果版本提供了不同的 Jar，代表所需的 Jar 可能已被更改，则跳过 Inherit 替换 - If JsonText.Contains("liteloader") AndAlso Version.McName <> Name AndAlso Not JsonText.Contains("logging") Then - If If(JsonObject("jar"), Version.McName).ToString = Version.McName Then _InheritVersion = Version.McName + If JsonText.Contains("liteloader") AndAlso Version.VanillaName <> Name AndAlso Not JsonText.Contains("logging") Then + If If(JsonObject("jar"), Version.VanillaName).ToString = Version.VanillaName Then _InheritName = Version.VanillaName End If 'HMCL 版本无 Json - If IsHmclFormatJson Then _InheritVersion = "" + If IsHmclFormatJson Then _InheritName = "" End If - Return _InheritVersion + Return _InheritName End Get End Property - Private _InheritVersion As String = Nothing + Private _InheritName As String = Nothing - ''' - ''' 版本名，或版本文件夹的完整路径（不规定是否以 \ 结尾）。 - Public Sub New(Path As String) - Me.Path = If(Path.Contains(":"), "", PathMcFolder & "versions\") & '补全完整路径 - Path & - If(Path.EndsWithF("\"), "", "\") '补全右划线 + ''' + ''' 从版本名，或版本文件夹的完整路径初始化（不规定是否以 \ 结尾）。 + ''' + Public Sub New(Name As String) + PathVersion = If(Name.Contains(":"), "", McFolderSelected & "versions\") & '补全完整路径 + Name & + If(Name.EndsWithF("\"), "", "\") '补全右划线 End Sub ''' @@ -640,217 +677,277 @@ Recheck: Public Function Check() As Boolean '检查文件夹 - If Not Directory.Exists(Path) Then - State = McVersionState.Error + If Not Directory.Exists(PathVersion) Then + State = McInstanceState.Error Info = "未找到版本 " & Name Return False End If '检查权限 Try - Directory.CreateDirectory(Path & "PCL\") - CheckPermissionWithException(Path & "PCL\") + Directory.CreateDirectory(PathVersion & "PCL\") + CheckPermissionWithException(PathVersion & "PCL\") Catch ex As Exception - State = McVersionState.Error + State = McInstanceState.Error Info = "PCL 没有对该文件夹的访问权限，请右键以管理员身份运行 PCL" Log(ex, "没有访问版本文件夹的权限") Return False End Try '确认 Json 可用性 Try - Dim JsonObjCheck = JsonObject + If JsonObject("mainClass") Is Nothing Then Throw New Exception("版本 JSON 中没有 mainClass 项！") '这里也会触发 JsonObject 的 Get 事件 Catch ex As Exception - Log(ex, "版本 JSON 可用性检查失败（" & Path & "）") + Log(ex, "版本 JSON 可用性检查失败（" & PathVersion & "）") JsonText = "" JsonObject = Nothing Info = ex.Message - State = McVersionState.Error + State = McInstanceState.Error + Return False + End Try + '检查版本号获取 + Try + If String.IsNullOrEmpty(Version.VanillaName) Then Throw New Exception("无法获取版本号，结果为空") + Catch ex As Exception + Log(ex, "版本号获取失败（" & Name & "）") + State = McInstanceState.Error + Info = "版本号获取失败：" & ex.GetBrief() Return False End Try '检查依赖版本 Try - If Not InheritVersion = "" Then - If Not File.Exists(GetPathFromFullPath(Path) & InheritVersion & "\" & InheritVersion & ".json") Then - State = McVersionState.Error - Info = "需要安装 " & InheritVersion & " 作为前置版本" + If Not InheritName = "" Then + If Not File.Exists(GetPathFromFullPath(PathVersion) & InheritName & "\" & InheritName & ".json") Then + State = McInstanceState.Error + Info = "需要安装 " & InheritName & " 作为前置版本" Return False End If End If Catch ex As Exception Log(ex, "依赖版本检查出错（" & Name & "）") - State = McVersionState.Error - Info = "未知错误：" & GetExceptionSummary(ex) + State = McInstanceState.Error + Info = "未知错误：" & ex.GetBrief() Return False End Try - State = McVersionState.Original + State = McInstanceState.Original Return True End Function ''' ''' 加载 Minecraft 版本的详细信息。不使用其缓存，且会更新缓存。 ''' - Public Function Load() As McVersion + Public Function Load() As McInstance Try '检查版本，若出错则跳过数据确定阶段 If Not Check() Then GoTo ExitDataLoad #Region "确定版本分类" - Select Case Version.McName '在获取 Version.Original 对象时会完成它的加载 + Select Case Version.VanillaName '在获取 Version.Original 对象时会完成它的加载 Case "Unknown" - State = McVersionState.Error + State = McInstanceState.Error Case "Old" - State = McVersionState.Old + State = McInstanceState.Old Case Else '根据 API 进行筛选 Dim RealJson As String = If(JsonObject, JsonText).ToString '愚人节与快照版本 - If If(JsonObject("type"), "").ToString = "fool" OrElse GetMcFoolName(Version.McName) <> "" Then - State = McVersionState.Fool - ElseIf Version.McName.ContainsF("w", True) OrElse Name.ContainsF("combat", True) OrElse Version.McName.ContainsF("rc", True) OrElse Version.McName.ContainsF("pre", True) OrElse Version.McName.ContainsF("experimental", True) OrElse If(JsonObject("type"), "").ToString = "snapshot" OrElse If(JsonObject("type"), "").ToString = "pending" Then - State = McVersionState.Snapshot + Dim FixedReleaseTime = ReleaseTime.ToUniversalTime().AddHours(2) + Dim JsonType = If(JsonObject("type"), "").ToString + If JsonType = "fool" OrElse + (FixedReleaseTime.Month = 4 AndAlso FixedReleaseTime.Day = 1 AndAlso JsonType = "snapshot") OrElse + GetMcFoolName(Version.VanillaName) <> "" Then + State = McInstanceState.Fool + ElseIf IsSnapshot() Then + State = McInstanceState.Snapshot End If 'OptiFine If RealJson.Contains("optifine") Then - State = McVersionState.OptiFine + State = McInstanceState.OptiFine Version.HasOptiFine = True - Version.OptiFineVersion = If(RegexSeek(RealJson, "(?<=HD_U_)[^"":/]+"), "未知版本") + Version.OptiFine = If(RegexSeek(RealJson, "(?<=HD_U_)[^"":/]+"), "未知版本") End If 'LiteLoader If RealJson.Contains("liteloader") Then - State = McVersionState.LiteLoader + State = McInstanceState.LiteLoader Version.HasLiteLoader = True End If 'Fabric、Forge If RealJson.Contains("net.fabricmc:fabric-loader") OrElse RealJson.Contains("org.quiltmc:quilt-loader") Then - State = McVersionState.Fabric + State = McInstanceState.Fabric Version.HasFabric = True - Version.FabricVersion = If(RegexSeek(RealJson, "(?<=(net.fabricmc:fabric-loader:)|(org.quiltmc:quilt-loader:))[0-9\.]+(\+build.[0-9]+)?"), "未知版本").Replace("+build", "") + Version.Fabric = If(RegexSeek(RealJson, "(?<=(net.fabricmc:fabric-loader:)|(org.quiltmc:quilt-loader:))[0-9\.]+(\+build.[0-9]+)?"), "未知版本").Replace("+build", "") ElseIf RealJson.Contains("minecraftforge") AndAlso Not RealJson.Contains("net.neoforge") Then - State = McVersionState.Forge + State = McInstanceState.Forge Version.HasForge = True - Version.ForgeVersion = RegexSeek(RealJson, "(?<=forge:[0-9\.]+(_pre[0-9]*)?\-)[0-9\.]+") - If Version.ForgeVersion Is Nothing Then Version.ForgeVersion = RegexSeek(RealJson, "(?<=net\.minecraftforge:minecraftforge:)[0-9\.]+") - If Version.ForgeVersion Is Nothing Then Version.ForgeVersion = If(RegexSeek(RealJson, "(?<=net\.minecraftforge:fmlloader:[0-9\.]+-)[0-9\.]+"), "未知版本") + Version.Forge = RegexSeek(RealJson, "(?<=forge:[0-9\.]+(_pre[0-9]*)?\-)[0-9\.]+") + If Version.Forge Is Nothing Then Version.Forge = RegexSeek(RealJson, "(?<=net\.minecraftforge:minecraftforge:)[0-9\.]+") + If Version.Forge Is Nothing Then Version.Forge = If(RegexSeek(RealJson, "(?<=net\.minecraftforge:fmlloader:[0-9\.]+-)[0-9\.]+"), "未知版本") ElseIf RealJson.Contains("net.neoforge") Then '1.20.1 JSON 范例："--fml.forgeVersion", "47.1.99" '1.20.2+ JSON 范例："--fml.neoForgeVersion", "20.6.119-beta" - State = McVersionState.NeoForge + State = McInstanceState.NeoForge Version.HasNeoForge = True - Version.NeoForgeVersion = If(RegexSeek(RealJson, "(?<=orgeVersion"",[^""]*?"")[^""]+(?="",)"), "未知版本") + Version.NeoForge = If(RegexSeek(RealJson, "(?<=orgeVersion"",[^""]*?"")[^""]+(?="",)"), "未知版本") End If - Version.IsApiLoaded = True End Select #End Region ExitDataLoad: '确定版本图标 - Logo = ReadIni(Path & "PCL\Setup.ini", "Logo", "") - If Logo = "" OrElse Not CType(ReadIni(Path & "PCL\Setup.ini", "LogoCustom", False), Boolean) Then + Logo = ReadIni(PathVersion & "PCL\Setup.ini", "Logo", "") + If Logo = "" OrElse Not CType(ReadIni(PathVersion & "PCL\Setup.ini", "LogoCustom", False), Boolean) Then Select Case State - Case McVersionState.Original + Case McInstanceState.Original Logo = PathImage & "Blocks/Grass.png" - Case McVersionState.Snapshot + Case McInstanceState.Snapshot Logo = PathImage & "Blocks/CommandBlock.png" - Case McVersionState.Old + Case McInstanceState.Old Logo = PathImage & "Blocks/CobbleStone.png" - Case McVersionState.Forge + Case McInstanceState.Forge Logo = PathImage & "Blocks/Anvil.png" - Case McVersionState.NeoForge + Case McInstanceState.NeoForge Logo = PathImage & "Blocks/NeoForge.png" - Case McVersionState.Fabric + Case McInstanceState.Fabric Logo = PathImage & "Blocks/Fabric.png" - Case McVersionState.OptiFine + Case McInstanceState.OptiFine Logo = PathImage & "Blocks/GrassPath.png" - Case McVersionState.LiteLoader + Case McInstanceState.LiteLoader Logo = PathImage & "Blocks/Egg.png" - Case McVersionState.Fool + Case McInstanceState.Fool Logo = PathImage & "Blocks/GoldBlock.png" Case Else Logo = PathImage & "Blocks/RedstoneBlock.png" End Select End If '确定版本描述 - Dim CustomInfo As String = ReadIni(Path & "PCL\Setup.ini", "CustomInfo") - Info = If(CustomInfo <> "", CustomInfo, GetDefaultDescription()) - '确定版本收藏状态 - IsStar = ReadIni(Path & "PCL\Setup.ini", "IsStar", False) - '确定版本显示种类 - DisplayType = ReadIni(Path & "PCL\Setup.ini", "DisplayType", McVersionCardType.Auto) - '写入缓存 - If Directory.Exists(Path) Then - WriteIni(Path & "PCL\Setup.ini", "State", State) - WriteIni(Path & "PCL\Setup.ini", "Info", Info) - WriteIni(Path & "PCL\Setup.ini", "Logo", Logo) + Dim CustomInfo As String = ReadIni(PathVersion & "PCL\Setup.ini", "CustomInfo") + If CustomInfo <> "" Then + Info = CustomInfo + Else + Info = VersionDisplayName() + If State = McInstanceState.Fool Then + Info = GetMcFoolName(Version.VanillaName) + ElseIf State <> McInstanceState.Error Then + If Settings.Get("VersionServerLogin", Instance:=Me) = 3 Then Info += ", 统一通行证验证" + If Settings.Get("VersionServerLogin", Instance:=Me) = 4 Then Info += ", Authlib 验证" + End If End If - If State <> McVersionState.Error Then - WriteIni(Path & "PCL\Setup.ini", "ReleaseTime", ReleaseTime.ToString("yyyy'-'MM'-'dd HH':'mm")) - WriteIni(Path & "PCL\Setup.ini", "VersionFabric", Version.FabricVersion) - WriteIni(Path & "PCL\Setup.ini", "VersionOptiFine", Version.OptiFineVersion) - WriteIni(Path & "PCL\Setup.ini", "VersionLiteLoader", Version.HasLiteLoader) - WriteIni(Path & "PCL\Setup.ini", "VersionForge", Version.ForgeVersion) - WriteIni(Path & "PCL\Setup.ini", "VersionNeoForge", Version.NeoForgeVersion) - WriteIni(Path & "PCL\Setup.ini", "VersionApiCode", Version.SortCode) - WriteIni(Path & "PCL\Setup.ini", "VersionOriginal", Version.McName) - WriteIni(Path & "PCL\Setup.ini", "VersionOriginalMain", Version.McCodeMain) - WriteIni(Path & "PCL\Setup.ini", "VersionOriginalSub", Version.McCodeSub) + '确定版本收藏状态 + IsStar = ReadIni(PathVersion & "PCL\Setup.ini", "IsStar", False) + '确定版本显示种类 + DisplayType = ReadIni(PathVersion & "PCL\Setup.ini", "DisplayType", McInstanceCardType.Auto) + '写入缓存 + If Directory.Exists(PathVersion) Then + WriteIni(PathVersion & "PCL\Setup.ini", "State", State) + WriteIni(PathVersion & "PCL\Setup.ini", "Info", Info) + WriteIni(PathVersion & "PCL\Setup.ini", "Logo", Logo) + End If + If State <> McInstanceState.Error AndAlso Version.Reliable Then + WriteIni(PathVersion & "PCL\Setup.ini", "ReleaseTime", ReleaseTime.ToString("yyyy'-'MM'-'dd HH':'mm")) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionFabric", Version.Fabric) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionOptiFine", Version.OptiFine) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionLiteLoader", Version.HasLiteLoader) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionForge", Version.Forge) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionNeoForge", Version.NeoForge) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionVanillaName", Version.VanillaName) + WriteIni(PathVersion & "PCL\Setup.ini", "VersionVanilla", Version.Vanilla.ToString) End If Catch ex As Exception - Info = "未知错误：" & GetExceptionSummary(ex) + Info = "未知错误：" & ex.GetBrief() Logo = PathImage & "Blocks/RedstoneBlock.png" - State = McVersionState.Error + State = McInstanceState.Error Log(ex, "加载版本失败（" & Name & "）", LogLevel.Feedback) Finally IsLoaded = True End Try Return Me End Function - ''' - ''' 获取版本的默认描述。 - ''' - Public Function GetDefaultDescription() As String - Dim Info As String = "" - Select Case State - Case McVersionState.Snapshot - If Version.McName.ContainsF("pre", True) Then - Info = "预发布版 " & Version.McName - ElseIf Version.McName.ContainsF("rc", True) Then - Info = "发布候选 " & Version.McName - ElseIf Version.McName.Contains("experimental") OrElse Version.McName = "pending" Then - Info = "实验性快照" - Else - Info = "快照 " & Version.McName - End If - Case McVersionState.Old - Info = "远古版本" - Case McVersionState.Original, McVersionState.Forge, McVersionState.NeoForge, McVersionState.Fabric, McVersionState.OptiFine, McVersionState.LiteLoader - Info = Version.ToString - Case McVersionState.Fool - Info = GetMcFoolName(Version.McName) - Case McVersionState.Error - Return Me.Info '已有错误信息 - Case Else - Info = "发生了未知错误，请向作者反馈此问题" - End Select - If Not State = McVersionState.Error Then - If Setup.Get("VersionServerLogin", Version:=Me) = 3 Then Info += ", 统一通行证验证" - If Setup.Get("VersionServerLogin", Version:=Me) = 4 Then Info += ", Authlib 验证" - End If - Return Info + Private Function IsSnapshot() As Boolean + Return {"w", "snapshot", "rc", "pre", "experimental", "-"}.Any(Function(s) Version.VanillaName.ContainsF(s, True)) OrElse + Name.ContainsF("combat", True) OrElse + If(JsonObject("type"), "").ToString = "snapshot" OrElse If(JsonObject("type"), "").ToString = "pending" End Function Public IsLoaded As Boolean = False - - Public Overrides Function Equals(obj As Object) As Boolean - Dim version = TryCast(obj, McVersion) - Return version IsNot Nothing AndAlso Path = version.Path + ''' + ''' 获取对版本信息的简短描述。 + ''' 例如 “快照 16w01a”、“原版 1.12.2, Forge 1.2.3”、“愚人节版本 2.0”。 + ''' + Public Function VersionDisplayName() As String + 'Mod Loader 信息 + Dim ModLoaderInfo As String = "" + If Version.HasForge Then ModLoaderInfo += ", Forge" & If(Version.Forge = "未知版本", "", " " & Version.Forge) + If Version.HasNeoForge Then ModLoaderInfo += ", NeoForge" & If(Version.NeoForge = "未知版本", "", " " & Version.NeoForge) + If Version.HasFabric Then ModLoaderInfo += ", Fabric" & If(Version.Fabric = "未知版本", "", " " & Version.Fabric) + If Version.HasOptiFine Then ModLoaderInfo += ", OptiFine" & If(Version.OptiFine = "未知版本", "", " " & Version.OptiFine.Replace("-", " ").Replace("_", " ")) + If Version.HasLiteLoader Then ModLoaderInfo += ", LiteLoader" + '基础信息 + Dim Info As String + Select Case State + Case McInstanceState.Snapshot, McInstanceState.Original, McInstanceState.Forge, McInstanceState.NeoForge, McInstanceState.Fabric, McInstanceState.OptiFine, McInstanceState.LiteLoader + If Version.VanillaName.ContainsF("pre", True) Then + Info = "预发布版 " & Version.VanillaName + ElseIf Version.VanillaName.ContainsF("rc", True) Then + Info = "发布候选 " & Version.VanillaName + ElseIf Version.VanillaName.Contains("experimental") Then + Info = "实验性快照" & Version.VanillaName + ElseIf Version.VanillaName = "pending" Then + Info = "实验性快照" + ElseIf IsSnapshot Then + Info = If(Version.Reliable, "快照版 " & Version.VanillaName.Replace("-snapshot", ""), "快照版") + Else + Info = If(Version.Reliable, "正式版 " & Version.VanillaName, "正式版") + End If + Case McInstanceState.Old + Info = "远古版本" + Case McInstanceState.Fool + Info = "愚人节版本 " & Version.VanillaName + Case McInstanceState.Error + Return Me.Info '已有错误信息 + Case Else + Return "发生了未知错误，请向作者反馈此问题" + End Select + Return (Info & ModLoaderInfo).Replace("_", "-") End Function - Public Shared Operator =(a As McVersion, b As McVersion) As Boolean + + Public Function ToListItem(Optional ContentHandler As Action(Of MyListItem, EventArgs) = Nothing) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + Dim NewItem As New MyListItem With { + .Info = Info, .Height = 42, .Tag = Me, .SnapsToDevicePixels = True, .Type = MyListItem.CheckType.Clickable, + .ContentHandler = ContentHandler + } + '标题 + NewItem.Inlines.Clear() + NewItem.Inlines.Add(New Run(Name)) + If ReadIni(PathVersion & "PCL\Setup.ini", "CustomInfo") <> "" Then '如果版本设置了自定义描述，在标题后面以淡灰色显示其版本号 + NewItem.Inlines.Add(New Run(" | " & VersionDisplayName()) With {.Foreground = New MyColor(215, 215, 215), .FontSize = 12}) + End If + 'Logo + Try + If Logo.EndsWithF("PCL\Logo.png") Then + NewItem.Logo = PathVersion & "PCL\Logo.png" '修复老版本中，存储的自定义 Logo 使用完整路径，导致移动后无法加载的 Bug + Else + NewItem.Logo = Logo + End If + Catch ex As Exception + Log(ex, "加载版本图标失败", LogLevel.Hint) + NewItem.Logo = "pack://application:,,,/images/Blocks/RedstoneBlock.png" + End Try + Return NewItem + End Function) With {.Height = 42} + End Function + + '运算符支持 + Public Overrides Function Equals(obj As Object) As Boolean + Dim version = TryCast(obj, McInstance) + Return version IsNot Nothing AndAlso PathVersion = version.PathVersion + End Function + Public Shared Operator =(a As McInstance, b As McInstance) As Boolean If a Is Nothing AndAlso b Is Nothing Then Return True If a Is Nothing OrElse b Is Nothing Then Return False - Return a.Path = b.Path + Return a.PathVersion = b.PathVersion End Operator - Public Shared Operator <>(a As McVersion, b As McVersion) As Boolean + Public Shared Operator <>(a As McInstance, b As McInstance) As Boolean Return Not (a = b) End Operator - End Class - Public Enum McVersionState + Public Enum McInstanceState [Error] Original Snapshot @@ -864,80 +961,130 @@ ExitDataLoad: End Enum ''' - ''' 某个 Minecraft 实例的版本名、附加组件信息。 + ''' Minecraft 版本号和附加组件信息。 ''' - Public Class McVersionInfo - - ''' - ''' 版本的 API 信息是否已加载。 - ''' - Public IsApiLoaded As Boolean = False + Public Class McVersion '原版 ''' - ''' 原版版本名。如 1.12.2，16w01a。 + ''' 原版版本名。 + ''' 如 26.1，26.1-snapshot-1，1.12.2，16w01a。 ''' - Public McName As String + Public VanillaName As String ''' - ''' 原版主版本号，如 12（For 1.12.2），快照则固定为 99。不可用则为 -1。 + ''' 可比较的三段式原版版本号。 + ''' 对老版本格式，例如 1.20.1，会被转换为 20.0.1。 + ''' 若没有版本号，例如旧快照，则为 9999.0.0。 ''' - Public McCodeMain As Integer = -1 + Public Vanilla As Version ''' - ''' 原版次版本号，如 2（For 1.12.2），快照则固定为 99。不可用则为 -1。 + ''' 指示原版版本号是否可靠（不是通过猜测获取）。 ''' - Public McCodeSub As Integer = -1 + Public Reliable As Boolean = True ''' - ''' 是否为非快照版，且读取到了一个有效的原版版本号。 + ''' 原版版本号是否有效。 ''' - Public ReadOnly Property IsStandardVersion As Boolean + Public ReadOnly Property Vaild As Boolean Get - Return McCodeMain > -1 AndAlso McCodeMain < 99 AndAlso McCodeSub > -1 AndAlso McCodeSub < 99 + Return Vanilla.Major < 1000 End Get End Property ''' - ''' 标准的原版版本号。 - ''' 若为快照版或没有有效版本号，则返回 0。 + ''' 可供比较的原版 Drop 序数。 + ''' 例如 26.3.2 为 263，1.21.5 为 210。 + ''' 若没有版本号，例如旧快照，则直接指定为 209。 ''' - Public ReadOnly Property McVersion As Version + Public ReadOnly Property Drop As Integer Get - If Not IsStandardVersion Then Return New Version(0, 0, 0) - Return New Version(1, McCodeMain, McCodeSub) + Return If(Vaild, Vanilla.Major * 10 + Vanilla.Minor, 209) End Get End Property 'OptiFine ''' - ''' 该版本是否通过 Json 安装了 OptiFine。 + ''' 该版本是否通过 JSON 安装了 OptiFine。 ''' Public HasOptiFine As Boolean = False ''' - ''' OptiFine 版本号，如 C8、C9_pre10。 + ''' OptiFine 版本名，如 C8、C9_pre10。 ''' - Public OptiFineVersion As String = "" + Public OptiFine As String = "" + ''' + ''' 可供比较的 OptiFine 版本序数。 + ''' + Public ReadOnly Property OptiFineCode As Integer + Get + If String.IsNullOrEmpty(OptiFine) OrElse OptiFine = "未知版本" Then Return 0 + '字母编号，如 G2 中的 G（7） + Dim Result As Integer = Asc(OptiFine.Upper.First) - Asc("A"c) + 1 + '末尾数字，如 C5 beta4 中的 5 + Result *= 100 + Result += Val(RegexSeek(Right(OptiFine, OptiFine.Length - 1), "[0-9]+")) + '测试标记（正式版为 99，Pre[x] 为 50+x，Beta[x] 为 x） + Result *= 100 + If OptiFine.ContainsF("pre", True) Then Result += 50 + If OptiFine.ContainsF("pre", True) OrElse OptiFine.ContainsF("beta", True) Then + If Val(Right(OptiFine, 1)) = 0 AndAlso Right(OptiFine, 1) <> "0" Then + Result += 1 '为 pre 或 beta 结尾，视作 1 + Else + Result += Val(RegexSeek(OptiFine.Lower, "(?<=((pre)|(beta)))[0-9]+")) + End If + Else + Result += 99 + End If + Return Result + End Get + End Property - 'Forge + 'Forge/NeoForge ''' ''' 该版本是否安装了 Forge。 ''' Public HasForge As Boolean = False - ''' - ''' Forge 版本号，如 31.1.2、14.23.5.2847。 - ''' - Public ForgeVersion As String = "" - - 'NeoForge - ''' ''' 该版本是否安装了 NeoForge。 ''' Public HasNeoForge As Boolean = False ''' - ''' NeoForge 版本号，如 21.0.2-beta、47.1.79。 + ''' 该版本是否安装了 Forge 或 NeoForge。 ''' - Public NeoForgeVersion As String = "" + Public ReadOnly Property HasForgelike As Boolean + Get + Return HasForge OrElse HasNeoForge + End Get + End Property + ''' + ''' Forge 版本名，如 31.1.2、14.23.5.2847。 + ''' + Public Forge As String = "" + ''' + ''' NeoForge 版本名，如 47.1.79、21.0.2-beta、26.1.0.0-alpha.14+snapshot-11。 + ''' + Public NeoForge As String = "" + ''' + ''' 可供比较的类 Forge 版本序数。 + ''' + Public ReadOnly Property ForgelikeCode As Integer + Get + If Not HasForgelike Then Return 0 + If (String.IsNullOrEmpty(Forge) OrElse Forge = "未知版本") AndAlso + (String.IsNullOrEmpty(NeoForge) OrElse NeoForge = "未知版本") Then Return 0 + Dim Segments = RegexSearch(If(HasForge, Forge, NeoForge), "\d+") + Select Case Segments.Count + Case Is > 4 + Return Val(Segments(0)) * 1000000 + Val(Segments(1)) * 10000 + Val(Segments(3)) + Case 3 + Return Val(Segments(0)) * 1000000 + Val(Segments(1)) * 10000 + Val(Segments(2)) + Case 2 + Return Val(Segments(0)) * 1000000 + Val(Segments(1)) * 10000 + Case Else + Return Val(Segments(0)) * 1000000 + End Select + End Get + End Property 'Fabric @@ -946,9 +1093,9 @@ ExitDataLoad: ''' Public HasFabric As Boolean = False ''' - ''' Fabric 版本号，如 0.7.2.175。 + ''' Fabric 版本名，如 0.7.2.175。 ''' - Public FabricVersion As String = "" + Public Fabric As String = "" 'LiteLoader @@ -957,84 +1104,63 @@ ExitDataLoad: ''' Public HasLiteLoader As Boolean = False - 'API + 'Helpers ''' - ''' 生成对此版本信息的用户友好的描述性字符串。 + ''' 版本字符串是否符合 Minecraft 原版格式，例如 1.x、26.x。 ''' - Public Overrides Function ToString() As String - ToString = "" - If HasForge Then ToString += ", Forge" & If(ForgeVersion = "未知版本", "", " " & ForgeVersion) - If HasNeoForge Then ToString += ", NeoForge" & If(NeoForgeVersion = "未知版本", "", " " & NeoForgeVersion) - If HasFabric Then ToString += ", Fabric" & If(FabricVersion = "未知版本", "", " " & FabricVersion) - If HasOptiFine Then ToString += ", OptiFine" & If(OptiFineVersion = "未知版本", "", " " & OptiFineVersion) - If HasLiteLoader Then ToString += ", LiteLoader" - If ToString = "" Then - Return "原版 " & McName + Public Shared Function IsFormatFit(Version As String) As Boolean + If Version Is Nothing Then Return False + If RegexCheck(Version, "^1\.\d") Then Return True + If Val(RegexSeek(Version, "^[2-9]\d\.\d+")) >= 26 Then Return True + Return False + End Function + ''' + ''' 将版本名转换为 Drop 序数。 + ''' 若无法转换则返回 209。 + ''' + Public Shared Function VersionToDrop(VanillaName As String) As Integer + If VanillaName Is Nothing Then Return 209 + Dim Version = NameToVersion(VanillaName) + If Version.Major >= 1000 Then Return 209 + Return Version.Major * 10 + Version.Minor + End Function + ''' + ''' 将 Drop 序数转换为版本字符串。 + ''' + Public Shared Function DropToVersion(Drop As Integer) As String + If Drop >= 250 Then + Return $"{Drop \ 10}.{Drop Mod 10}" + ElseIf Drop = 209 Then + Log("[Minecraft] 尝试将旧快照版 Drop 序数转换为版本字符串，这不应该发生！" & vbCrLf & GetStackTrace(), LogLevel.Debug) + Return "1.20" Else - Return McName & ToString & If(ModeDebug, " (" & SortCode & "#)", "") + Return $"1.{Drop \ 10}" End If End Function - ''' - ''' 用于排序比较的编号。 + ''' 将版本名转换为可比较的三段式原版版本号。 + ''' 对老版本格式，例如 1.20.3，会被转换为 20.0.3。 + ''' 若没有版本号，例如旧快照，则为 9999.0.0。 ''' - Public Property SortCode As Integer - Get - If _SortCode = -2 Then - '初始化 - Try - If HasFabric Then - If FabricVersion = "未知版本" Then Return 0 - Dim SubVersions = FabricVersion.Split(".") - If SubVersions.Length >= 3 Then - _SortCode = Val(SubVersions(0)) * 10000 + Val(SubVersions(1)) * 100 + Val(SubVersions(2)) - Else - Throw New Exception("无效的 Fabric 版本：" & ForgeVersion) - End If - ElseIf HasForge OrElse HasNeoForge Then - If ForgeVersion = "未知版本" AndAlso NeoForgeVersion = "未知版本" Then Return 0 - Dim SubVersions = If(HasForge, ForgeVersion.Split("."), NeoForgeVersion.Split(".")) - If SubVersions.Length = 4 Then - _SortCode = Val(SubVersions(0)) * 1000000 + Val(SubVersions(1)) * 10000 + Val(SubVersions(3)) - ElseIf SubVersions.Length = 3 Then - _SortCode = Val(SubVersions(0)) * 1000000 + Val(SubVersions(1)) * 10000 + Val(SubVersions(2)) - Else - Throw New Exception("无效的 Neo/Forge 版本：" & ForgeVersion) - End If - ElseIf HasOptiFine Then - If OptiFineVersion = "未知版本" Then Return 0 - '由对应原版次级版本号（2 位）、字母（2 位）、末尾数字（2 位）、测试标记（2 位，正式版为 99，Pre[x] 为 50+x，Beta[x] 为 x）组成 - _SortCode = - If(McCodeSub >= 0, McCodeSub, 0) * 1000000 + '第一段：原版次级版本号（2 位） - (Asc(CType(Left(OptiFineVersion.ToUpper, 1), Char)) - Asc("A"c) + 1) * 10000 + '第二段：字母编号（2 位），如 G2 中的 G（7） - Val(RegexSeek(Right(OptiFineVersion, OptiFineVersion.Length - 1), "[0-9]+")) * 100 '第三段：末尾数字（2 位），如 C5 beta4 中的 5 - '第三段：测试标记 - If OptiFineVersion.ContainsF("pre", True) Then _SortCode += 50 - If OptiFineVersion.ContainsF("pre", True) OrElse OptiFineVersion.ContainsF("beta", True) Then - If Val(Right(OptiFineVersion, 1)) = 0 AndAlso Right(OptiFineVersion, 1) <> "0" Then - _SortCode += 1 '为 pre 或 beta 结尾，视作 1 - Else - _SortCode += Val(RegexSeek(OptiFineVersion.ToLower, "(?<=((pre)|(beta)))[0-9]+")) - End If - Else - _SortCode += 99 - End If - Else - _SortCode = -1 - End If - Catch ex As Exception - _SortCode = -1 - Log(ex, "获取 API 版本信息失败：" & ToString()) - End Try - End If - Return _SortCode - End Get - Set(value As Integer) - _SortCode = value - End Set - End Property - Private _SortCode As Integer = -2 + Public Shared Function NameToVersion(VanillaName As String) As Version + VanillaName = VanillaName.Replace("_unobfuscated", "").Replace(" Unobfuscated", "") + If VanillaName.StartsWithF("1.") Then + Dim Segments = VanillaName.Split(" _-.".ToCharArray) + Return New Version( + Val(If(Segments.Count >= 2, Segments(1), "0")), + 0, + Val(If(Segments.Count >= 3, Segments(2), "0"))) + ElseIf RegexCheck(VanillaName, "^[2-9][0-9]\.") Then + Dim Segments = VanillaName.Split(" _-.".ToCharArray) + Return New Version( + Val(Segments(0)), + Val(If(Segments.Count >= 2, Segments(1), "0")), + Val(If(Segments.Count >= 3, Segments(2), "0"))) + Else + Return New Version(9999, 0, 0) + End If + End Function End Class @@ -1042,7 +1168,7 @@ ExitDataLoad: ''' 根据版本名获取对应的愚人节版本描述。非愚人节版本会返回空字符串。 ''' Public Function GetMcFoolName(Name As String) As String - Name = Name.ToLower + Name = Name.Lower If Name.StartsWithF("2.0") Then Return "2013 | 这个秘密计划了两年的更新将游戏推向了一个新高度！" ElseIf Name = "15w14a" Then @@ -1061,6 +1187,8 @@ ExitDataLoad: Return "2024 | 毒马铃薯一直都被大家忽视和低估，于是我们超级加强了它！" ElseIf Name = "25w14craftmine" Then Return "2025 | 你可以合成任何东西——包括合成你的世界！" + ElseIf Name = "26w14a" Then + Return "2026 | 为什么需要物品栏？让方块们跟着你走吧！" Else Return "" End If @@ -1069,7 +1197,7 @@ ExitDataLoad: ''' ''' 当前按卡片分类的所有版本列表。 ''' - Public McVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion)) + Public McInstanceList As New Dictionary(Of McInstanceCardType, List(Of McInstance)) #End Region @@ -1078,175 +1206,169 @@ ExitDataLoad: ''' ''' 是否要求本次加载强制刷新版本列表。 ''' - Public McVersionListForceRefresh As Boolean = False - ''' - ''' 加载 Minecraft 文件夹的版本列表。 - ''' - Public McVersionListLoader As New LoaderTask(Of String, Integer)("Minecraft Version List", AddressOf McVersionListLoad) With {.ReloadTimeout = 1} - + Public McInstanceListForceRefresh As Boolean = False ''' ''' 是否为本次打开 PCL 后第一次加载版本列表。 ''' 这会清理所有 .pclignore 文件，而非跳过这些对应版本。 ''' - Private IsFirstMcVersionListLoad As Boolean = True + Private IsFirstMcInstanceListLoad As Boolean = True ''' - ''' 开始加载当前 Minecraft 文件夹的版本列表。 + ''' 加载 Minecraft 文件夹的版本列表。 ''' - Private Sub McVersionListLoad(Loader As LoaderTask(Of String, Integer)) + Public McInstanceListLoader As New LoaderTask(Of String, Integer)("Minecraft Instance List", AddressOf InitMcInstanceList) With {.ReloadTimeout = 1} + Private Sub InitMcInstanceList(Loader As LoaderTask(Of String, Integer)) '开始加载 - Dim Path As String = Loader.Input + Dim PathMc As String = Loader.Input Try '初始化 - McVersionList = New Dictionary(Of McVersionCardType, List(Of McVersion)) + McInstanceList = New Dictionary(Of McInstanceCardType, List(Of McInstance)) '检测缓存是否需要更新 Dim FolderList As New List(Of String) - If Directory.Exists(Path & "versions") Then '不要使用 CheckPermission，会导致写入时间改变，从而使得文件夹被强制刷新 + If Directory.Exists(PathMc & "versions") Then '不要使用 CheckPermission，会导致写入时间改变，从而使得文件夹被强制刷新 Try - For Each Folder As DirectoryInfo In New DirectoryInfo(Path & "versions").GetDirectories + For Each Folder As DirectoryInfo In New DirectoryInfo(PathMc & "versions").GetDirectories FolderList.Add(Folder.Name) Next Catch ex As Exception - Throw New Exception("无法读取版本文件夹，可能是由于没有权限（" & Path & "versions）", ex) + Throw New Exception("无法读取版本文件夹，可能是由于没有权限（" & PathMc & "versions）", ex) End Try End If '不可用 If Not FolderList.Any() Then - WriteIni(Path & "PCL.ini", "VersionCache", "") '清空缓存 + WriteIni(PathMc & "PCL.ini", "InstanceCache", "") '清空缓存 GoTo OnLoaded End If '有可用版本 - Dim FolderListCheck As Integer = GetHash(McVersionCacheVersion & "#" & Join(FolderList.ToArray, "#")) Mod (Integer.MaxValue - 1) '根据文件夹名列表生成辨识码 - If Not McVersionListForceRefresh AndAlso Val(ReadIni(Path & "PCL.ini", "VersionCache")) = FolderListCheck Then + Dim FolderListCheck As Integer = GetHash(McInstanceCacheVersion & "#" & FolderList.Join("#"c)) Mod (Integer.MaxValue - 1) '根据文件夹名列表生成辨识码 + If Not McInstanceListForceRefresh AndAlso Val(ReadIni(PathMc & "PCL.ini", "InstanceCache")) = FolderListCheck Then '可以使用缓存 - Dim Result = McVersionListLoadCache(Path) + Dim Result = InitMcInstanceListWithCache(PathMc) If Result Is Nothing Then GoTo Reload Else - McVersionList = Result + McInstanceList = Result End If Else '文件夹列表不符 Reload: - McVersionListForceRefresh = False + McInstanceListForceRefresh = False Log("[Minecraft] 文件夹列表变更，重载所有版本") - WriteIni(Path & "PCL.ini", "VersionCache", FolderListCheck) - McVersionList = McVersionListLoadNoCache(Path) + WriteIni(PathMc & "PCL.ini", "InstanceCache", FolderListCheck) + McInstanceList = InitMcInstanceListWithoutCache(PathMc) End If - IsFirstMcVersionListLoad = False + IsFirstMcInstanceListLoad = False '改变当前选择的版本 OnLoaded: - If Loader.IsAborted Then Return - If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then + If Loader.IsInterrupted Then Return + If McInstanceList.Any(Function(v) v.Key <> McInstanceCardType.Error) Then '尝试读取已储存的选择 - Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version") + Dim SavedSelection As String = ReadIni(PathMc & "PCL.ini", "Version") If SavedSelection <> "" Then - For Each Card As KeyValuePair(Of McVersionCardType, List(Of McVersion)) In McVersionList - For Each Version As McVersion In Card.Value - If Version.Name = SavedSelection AndAlso Not Version.State = McVersionState.Error Then + For Each Card As KeyValuePair(Of McInstanceCardType, List(Of McInstance)) In McInstanceList + For Each Instance As McInstance In Card.Value + If Instance.Name = SavedSelection AndAlso Not Instance.State = McInstanceState.Error Then '使用已储存的选择 - McVersionCurrent = Version - Setup.Set("LaunchVersionSelect", McVersionCurrent.Name) - Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本：" & McVersionCurrent.Path) + McInstanceSelected = Instance + Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本：" & McInstanceSelected.PathVersion) Return End If Next Next End If - If Not McVersionList.First.Value(0).State = McVersionState.Error Then + If Not McInstanceList.First.Value(0).State = McInstanceState.Error Then '自动选择第一项 - McVersionCurrent = McVersionList.First.Value(0) - Setup.Set("LaunchVersionSelect", McVersionCurrent.Name) - Log("[Launch] 自动选择 Minecraft 版本：" & McVersionCurrent.Path) + McInstanceSelected = McInstanceList.First.Value(0) + Log("[Launch] 自动选择 Minecraft 版本：" & McInstanceSelected.PathVersion) End If Else - McVersionCurrent = Nothing - Setup.Set("LaunchVersionSelect", "") + McInstanceSelected = Nothing Log("[Minecraft] 未找到可用 Minecraft 版本") End If - If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 3000)) + If Settings.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 3000)) Catch ex As ThreadInterruptedException Catch ex As Exception - WriteIni(Path & "PCL.ini", "VersionCache", "") '要求下次重新加载 + If Loader.IsInterrupted Then Return '#5617 + WriteIni(PathMc & "PCL.ini", "InstanceCache", "") '要求下次重新加载 Log(ex, "加载 .minecraft 版本列表失败", LogLevel.Feedback) End Try End Sub '获取版本列表 - Private Function McVersionListLoadCache(Path As String) As Dictionary(Of McVersionCardType, List(Of McVersion)) - Dim ResultVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion)) + Private Function InitMcInstanceListWithCache(Path As String) As Dictionary(Of McInstanceCardType, List(Of McInstance)) + Dim Results As New Dictionary(Of McInstanceCardType, List(Of McInstance)) Try Dim CardCount As Integer = ReadIni(Path & "PCL.ini", "CardCount", -1) If CardCount = -1 Then Return Nothing For i = 0 To CardCount - 1 - Dim CardType As McVersionCardType = ReadIni(Path & "PCL.ini", "CardKey" & (i + 1), ":") - Dim VersionList As New List(Of McVersion) + Dim CardType As McInstanceCardType = ReadIni(Path & "PCL.ini", "CardKey" & (i + 1), ":") + Dim InstanceList As New List(Of McInstance) '循环读取版本 For Each Folder As String In ReadIni(Path & "PCL.ini", "CardValue" & (i + 1), ":").Split(":") If Folder = "" Then Continue For - Dim VersionFolder As String = $"{Path}versions\{Folder}\" - If File.Exists(VersionFolder & ".pclignore") Then - If IsFirstMcVersionListLoad Then - Log("[Minecraft] 清理残留的忽略项目：" & VersionFolder) '#2781 - File.Delete(VersionFolder & ".pclignore") + Dim FolderVersions As String = $"{Path}versions\{Folder}\" + If File.Exists(FolderVersions & ".pclignore") Then + If IsFirstMcInstanceListLoad Then + Log("[Minecraft] 清理残留的忽略项目：" & FolderVersions) '#2781 + File.Delete(FolderVersions & ".pclignore") Else - Log("[Minecraft] 跳过要求忽略的项目：" & VersionFolder) + Log("[Minecraft] 跳过要求忽略的项目：" & FolderVersions) Continue For End If End If Try '读取单个版本 - Dim Version As New McVersion(VersionFolder) - VersionList.Add(Version) - Version.Info = ReadIni(Version.Path & "PCL\Setup.ini", "CustomInfo", "") - If Version.Info = "" Then Version.Info = ReadIni(Version.Path & "PCL\Setup.ini", "Info", Version.Info) - Version.Logo = ReadIni(Version.Path & "PCL\Setup.ini", "Logo", Version.Logo) - Version.ReleaseTime = ReadIni(Version.Path & "PCL\Setup.ini", "ReleaseTime", Version.ReleaseTime) - Version.State = ReadIni(Version.Path & "PCL\Setup.ini", "State", Version.State) - Version.IsStar = ReadIni(Version.Path & "PCL\Setup.ini", "IsStar", False) - Version.DisplayType = ReadIni(Path & "PCL\Setup.ini", "DisplayType", McVersionCardType.Auto) - If Version.State <> McVersionState.Error AndAlso - ReadIni(Version.Path & "PCL\Setup.ini", "VersionOriginal", "Unknown") <> "Unknown" Then '旧版本可能没有这一项，导致 Version 不加载（#643） - Dim VersionInfo As New McVersionInfo With { - .FabricVersion = ReadIni(Version.Path & "PCL\Setup.ini", "VersionFabric", ""), - .ForgeVersion = ReadIni(Version.Path & "PCL\Setup.ini", "VersionForge", ""), - .NeoForgeVersion = ReadIni(Version.Path & "PCL\Setup.ini", "VersionNeoForge", ""), - .OptiFineVersion = ReadIni(Version.Path & "PCL\Setup.ini", "VersionOptiFine", ""), - .HasLiteLoader = ReadIni(Version.Path & "PCL\Setup.ini", "VersionLiteLoader", False), - .SortCode = ReadIni(Version.Path & "PCL\Setup.ini", "VersionApiCode", -1), - .McName = ReadIni(Version.Path & "PCL\Setup.ini", "VersionOriginal", "Unknown"), - .McCodeMain = ReadIni(Version.Path & "PCL\Setup.ini", "VersionOriginalMain", -1), - .McCodeSub = ReadIni(Version.Path & "PCL\Setup.ini", "VersionOriginalSub", -1), - .IsApiLoaded = True + Dim Instance As New McInstance(FolderVersions) + InstanceList.Add(Instance) + Instance.Info = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "CustomInfo", "") + If Instance.Info = "" Then Instance.Info = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "Info", Instance.Info) + Instance.Logo = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "Logo", Instance.Logo) + Instance.ReleaseTime = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "ReleaseTime", Instance.ReleaseTime) + Instance.State = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "State", Instance.State) + Instance.IsStar = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "IsStar", False) + Instance.DisplayType = ReadIni(Path & "PCL\Setup.ini", "DisplayType", McInstanceCardType.Auto) + If Instance.State <> McInstanceState.Error AndAlso + ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionVanillaName", "Unknown") <> "Unknown" Then + '读取版本信息 + Dim VersionInfo As New McVersion With { + .Fabric = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionFabric", ""), + .Forge = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionForge", ""), + .NeoForge = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionNeoForge", ""), + .OptiFine = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionOptiFine", ""), + .HasLiteLoader = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionLiteLoader", False), + .VanillaName = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionVanillaName", "Unknown"), + .Vanilla = New Version(ReadIni(Instance.PathVersion & "PCL\Setup.ini", "VersionVanilla", "0.0.0")) } - VersionInfo.HasFabric = VersionInfo.FabricVersion.Any() - VersionInfo.HasForge = VersionInfo.ForgeVersion.Any() - VersionInfo.HasNeoForge = VersionInfo.NeoForgeVersion.Any() - VersionInfo.HasOptiFine = VersionInfo.OptiFineVersion.Any() - Version.Version = VersionInfo + VersionInfo.HasFabric = VersionInfo.Fabric.Any() + VersionInfo.HasForge = VersionInfo.Forge.Any() + VersionInfo.HasNeoForge = VersionInfo.NeoForge.Any() + VersionInfo.HasOptiFine = VersionInfo.OptiFine.Any() + Instance.Version = VersionInfo + Else + Instance.Load() End If '重新检查错误版本 - If Version.State = McVersionState.Error Then - '重新获取版本错误信息 - Dim OldDesc As String = Version.Info - Version.State = McVersionState.Original - Version.Check() + If Instance.State = McInstanceState.Error Then + '重新尝试获取版本信息 + Dim OldDesc As String = Instance.Info + Instance.State = McInstanceState.Original + Instance.Check() '校验错误原因是否改变 - Dim CustomInfo As String = ReadIni(Version.Path & "PCL\Setup.ini", "CustomInfo") - If Version.State = McVersionState.Original OrElse (CustomInfo = "" AndAlso Not OldDesc = Version.Info) Then - Log("[Minecraft] 版本 " & Version.Name & " 的错误状态已变更，新的状态为：" & Version.Info) + Dim CustomInfo As String = ReadIni(Instance.PathVersion & "PCL\Setup.ini", "CustomInfo") + If Instance.State = McInstanceState.Original OrElse (CustomInfo = "" AndAlso Not OldDesc = Instance.Info) Then + Log("[Minecraft] 版本 " & Instance.Name & " 的错误状态已变更，新的状态为：" & Instance.Info) Return Nothing End If End If '校验未加载的版本 - If Version.Logo = "" Then - Log("[Minecraft] 版本 " & Version.Name & " 未被加载") + If Instance.Logo = "" Then + Log("[Minecraft] 版本 " & Instance.Name & " 未被加载") Return Nothing End If @@ -1256,16 +1378,16 @@ OnLoaded: End Try Next - If VersionList.Any Then ResultVersionList.Add(CardType, VersionList) + If InstanceList.Any Then Results.Add(CardType, InstanceList) Next - Return ResultVersionList + Return Results Catch ex As Exception Log(ex, "读取版本缓存失败") Return Nothing End Try End Function - Private Function McVersionListLoadNoCache(Path As String) As Dictionary(Of McVersionCardType, List(Of McVersion)) - Dim VersionList As New List(Of McVersion) + Private Function InitMcInstanceListWithoutCache(Path As String) As Dictionary(Of McInstanceCardType, List(Of McInstance)) + Dim InstanceList As New List(Of McInstance) #Region "循环加载每个版本的信息" For Each Folder As DirectoryInfo In New DirectoryInfo(Path & "versions").GetDirectories @@ -1279,7 +1401,7 @@ OnLoaded: End If Dim VersionFolder As String = Folder.FullName & "\" If File.Exists(VersionFolder & ".pclignore") Then - If IsFirstMcVersionListLoad Then + If IsFirstMcInstanceListLoad Then Log("[Minecraft] 清理残留的忽略项目：" & VersionFolder) '#2781 File.Delete(VersionFolder & ".pclignore") Else @@ -1287,238 +1409,193 @@ OnLoaded: Continue For End If End If - Dim Version As New McVersion(VersionFolder) - VersionList.Add(Version) - Version.Load() + Dim Instance As New McInstance(VersionFolder) + InstanceList.Add(Instance) + Instance.Load() Next #End Region - Dim ResultVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion)) + Dim Results As New Dictionary(Of McInstanceCardType, List(Of McInstance)) #Region "将版本分类到各个卡片" Try '未经过自定义的版本列表 - Dim VersionListOriginal As New Dictionary(Of McVersionCardType, List(Of McVersion)) + Dim InstanceListOriginal As New Dictionary(Of McInstanceCardType, List(Of McInstance)) '单独列出收藏的版本 - Dim StaredVersions As New List(Of McVersion) - For Each Version As McVersion In VersionList.ToList - If Version.IsStar AndAlso Not Version.DisplayType = McVersionCardType.Hidden Then - StaredVersions.Add(Version) - VersionList.Remove(Version) - End If + Dim InstanceStar As New List(Of McInstance) + For Each Instance As McInstance In InstanceList.ToList + If Not Instance.IsStar Then Continue For + If Instance.DisplayType = McInstanceCardType.Hidden Then Continue For + InstanceStar.Add(Instance) + InstanceList.Remove(Instance) Next - If StaredVersions.Any Then VersionListOriginal.Add(McVersionCardType.Star, StaredVersions) + If InstanceStar.Any Then InstanceListOriginal.Add(McInstanceCardType.Star, InstanceStar) '预先筛选出愚人节和错误的版本 - McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Error}, McVersionCardType.Error) - McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Fool}, McVersionCardType.Fool) + McInstanceFilter(InstanceList, InstanceListOriginal, {McInstanceState.Error}, McInstanceCardType.Error) + McInstanceFilter(InstanceList, InstanceListOriginal, {McInstanceState.Fool}, McInstanceCardType.Fool) '筛选 API 版本 - McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Forge, McVersionState.NeoForge, McVersionState.LiteLoader, McVersionState.Fabric}, McVersionCardType.API) + McInstanceFilter(InstanceList, InstanceListOriginal, {McInstanceState.Forge, McInstanceState.NeoForge, McInstanceState.LiteLoader, McInstanceState.Fabric}, McInstanceCardType.API) '将老版本预先分类入不常用，只剩余原版、快照、OptiFine - Dim VersionUseful As New List(Of McVersion) - Dim VersionRubbish As New List(Of McVersion) - McVersionFilter(VersionList, {McVersionState.Old}, VersionRubbish) + Dim InstanceUseful As New List(Of McInstance) + Dim InstanceRubbish As New List(Of McInstance) + McInstanceFilter(InstanceList, {McInstanceState.Old}, InstanceRubbish) '确认最新版本，若为快照则加入常用列表 - Dim LargestVersion As McVersion = Nothing '最新的版本 - For Each Version As McVersion In VersionList - If Version.State = McVersionState.Original OrElse Version.State = McVersionState.Snapshot Then - If LargestVersion Is Nothing OrElse Version.ReleaseTime > LargestVersion.ReleaseTime Then LargestVersion = Version - End If - Next - If LargestVersion IsNot Nothing AndAlso LargestVersion.State = McVersionState.Snapshot Then - VersionUseful.Add(LargestVersion) - VersionList.Remove(LargestVersion) + Dim LargestInstance As McInstance = InstanceList. + Where(Function(v) v.State = McInstanceState.Original OrElse v.State = McInstanceState.Snapshot). + MaxBy(Function(v) v.ReleaseTime) + If LargestInstance IsNot Nothing AndAlso LargestInstance.State = McInstanceState.Snapshot Then + InstanceUseful.Add(LargestInstance) + InstanceList.Remove(LargestInstance) End If '将剩余的快照全部拖进不常用列表 - McVersionFilter(VersionList, {McVersionState.Snapshot}, VersionRubbish) + McInstanceFilter(InstanceList, {McInstanceState.Snapshot}, InstanceRubbish) - '获取每个大版本下最新的原版与 OptiFine - Dim NewerVersion As New Dictionary(Of String, McVersion) - Dim ExistVersion As New List(Of Integer) - For Each Version As McVersion In VersionList - If Version.Version.McCodeMain < 2 Then Continue For '未获取成功的版本 - If Not ExistVersion.Contains(Version.Version.McCodeMain) Then ExistVersion.Add(Version.Version.McCodeMain) - If NewerVersion.ContainsKey(Version.Version.McCodeMain & "-" & Version.State) Then - If Version.Version.HasOptiFine Then - 'OptiFine 根据排序识别号判断 - If Version.Version.SortCode > NewerVersion(Version.Version.McCodeMain & "-" & Version.State).Version.SortCode Then NewerVersion(Version.Version.McCodeMain & "-" & Version.State) = Version - Else - '原版根据发布时间判断 - If Version.ReleaseTime > NewerVersion(Version.Version.McCodeMain & "-" & Version.State).ReleaseTime Then NewerVersion(Version.Version.McCodeMain & "-" & Version.State) = Version - End If + '获取每个 Drop 下最新的原版与 OptiFine + Dim NewerInstance As New Dictionary(Of String, McInstance) + Dim ExistDrops As New List(Of Integer) + For Each Instance As McInstance In InstanceList + If Not Instance.Version.Vaild Then Continue For + If Not ExistDrops.Contains(Instance.Version.Drop) Then ExistDrops.Add(Instance.Version.Drop) + Dim Key As String = Instance.Version.Drop & "-" & Instance.State + If Not NewerInstance.ContainsKey(Key) Then + NewerInstance.Add(Key, Instance) + Continue For + End If + If Instance.Version.HasOptiFine Then + If Instance.Version.OptiFineCode > NewerInstance(Key).Version.OptiFineCode Then NewerInstance(Key) = Instance 'OptiFine 根据版本号判断 Else - NewerVersion.Add(Version.Version.McCodeMain & "-" & Version.State, Version) + If Instance.ReleaseTime > NewerInstance(Key).ReleaseTime Then NewerInstance(Key) = Instance '原版根据发布时间判断 End If Next - '将每个大版本下的最常规版本加入 - For Each Code As Integer In ExistVersion - If NewerVersion.ContainsKey(Code & "-" & McVersionState.OptiFine) AndAlso NewerVersion.ContainsKey(Code & "-" & McVersionState.Original) Then + '将每个 Drop 下的最常规版本加入 + For Each Drop As Integer In ExistDrops + If NewerInstance.ContainsKey(Drop & "-" & McInstanceState.OptiFine) AndAlso NewerInstance.ContainsKey(Drop & "-" & McInstanceState.Original) Then '同时存在 OptiFine 与原版 - Dim OriginalVersion As McVersion = NewerVersion(Code & "-" & McVersionState.Original) - Dim OptiFineVersion As McVersion = NewerVersion(Code & "-" & McVersionState.OptiFine) - If OriginalVersion.Version.McCodeSub > OptiFineVersion.Version.McCodeSub Then + Dim VanillaInstance As McInstance = NewerInstance(Drop & "-" & McInstanceState.Original) + Dim OptiFineInstance As McInstance = NewerInstance(Drop & "-" & McInstanceState.OptiFine) + If VanillaInstance.Version.Drop > OptiFineInstance.Version.Drop Then '仅在原版比 OptiFine 更新时才加入原版 - VersionUseful.Add(OriginalVersion) - VersionList.Remove(OriginalVersion) + InstanceUseful.Add(VanillaInstance) + InstanceList.Remove(VanillaInstance) End If - VersionUseful.Add(OptiFineVersion) - VersionList.Remove(OptiFineVersion) - ElseIf NewerVersion.ContainsKey(Code & "-" & McVersionState.OptiFine) Then + InstanceUseful.Add(OptiFineInstance) + InstanceList.Remove(OptiFineInstance) + ElseIf NewerInstance.ContainsKey(Drop & "-" & McInstanceState.OptiFine) Then '没有原版，直接加入 OptiFine - VersionUseful.Add(NewerVersion(Code & "-" & McVersionState.OptiFine)) - VersionList.Remove(NewerVersion(Code & "-" & McVersionState.OptiFine)) - ElseIf NewerVersion.ContainsKey(Code & "-" & McVersionState.Original) Then + InstanceUseful.Add(NewerInstance(Drop & "-" & McInstanceState.OptiFine)) + InstanceList.Remove(NewerInstance(Drop & "-" & McInstanceState.OptiFine)) + ElseIf NewerInstance.ContainsKey(Drop & "-" & McInstanceState.Original) Then '没有 OptiFine，直接加入原版 - VersionUseful.Add(NewerVersion(Code & "-" & McVersionState.Original)) - VersionList.Remove(NewerVersion(Code & "-" & McVersionState.Original)) + InstanceUseful.Add(NewerInstance(Drop & "-" & McInstanceState.Original)) + InstanceList.Remove(NewerInstance(Drop & "-" & McInstanceState.Original)) End If Next '将剩余的东西添加进去 - VersionRubbish.AddRange(VersionList) - If VersionUseful.Any Then VersionListOriginal.Add(McVersionCardType.OriginalLike, VersionUseful) - If VersionRubbish.Any Then VersionListOriginal.Add(McVersionCardType.Rubbish, VersionRubbish) + InstanceRubbish.AddRange(InstanceList) + If InstanceUseful.Any Then InstanceListOriginal.Add(McInstanceCardType.OriginalLike, InstanceUseful) + If InstanceRubbish.Any Then InstanceListOriginal.Add(McInstanceCardType.Rubbish, InstanceRubbish) '按照自定义版本分类重新添加 - For Each VersionPair In VersionListOriginal - For Each Version As McVersion In VersionPair.Value - Dim RealType = If(Version.DisplayType = 0 OrElse VersionPair.Key = McVersionCardType.Star, VersionPair.Key, Version.DisplayType) - If Not ResultVersionList.ContainsKey(RealType) Then ResultVersionList.Add(RealType, New List(Of McVersion)) - ResultVersionList(RealType).Add(Version) + For Each InstancePair In InstanceListOriginal + For Each Instance As McInstance In InstancePair.Value + Dim RealType = If(Instance.DisplayType = 0 OrElse InstancePair.Key = McInstanceCardType.Star, InstancePair.Key, Instance.DisplayType) + If Not Results.ContainsKey(RealType) Then Results.Add(RealType, New List(Of McInstance)) + Results(RealType).Add(Instance) Next Next Catch ex As Exception - ResultVersionList.Clear() + Results.Clear() Log(ex, "分类版本列表失败", LogLevel.Feedback) End Try #End Region #Region "对卡片与版本进行排序" - '对卡片进行整体排序 - Dim SortedVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion)) - For Each SortRule As String In {McVersionCardType.Star, McVersionCardType.API, McVersionCardType.OriginalLike, McVersionCardType.Rubbish, McVersionCardType.Fool, McVersionCardType.Error, McVersionCardType.Hidden} - If ResultVersionList.ContainsKey(SortRule) Then SortedVersionList.Add(SortRule, ResultVersionList(SortRule)) + '卡片排序 + Dim SortedInstanceList As New Dictionary(Of McInstanceCardType, List(Of McInstance)) + For Each SortRule As String In {McInstanceCardType.Star, McInstanceCardType.API, McInstanceCardType.OriginalLike, McInstanceCardType.Rubbish, McInstanceCardType.Fool, McInstanceCardType.Error, McInstanceCardType.Hidden} + If Results.ContainsKey(SortRule) Then SortedInstanceList.Add(SortRule, Results(SortRule)) Next - ResultVersionList = SortedVersionList + Results = SortedInstanceList - '常规版本：快照放在最上面，此后按版本号从高到低排序 - If ResultVersionList.ContainsKey(McVersionCardType.OriginalLike) Then - Dim OldList As List(Of McVersion) = ResultVersionList(McVersionCardType.OriginalLike) - '提取快照 - Dim Snapshot As McVersion = Nothing - For Each Version As McVersion In OldList - If Version.State = McVersionState.Snapshot Then - Snapshot = Version - Exit For - End If - Next - If Not IsNothing(Snapshot) Then OldList.Remove(Snapshot) - '按版本号排序 - Dim NewList As List(Of McVersion) = OldList.OrderByDescending(Function(v) v.Version.McCodeMain).ToList - '回设 - If Not IsNothing(Snapshot) Then NewList.Insert(0, Snapshot) - ResultVersionList(McVersionCardType.OriginalLike) = NewList - End If - - '不常用版本：按发布时间新旧排序，如果不可用则按名称排序 - If ResultVersionList.ContainsKey(McVersionCardType.Rubbish) Then - ResultVersionList(McVersionCardType.Rubbish) = ResultVersionList(McVersionCardType.Rubbish).Sort( - Function(Left As McVersion, Right As McVersion) - Dim LeftYear As Integer = Left.ReleaseTime.Year '+ If(Left.State = McVersionState.Original OrElse Left.Version.HasOptiFine, 100, 0) - Dim RightYear As Integer = Right.ReleaseTime.Year '+ If(Right.State = McVersionState.Original OrElse Left.Version.HasOptiFine, 100, 0) - If LeftYear > 2000 AndAlso RightYear > 2000 Then - If LeftYear <> RightYear Then - Return LeftYear > RightYear - Else - Return Left.ReleaseTime > Right.ReleaseTime - End If - ElseIf LeftYear > 2000 AndAlso RightYear < 2000 Then - Return True - ElseIf LeftYear < 2000 AndAlso RightYear > 2000 Then - Return False - Else - Return Left.Name > Right.Name - End If + '版本排序 + For Each CardType In {McInstanceCardType.Star, McInstanceCardType.API, McInstanceCardType.OriginalLike, McInstanceCardType.Rubbish, McInstanceCardType.Fool} + If Not Results.ContainsKey(CardType) Then Continue For + Dim GetComponentCode = + Function(Instance As McInstance) As Integer + If Instance.Version.ForgelikeCode > 0 Then Return Instance.Version.ForgelikeCode + If Instance.Version.HasOptiFine Then Return Instance.Version.OptiFineCode + Return 0 + End Function + Results(CardType) = Results(CardType).SortByComparison( + Function(Left As McInstance, Right As McInstance) + '发布时间 + If (Left.ReleaseTime.Year >= 2000 OrElse Right.ReleaseTime.Year >= 2000) AndAlso + Left.ReleaseTime <> Right.ReleaseTime Then Return Left.ReleaseTime > Right.ReleaseTime + '附加组件种类 + If Left.Version.HasFabric <> Right.Version.HasFabric Then Return Left.Version.HasFabric + If Left.Version.HasNeoForge <> Right.Version.HasNeoForge Then Return Left.Version.HasNeoForge + If Left.Version.HasForge <> Right.Version.HasForge Then Return Left.Version.HasForge + If Left.Version.HasOptiFine <> Right.Version.HasOptiFine Then Return Left.Version.HasOptiFine + If Left.Version.HasLiteLoader <> Right.Version.HasLiteLoader Then Return Left.Version.HasLiteLoader + '附加组件版本 + If GetComponentCode(Left) <> GetComponentCode(Right) Then Return GetComponentCode(Left) > GetComponentCode(Right) + '名称 + Return Left.Name > Right.Name End Function) - End If - - 'API 版本：优先按版本排序，此后【先放 Fabric，再放 Neo/Forge（按版本号从高到低排序），最后放 LiteLoader（按名称排序）】 - If ResultVersionList.ContainsKey(McVersionCardType.API) Then - ResultVersionList(McVersionCardType.API) = ResultVersionList(McVersionCardType.API).Sort( - Function(Left As McVersion, Right As McVersion) - Dim Basic = VersionSortInteger(Left.Version.McName, Right.Version.McName) - If Basic <> 0 Then - Return Basic > 0 - Else - If Left.Version.HasFabric Xor Right.Version.HasFabric Then - Return Left.Version.HasFabric - ElseIf Left.Version.HasNeoForge Xor Right.Version.HasNeoForge Then - Return Left.Version.HasNeoForge - ElseIf Left.Version.HasForge Xor Right.Version.HasForge Then - Return Left.Version.HasForge - ElseIf Not Left.Version.SortCode <> Right.Version.SortCode Then - Return Left.Version.SortCode > Right.Version.SortCode - Else - Return Left.Name > Right.Name - End If - End If - End Function) - End If + Next #End Region #Region "保存卡片缓存" - WriteIni(Path & "PCL.ini", "CardCount", ResultVersionList.Count) - For i = 0 To ResultVersionList.Count - 1 - WriteIni(Path & "PCL.ini", "CardKey" & (i + 1), ResultVersionList.Keys(i)) + WriteIni(Path & "PCL.ini", "CardCount", Results.Count) + For i = 0 To Results.Count - 1 + WriteIni(Path & "PCL.ini", "CardKey" & (i + 1), Results.Keys(i)) Dim Value As String = "" - For Each Version As McVersion In ResultVersionList.Values(i) - Value += Version.Name & ":" + For Each Instance As McInstance In Results.Values(i) + Value += Instance.Name & ":" Next WriteIni(Path & "PCL.ini", "CardValue" & (i + 1), Value) Next #End Region - Return ResultVersionList + Return Results End Function ''' ''' 筛选特定种类的版本，并直接添加为卡片。 ''' - ''' 用于筛选的列表。 + ''' 用于筛选的列表。 ''' 需要筛选出的版本类型。-2 代表隐藏的版本。 ''' 卡片的名称。 - Private Sub McVersionFilter(ByRef VersionList As List(Of McVersion), ByRef Target As Dictionary(Of McVersionCardType, List(Of McVersion)), Formula As McVersionState(), CardType As McVersionCardType) - Dim KeepList = VersionList.Where(Function(v) Formula.Contains(v.State)).ToList + Private Sub McInstanceFilter(ByRef InstanceList As List(Of McInstance), ByRef Target As Dictionary(Of McInstanceCardType, List(Of McInstance)), Formula As McInstanceState(), CardType As McInstanceCardType) + Dim KeepList = InstanceList.Where(Function(v) Formula.Contains(v.State)).ToList '加入版本列表，并从剩余中删除 If KeepList.Any Then Target.Add(CardType, KeepList) - For Each Version As McVersion In KeepList - VersionList.Remove(Version) - Next + InstanceList = InstanceList.Except(KeepList).ToList() End If End Sub ''' ''' 筛选特定种类的版本，并增加入一个已有列表中。 ''' - ''' 用于筛选的列表。 + ''' 用于筛选的列表。 ''' 需要筛选出的版本类型。-2 代表隐藏的版本。 ''' 传入需要增加入的列表。 - Private Sub McVersionFilter(ByRef VersionList As List(Of McVersion), Formula As McVersionState(), ByRef KeepList As List(Of McVersion)) - KeepList.AddRange(VersionList.Where(Function(v) Formula.Contains(v.State))) + Private Sub McInstanceFilter(ByRef InstanceList As List(Of McInstance), Formula As McInstanceState(), ByRef KeepList As List(Of McInstance)) + KeepList.AddRange(InstanceList.Where(Function(v) Formula.Contains(v.State))) '加入版本列表，并从剩余中删除 If KeepList.Any Then - For Each Version As McVersion In KeepList - VersionList.Remove(Version) - Next + InstanceList = InstanceList.Except(KeepList).ToList() End If End Sub - Public Enum McVersionCardType + Public Enum McInstanceCardType Star = -1 Auto = 0 '仅用于强制版本分类的自动 Hidden = 1 @@ -1542,19 +1619,19 @@ OnLoaded: ''' 要求玩家选择一个皮肤文件，并进行相关校验。 ''' Public Function McSkinSelect() As McSkinInfo - Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.webp)|*.png;*.jpg;*.webp", "选择皮肤文件") + Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.jpeg;*.webp)|*.png;*.jpg;*.jpeg;*.webp", "选择皮肤文件") '验证有效性 If FileName = "" Then Return New McSkinInfo With {.IsVaild = False} Try Dim Image As New MyBitmap(FileName) If Image.Pic.Width <> 64 OrElse Not (Image.Pic.Height = 32 OrElse Image.Pic.Height = 64) Then - Hint("皮肤图片大小应为 64x32 像素或 64x64 像素！", HintType.Critical) + Hint("皮肤图片大小应为 64x32 像素或 64x64 像素！", HintType.Red) Return New McSkinInfo With {.IsVaild = False} End If Dim FileInfo As New FileInfo(FileName) If FileInfo.Length > 24 * 1024 Then - Hint("皮肤文件大小需小于 24 KB，而所选文件大小为 " & Math.Round(FileInfo.Length / 1024, 2) & " KB", HintType.Critical) + Hint("皮肤文件大小需小于 24 KB，而所选文件大小为 " & Math.Round(FileInfo.Length / 1024, 2) & " KB", HintType.Red) Return New McSkinInfo With {.IsVaild = False} End If Catch ex As Exception @@ -1575,11 +1652,11 @@ OnLoaded: ''' ''' 获取 Uuid 对应的皮肤文件地址，失败将抛出异常。 ''' - Public Function McSkinGetAddress(Uuid As String, Type As String) As String - If Uuid = "" Then Throw New Exception("Uuid 为空。") - If Uuid.StartsWithF("00000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。") + Public Function McSkinGetAddress(UUID As String, Type As String) As String + If UUID = "" Then Throw New Exception("UUID 为空。") + If UUID.StartsWithF("00000") AndAlso Type <> "Auth" Then Throw New Exception("离线 UUID 无正版皮肤文件：" & UUID) '尝试读取缓存 - Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid) + Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID) If Not CacheSkinAddress = "" Then Return CacheSkinAddress '获取皮肤地址 Dim Url As String @@ -1587,13 +1664,13 @@ OnLoaded: Case "Mojang", "Ms" Url = "https://sessionserver.mojang.com/session/minecraft/profile/" Case "Nide" - Url = "https://auth.mc-user.com:233/" & If(McVersionCurrent Is Nothing, Setup.Get("CacheNideServer"), Setup.Get("VersionServerNide", Version:=McVersionCurrent)) & "/sessionserver/session/minecraft/profile/" + Url = "https://auth.mc-user.com:233/" & If(McInstanceSelected Is Nothing, Settings.Get("CacheNideServer"), Settings.Get("VersionServerNide", Instance:=McInstanceSelected)) & "/sessionserver/session/minecraft/profile/" Case "Auth" - Url = If(McVersionCurrent Is Nothing, Setup.Get("CacheAuthServerServer"), Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)) & "/sessionserver/session/minecraft/profile/" + Url = If(McInstanceSelected Is Nothing, Settings.Get("CacheAuthServerServer"), Settings.Get("VersionServerAuthServer", Instance:=McInstanceSelected)) & "/sessionserver/session/minecraft/profile/" Case Else Throw New ArgumentException("皮肤地址种类无效：" & If(Type, "null")) End Select - Dim SkinString = NetGetCodeByRequestRetry(Url & Uuid) + Dim SkinString = NetRequestByClientRetry(Url & UUID, RequireJson:=True) If SkinString = "" Then Throw New Exception("皮肤返回值为空，可能是未设置自定义皮肤的用户") '处理皮肤地址 Dim SkinValue As String @@ -1610,15 +1687,16 @@ OnLoaded: Throw New Exception("皮肤返回值中不包含皮肤数据项，可能是未设置自定义皮肤的用户", ex) End Try SkinString = Encoding.GetEncoding("utf-8").GetString(Convert.FromBase64String(SkinValue)) - Dim SkinJson As JObject = GetJson(SkinString.ToLower) + Dim SkinJson As JObject = GetJson(SkinString.Lower) If SkinJson("textures") Is Nothing OrElse SkinJson("textures")("skin") Is Nothing OrElse SkinJson("textures")("skin")("url") Is Nothing Then Throw New Exception("用户未设置自定义皮肤") Else - SkinValue = SkinJson("textures")("skin")("url").ToString.Replace("http:", "https:") + Dim SkinUrl As String = SkinJson("textures")("skin")("url").ToString + SkinValue = If(SkinUrl.Contains("minecraft.net/"), SkinUrl.Replace("http://", "https://"), SkinUrl) End If '保存缓存 - WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue) - Log("[Skin] UUID " & Uuid & " 对应的皮肤文件为 " & SkinValue) + WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID, SkinValue) + Log("[Skin] UUID " & UUID & " 对应的皮肤文件为 " & SkinValue) Return SkinValue End Function @@ -1631,9 +1709,9 @@ OnLoaded: Dim FileAddress As String = PathTemp & "Cache\Skin\" & GetHash(Address) & ".png" SyncLock McSkinDownloadLock If Not File.Exists(FileAddress) Then - NetDownloadByClient(Address, FileAddress & NetDownloadEnd) + NetDownloadByClient(Address, FileAddress & ".PCLDownloading") File.Delete(FileAddress) - FileSystem.Rename(FileAddress & NetDownloadEnd, FileAddress) + File.Move(FileAddress & ".PCLDownloading", FileAddress) Log("[Minecraft] 皮肤下载成功：" & FileAddress) End If Return FileAddress @@ -1707,7 +1785,7 @@ OnLoaded: If OriginalName Is Nothing Then Return Nothing Dim Splited As New List(Of String)(OriginalName.Split(":")) Splited.RemoveAt(2) 'Java 的此格式下版本号固定为第三段，第四段可能包含架构、分包等其他信息 - Return Join(Splited, ":") + Return Splited.Join(":"c) End Get End Property ''' @@ -1772,65 +1850,64 @@ OnLoaded: ''' ''' 递归获取 Minecraft 某一版本的完整支持库列表。 ''' - Public Function McLibListGet(Version As McVersion, IncludeVersionJar As Boolean) As List(Of McLibToken) + Public Function McLibListGet(Instance As McInstance, IncludeMainJar As Boolean) As List(Of McLibToken) '获取当前支持库列表 - Log("[Minecraft] 获取支持库列表：" & Version.Name) - McLibListGet = McLibListGetWithJson(Version.JsonObject) - If Not IncludeVersionJar Then Return McLibListGet + Log("[Minecraft] 获取支持库列表：" & Instance.Name) + Dim Result = McLibListGetWithJson(Instance.JsonObject) '需要添加原版 Jar - Dim RealVersion As McVersion - Dim RequiredJar As String = Version.JsonObject("jar")?.ToString - If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then - 'HMCL 项直接使用自身的 Jar - '根据 Inherit 获取最深层版本 - Dim OriginalVersion As McVersion = Version - '1.17+ 的 Forge 不寻找 Inherit - If Not ((Version.Version.HasForge OrElse Version.Version.HasNeoForge) AndAlso Version.Version.McCodeMain >= 17) Then - Do Until OriginalVersion.InheritVersion = "" - If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do - OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\") - Loop + If IncludeMainJar Then + Dim RealInstance As McInstance + Dim RequiredJar As String = Instance.JsonObject("jar")?.ToString + If Instance.IsHmclFormatJson OrElse RequiredJar Is Nothing Then + 'HMCL 项直接使用自身的 Jar + '根据 Inherit 获取最深层版本 + Dim OriginalInstance As McInstance = Instance + '1.17+ 的 Forge 不寻找 Inherit + If Not (Instance.Version.HasForgelike AndAlso Instance.Version.Vanilla.Major >= 17) Then + Do Until OriginalInstance.InheritName = "" + If OriginalInstance.InheritName = OriginalInstance.Name Then Exit Do + OriginalInstance = New McInstance(McFolderSelected & "versions\" & OriginalInstance.InheritName & "\") + Loop + End If + '需要新建对象，否则后面的 Check 会导致 McInstanceCurrent 的 State 变回 Original + '复现：启动一个 Snapshot 版本 + RealInstance = New McInstance(OriginalInstance.PathVersion) + Else + 'Json 已提供 Jar 字段，使用该字段的信息 + RealInstance = New McInstance(RequiredJar) End If - '需要新建对象，否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original - '复现：启动一个 Snapshot 版本 - RealVersion = New McVersion(OriginalVersion.Path) - Else - 'Json 已提供 Jar 字段，使用该字段的信息 - RealVersion = New McVersion(RequiredJar) + Dim ClientUrl As String, ClientSHA1 As String + '判断需求的版本是否存在 + '不能调用 RealVersion.Check()，可能会莫名其妙地触发 CheckPermission 正被另一进程使用，导致误判前置不存在 + If Not File.Exists(RealInstance.PathVersion & RealInstance.Name & ".json") Then + RealInstance = Instance + Log("[Minecraft] 可能缺少前置版本 " & RealInstance.Name & "，找不到对应的 json 文件", LogLevel.Debug) + End If + '获取详细下载信息 + If RealInstance.JsonObject("downloads") IsNot Nothing AndAlso RealInstance.JsonObject("downloads")("client") IsNot Nothing Then + ClientUrl = RealInstance.JsonObject("downloads")("client")("url") + ClientSHA1 = RealInstance.JsonObject("downloads")("client")("sha1") + Else + ClientUrl = Nothing + ClientSHA1 = Nothing + End If + '把所需的原版 Jar 添加进去 + Result.Add(New McLibToken With {.LocalPath = RealInstance.PathVersion & RealInstance.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1}) End If - Dim ClientUrl As String, ClientSHA1 As String - '判断需求的版本是否存在 - '不能调用 RealVersion.Check()，可能会莫名其妙地触发 CheckPermission 正被另一进程使用，导致误判前置不存在 - If Not File.Exists(RealVersion.Path & RealVersion.Name & ".json") Then - RealVersion = Version - Log("[Minecraft] 可能缺少前置版本 " & RealVersion.Name & "，找不到对应的 json 文件", LogLevel.Debug) - End If - '获取详细下载信息 - If RealVersion.JsonObject("downloads") IsNot Nothing AndAlso RealVersion.JsonObject("downloads")("client") IsNot Nothing Then - ClientUrl = RealVersion.JsonObject("downloads")("client")("url") - ClientSHA1 = RealVersion.JsonObject("downloads")("client")("sha1") - Else - ClientUrl = Nothing - ClientSHA1 = Nothing - End If - '把所需的原版 Jar 添加进去 - McLibListGet.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1}) + Return Result End Function ''' ''' 获取 Minecraft 某一版本忽视继承的支持库列表，即结果中没有继承项。 ''' Public Function McLibListGetWithJson(JsonObject As JObject, Optional KeepSameNameDifferentVersionResult As Boolean = False, Optional CustomMcFolder As String = Nothing) As List(Of McLibToken) - CustomMcFolder = If(CustomMcFolder, PathMcFolder) - Dim BasicArray As New List(Of McLibToken) - - '添加基础 Json 项 - Dim AllLibs As JArray = JsonObject("libraries") + CustomMcFolder = If(CustomMcFolder, McFolderSelected) '转换为 LibToken - For Each Library As JObject In AllLibs.Children + Dim BasicArray As New List(Of McLibToken) + For Each Library As JObject In CType(JsonObject("libraries"), JArray).Children '清理 null 项（BakaXL 会把没有的项序列化为 null，但会被 Newtonsoft 转换为 JValue，导致 Is Nothing = false；这导致了 #409） For i = Library.Properties.Count - 1 To 0 Step -1 @@ -1874,17 +1951,29 @@ OnLoaded: .OriginalName = Library("name"), .Url = If(RootUrl, Library("downloads")("classifiers")("natives-windows")("url")), .LocalPath = If(Library("downloads")("classifiers")("natives-windows")("path") Is Nothing, - McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), - CustomMcFolder & "libraries\" & Library("downloads")("classifiers")("natives-windows")("path").ToString.Replace("/", "\")), + McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), + $"{CustomMcFolder}libraries\{Library("downloads")("classifiers")("natives-windows")("path").ToString.Replace("/", "\")}"), .Size = Val(Library("downloads")("classifiers")("natives-windows")("size").ToString), .IsNatives = True, .SHA1 = Library("downloads")("classifiers")("natives-windows")("sha1").ToString}) Else - BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing}) + BasicArray.Add( + New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .Size = 0, .IsNatives = True, .SHA1 = Nothing, + .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", $"-{Library("natives")("windows")}.jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")) + }) End If Catch ex As Exception Log(ex, "处理实际支持库列表失败（有 Natives，" & If(Library("name"), "Nothing").ToString & "）") - BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing}) + BasicArray.Add( + New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .Size = 0, .IsNatives = True, .SHA1 = Nothing, + .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", $"-{Library("natives")("windows")}.jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")) + }) End Try End If @@ -1910,7 +1999,7 @@ OnLoaded: ResultArray.Add(Key & GetUuid(), BasicArray(i)) Else Log($"[Minecraft] 发现重复的支持库：{BasicArray(i)} ({BasicArrayVersion}) 与 {ResultArray(Key)} ({ResultArrayVersion})，已忽略其中之一") - If VersionSortBoolean(BasicArrayVersion, ResultArrayVersion) Then + If CompareVersionGE(BasicArrayVersion, ResultArrayVersion) Then ResultArray(Key) = BasicArray(i) End If End If @@ -1922,82 +2011,71 @@ OnLoaded: End Function ''' - ''' 获取版本缺失的支持库文件所对应的 NetTaskFile。 + ''' 获取版本所需支持库文件的 NetFile。 ''' - Public Function McLibFix(Version As McVersion) As List(Of NetFile) - If Not Version.IsLoaded Then Version.Load() + Public Function McLibNetFilesFromInstance(Instance As McInstance) As List(Of NetFile) + If Not Instance.IsLoaded Then Instance.Load() Dim Result As New List(Of NetFile) '更新此方法时需要同步更新 Forge 新版自动安装方法！ '主 Jar 文件 Try - Dim MainJar As NetFile = DlClientJarGet(Version, True) + Dim MainJar As NetFile = DlClientJarGet(Instance, True) If MainJar IsNot Nothing Then Result.Add(MainJar) Catch ex As Exception Log(ex, "版本缺失主 jar 文件所必须的信息", LogLevel.Developer) End Try 'Library 文件 - Result.AddRange(McLibFixFromLibToken(McLibListGet(Version, False))) + Result.AddRange(McLibNetFilesFromTokens(McLibListGet(Instance, False))) '统一通行证文件 - If Setup.Get("VersionServerLogin", Version:=Version) = 3 Then - Dim TargetFile = PathAppdata & "nide8auth.jar" - Dim DownloadInfo As JObject = Nothing - '获取下载信息 + If Settings.Get("VersionServerLogin", Instance:=Instance) = 3 Then + Dim TargetFile As String = PathPure & "nide8auth.jar" Try - Log("[Minecraft] 开始获取统一通行证下载信息") '测试链接：https://auth.mc-user.com:233/00000000000000000000000000000000/ - DownloadInfo = GetJson(NetGetCodeByLoader({ - "https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)}, IsJson:=True)) + Log("[Minecraft] 开始获取统一通行证下载信息") + Dim DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Settings.Get("VersionServerNide", Instance:=Instance), RequireJson:=True)) + Result.Add(New NetFile( + Urls:={"https://login.mc-user.com:233/index/jar"}, + LocalPath:=TargetFile, + Checker:=New FileChecker(Hash:=DownloadInfo("jarHash").ToString))) Catch ex As Exception - Log(ex, "获取统一通行证下载信息失败") - End Try - '校验文件 - If DownloadInfo IsNot Nothing Then - Dim Checker As New FileChecker(Hash:=DownloadInfo("jarHash").ToString) - If Checker.Check(TargetFile) IsNot Nothing Then - '开始下载 - Log("[Minecraft] 统一通行证需要更新：Hash - " & Checker.Hash, LogLevel.Developer) - Result.Add(New NetFile({"https://login.mc-user.com:233/index/jar"}, TargetFile, Checker)) + If File.Exists(TargetFile) Then + Log(ex, "获取统一通行证下载信息失败") + Else + Throw New Exception("获取统一通行证下载信息失败", ex) End If - End If + End Try End If 'Authlib-Injector 文件 - If Setup.Get("VersionServerLogin", Version:=Version) = 4 Then - Dim TargetFile = PathPure & "\authlib-injector.jar" - Dim DownloadInfo As JObject = Nothing - '获取下载信息 + If Settings.Get("VersionServerLogin", Instance:=Instance) = 4 Then + Dim TargetFile = PathPure & "authlib-injector.jar" Try Log("[Minecraft] 开始获取 Authlib-Injector 下载信息") - DownloadInfo = GetJson(NetGetCodeByLoader({ + Dim DownloadInfo = GetJson(NetRequestByClientRetry( "https://authlib-injector.yushi.moe/artifact/latest.json", - "https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json" - }, IsJson:=True)) + BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json", RequireJson:=True)) + Dim DownloadAddress As String = DownloadInfo("download_url").ToString. + Replace("bmclapi2.bangbang93.com/mirrors/authlib-injector", "authlib-injector.yushi.moe") + 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))) 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))) + If File.Exists(TargetFile) Then + Log(ex, "获取 Authlib-Injector 下载信息失败") + Else + Throw New Exception("获取 Authlib-Injector 下载信息失败", ex) End If - End If + End Try End If '跳过校验 - If ShouldIgnoreFileCheck(Version) Then - Log("[Minecraft] 用户要求尽量忽略文件检查，这可能会保留有误的文件") + If ShouldIgnoreFileCheck(Instance) Then + Log("[Minecraft] 设置要求尽量忽略文件检查，这可能会保留有误的文件", LogLevel.Debug) Result = Result.Where( Function(f) If File.Exists(f.LocalPath) Then @@ -2012,20 +2090,23 @@ OnLoaded: Return Result End Function ''' - ''' 将 McLibToken 列表转换为 NetFile。无需下载的文件会被自动过滤。 + ''' 将 McLibToken 列表转换为 NetFile。 ''' - Public Function McLibFixFromLibToken(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing) As List(Of NetFile) - CustomMcFolder = If(CustomMcFolder, PathMcFolder) + Public Function McLibNetFilesFromTokens(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing) As List(Of NetFile) + CustomMcFolder = If(CustomMcFolder, McFolderSelected) Dim Result As New List(Of NetFile) '获取 For Each Token As McLibToken In Libs - '检查文件 - 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 Checker As FileChecker + If Token.Name.ContainsF("labymod") Then + Checker = New FileChecker '不检查 LabyMod 的文件，它们提供的文件校验信息是错的（#3225） + Else + Checker = New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1) + End If + 'URL Dim Urls As New List(Of String) - If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then - '特判修复 Forge 部分 universal 文件缺失 URL（#5455） + If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then '特判修复 Forge 部分 universal 文件缺失 URL（#5455） Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/") End If If Token.Url IsNot Nothing Then @@ -2071,27 +2152,20 @@ OnLoaded: ''' 原始地址，如 com.mumfrey:liteloader:1.12.2-SNAPSHOT。 ''' 是否包含 Lib 文件夹头部，若不包含，则会类似以 com\xxx\ 开头。 Public Function McLibGet(Original As String, Optional WithHead As Boolean = True, Optional IgnoreLiteLoader As Boolean = False, Optional CustomMcFolder As String = Nothing) As String - CustomMcFolder = If(CustomMcFolder, PathMcFolder) + CustomMcFolder = If(CustomMcFolder, McFolderSelected) + '有时候原始的有四段，例如 net.minecraftforge:forge:1.21.4-54.0.34:client + '文件夹名应该忽略最后一段（client），但文件名需要保留 + '参见 #7306（以及 #5376 也是因为这里没有处理好导致的） Dim Splited = Original.Split(":") McLibGet = If(WithHead, CustomMcFolder & "libraries\", "") & - Splited(0).Replace(".", "\") & "\" & Splited(1) & "\" & Splited(2) & "\" & Splited(1) & "-" & Splited(2) & ".jar" - '判断 OptiFine 是否应该使用 installer - If McLibGet.Contains("optifine\OptiFine\1.") AndAlso Splited(2).Split(".").Count > 1 Then - Dim MajorVersion As Integer = Val(Splited(2).Split(".")(1).BeforeFirst("_")) - Dim MinorVersion As Integer = If(Splited(2).Split(".").Count > 2, Val(Splited(2).Split(".")(2).BeforeFirst("_")), 0) - If (MajorVersion = 12 OrElse (MajorVersion = 20 AndAlso MinorVersion >= 4) OrElse MajorVersion >= 21) AndAlso '仅在 1.12 (无法追溯) 和 1.20.4+ (#5376) 遇到此问题 - File.Exists($"{CustomMcFolder}libraries\{Splited(0).Replace(".", "\")}\{Splited(1)}\{Splited(2)}\{Splited(1)}-{Splited(2)}-installer.jar") Then - McLaunchLog("已将 " & Original & " 替换为对应的 Installer 文件") - McLibGet = McLibGet.Replace(".jar", "-installer.jar") - End If - End If + $"{Splited(0).Replace(".", "\")}\{Splited(1)}\{Splited(2)}\{Splited.Skip(1).Join("-")}.jar" End Function ''' ''' 检查设置，是否应当忽略文件检查？ ''' - Public Function ShouldIgnoreFileCheck(Version As McVersion) - Return Setup.Get("VersionAdvanceAssetsV2", Version:=Version) OrElse (Setup.Get("VersionAdvanceAssets", Version:=Version) = 2) + Public Function ShouldIgnoreFileCheck(Instance As McInstance) + Return Settings.Get("VersionAdvanceAssetsV2", Instance:=Instance) OrElse (Settings.Get("VersionAdvanceAssets", Instance:=Instance) = 2) End Function #End Region @@ -2102,17 +2176,17 @@ OnLoaded: ''' ''' 获取某版本资源文件索引的对应 Json 项，详见版本 Json 中的 assetIndex 项。失败会抛出异常。 ''' - Public Function McAssetsGetIndex(Version As McVersion, Optional ReturnLegacyOnError As Boolean = False, Optional CheckURLEmpty As Boolean = False) As JToken + Public Function McAssetsGetIndex(Instance As McInstance, Optional ReturnLegacyOnError As Boolean = False, Optional CheckURLEmpty As Boolean = False) As JToken Dim AssetsName As String Try Do While True - Dim Index As JToken = Version.JsonObject("assetIndex") + Dim Index As JToken = Instance.JsonObject("assetIndex") If Index IsNot Nothing AndAlso Index("id") IsNot Nothing Then Return Index - If Version.JsonObject("assets") IsNot Nothing Then AssetsName = Version.JsonObject("assets").ToString + If Instance.JsonObject("assets") IsNot Nothing Then AssetsName = Instance.JsonObject("assets").ToString If CheckURLEmpty AndAlso Index("url") IsNot Nothing Then Return Index '下一个版本 - If Version.InheritVersion = "" Then Exit Do - Version = New McVersion(PathMcFolder & "versions\" & Version.InheritVersion) + If Instance.InheritName = "" Then Exit Do + Instance = New McInstance(McFolderSelected & "versions\" & Instance.InheritName) Loop Catch End Try @@ -2139,17 +2213,17 @@ OnLoaded: ''' ''' 获取某版本资源文件索引名，优先使用 assetIndex，其次使用 assets。失败会返回 legacy。 ''' - Public Function McAssetsGetIndexName(Version As McVersion) As String + Public Function McAssetsGetIndexName(Instance As McInstance) As String Try Do While True - If Version.JsonObject("assetIndex") IsNot Nothing AndAlso Version.JsonObject("assetIndex")("id") IsNot Nothing Then - Return Version.JsonObject("assetIndex")("id").ToString + If Instance.JsonObject("assetIndex") IsNot Nothing AndAlso Instance.JsonObject("assetIndex")("id") IsNot Nothing Then + Return Instance.JsonObject("assetIndex")("id").ToString End If - If Version.JsonObject("assets") IsNot Nothing Then - Return Version.JsonObject("assets").ToString + If Instance.JsonObject("assets") IsNot Nothing Then + Return Instance.JsonObject("assets").ToString End If - If Version.InheritVersion = "" Then Exit Do - Version = New McVersion(PathMcFolder & "versions\" & Version.InheritVersion) + If Instance.InheritName = "" Then Exit Do + Instance = New McInstance(McFolderSelected & "versions\" & Instance.InheritName) Loop Catch ex As Exception Log(ex, "获取资源文件索引名失败") @@ -2183,30 +2257,30 @@ OnLoaded: ''' ''' 获取 Minecraft 的资源文件列表。失败会抛出异常。 ''' - Private Function McAssetsListGet(Version As McVersion) As List(Of McAssetsToken) - Dim IndexName = McAssetsGetIndexName(Version) + Private Function McAssetsListGet(Instance As McInstance) As List(Of McAssetsToken) + Dim IndexName = McAssetsGetIndexName(Instance) Try '初始化 - If Not File.Exists($"{PathMcFolder}assets\indexes\{IndexName}.json") Then Throw New FileNotFoundException("未找到 Asset Index", PathMcFolder & "assets\indexes\" & IndexName & ".json") + If Not File.Exists($"{McFolderSelected}assets\indexes\{IndexName}.json") Then Throw New FileNotFoundException("未找到 Asset Index", McFolderSelected & "assets\indexes\" & IndexName & ".json") Dim Result As New List(Of McAssetsToken) - Dim Json As JObject = GetJson(ReadFile($"{PathMcFolder}assets\indexes\{IndexName}.json")) + Dim Json As JObject = GetJson(ReadFile($"{McFolderSelected}assets\indexes\{IndexName}.json")) '读取列表 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("/", "\") + LocalPath = $"{Instance.PathIndie}resources\{File.Name}" ElseIf Json("virtual") IsNot Nothing AndAlso Json("virtual").ToObject(Of Boolean) Then 'Virtual - LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\") + LocalPath = $"{McFolderSelected}assets\virtual\legacy\{File.Name}" Else '正常 - LocalPath = PathMcFolder & "assets\objects\" & Left(File.Value("hash").ToString, 2) & "\" & File.Value("hash").ToString + LocalPath = $"{McFolderSelected}assets\objects\{Left(File.Value("hash").ToString, 2)}\{File.Value("hash")}" End If Result.Add(New McAssetsToken With { - .LocalPath = LocalPath, + .LocalPath = LocalPath.Replace("/", "\"), .SourcePath = File.Name, .Hash = File.Value("hash").ToString, .Size = File.Value("size").ToString @@ -2220,16 +2294,24 @@ OnLoaded: End Try End Function - '获取缺失列表 ''' - ''' 获取版本缺失的资源文件所对应的 NetTaskFile。 + ''' 获取版本资源文件所对应的 NetFile。 ''' - Public Function McAssetsFixList(Version As McVersion, CheckHash As Boolean, Optional ByRef ProgressFeed As LoaderBase = Nothing) As List(Of NetFile) + Public Function McAssetsFixList(Instance As McInstance, CheckHash As Boolean, Optional ByRef ProgressFeed As LoaderBase = Nothing) As List(Of NetFile) + '如果需要检查 Hash，则留到下载时处理，以借助多线程加快检查速度 + If CheckHash Then + Return McAssetsListGet(Instance). + Select(Function(Token As McAssetsToken) New NetFile( + DlSourceAssetsGet($"https://resources.download.minecraft.net/{Left(Token.Hash, 2)}/{Token.Hash}"), + LocalPath:=Token.LocalPath, + Checker:=New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), + Hash:=Token.Hash))).ToList + End If + '如果不检查 Hash，则立即处理 Dim Result As New List(Of NetFile) - Dim AssetsList As List(Of McAssetsToken) Try - AssetsList = McAssetsListGet(Version) + AssetsList = McAssetsListGet(Instance) Dim Token As McAssetsToken If ProgressFeed IsNot Nothing Then ProgressFeed.Progress = 0.04 For i = 0 To AssetsList.Count - 1 @@ -2238,8 +2320,7 @@ OnLoaded: If ProgressFeed IsNot Nothing Then ProgressFeed.Progress = 0.05 + 0.94 * i / AssetsList.Count '检查文件是否存在 Dim File As New FileInfo(Token.LocalPath) - If File.Exists AndAlso (Token.Size = 0 OrElse Token.Size = File.Length) AndAlso - (Not CheckHash OrElse Token.Hash Is Nothing OrElse Token.Hash = GetFileSHA1(Token.LocalPath)) Then Continue For + If File.Exists AndAlso (Token.Size = 0 OrElse Token.Size = File.Length) Then Continue For '文件不存在，添加下载 Result.Add(New NetFile(DlSourceAssetsGet($"https://resources.download.minecraft.net/{Left(Token.Hash, 2)}/{Token.Hash}"), Token.LocalPath, New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.Hash))) Next @@ -2247,7 +2328,6 @@ OnLoaded: Log(ex, "获取版本缺失的资源文件下载列表失败") End Try If ProgressFeed IsNot Nothing Then ProgressFeed.Progress = 0.99 - Return Result End Function @@ -2279,7 +2359,7 @@ OnLoaded: '下载 RunInUi( Sub() - PageDownloadInstall.McVersionWaitingForSelect = VersionName + PageDownloadInstall.VersionWaitingSelect = VersionName FrmMain.PageChange(FormMain.PageType.Download, FormMain.PageSubType.DownloadInstall) End Sub) End If @@ -2290,49 +2370,49 @@ OnLoaded: End Sub ''' - ''' 比较两个版本名的排序，若 Left 较新或相同则返回 True（Left >= Right）。无法比较两个 Pre 的大小。 - ''' 支持的格式范例：未知版本, 1.13.2, 1.7.10-pre4, 1.8_pre, 1.14 Pre-Release 2, 1.14.4 C6 + ''' 比较两个版本名；等同 Left >= Right。 + ''' 无法比较两个预发布版的大小。 + ''' 支持的格式：未知版本, 1.13.2, 1.7.10-pre4, 1.8_pre, 1.14 Pre-Release 2, 1.14.4 C6 ''' - Public Function VersionSortBoolean(Left As String, Right As String) As Boolean - Return VersionSortInteger(Left, Right) >= 0 + Public Function CompareVersionGE(Left As String, Right As String) As Boolean + Return CompareVersion(Left, Right) >= 0 End Function ''' - ''' 比较两个版本名的排序，若 Left 较新则返回 1，相同则返回 0，Right 较新则返回 -1。 - ''' 支持的格式范例：未知版本, 1.13.2, 1.7.10-pre4, 1.8_pre, 1.14 Pre-Release 2, 1.14.4 C6 + ''' 比较两个版本名，若 Left 较新则返回 1，相同则返回 0，Right 较新则返回 -1；等同 Left - Right。 + ''' 无法比较两个预发布版的大小。 + ''' 支持的格式：未知版本, 26.1-snapshot-1，1.13.2, 1.7.10-pre4, 1.8_pre, 1.14 Pre-Release 2, 1.14.4 C6 ''' - Public Function VersionSortInteger(Left As String, Right As String) As Integer + Public Function CompareVersion(Left As String, Right As String) As Integer If Left = "未知版本" OrElse Right = "未知版本" Then If Left = "未知版本" AndAlso Right <> "未知版本" Then Return 1 If Left = "未知版本" AndAlso Right = "未知版本" Then Return 0 If Left <> "未知版本" AndAlso Right = "未知版本" Then Return -1 End If - Left = Left.ToLowerInvariant - Right = Right.ToLowerInvariant + Left = Left.Lower + Right = Right.Lower Dim Lefts = RegexSearch(Left.Replace("快照", "snapshot").Replace("预览版", "pre"), "[a-z]+|[0-9]+") Dim Rights = RegexSearch(Right.Replace("快照", "snapshot").Replace("预览版", "pre"), "[a-z]+|[0-9]+") Dim i As Integer = 0 While True '两边均缺失，感觉是一个东西 If Lefts.Count - 1 < i AndAlso Rights.Count - 1 < i Then - If Left > Right Then - Return 1 - ElseIf Left < Right Then - Return -1 - Else - Return 0 - End If + If Left > Right Then Return 1 + If Left < Right Then Return -1 + Return 0 End If '确定两边的数值 - Dim LeftValue As String = If(Lefts.Count - 1 < i, "-1", Lefts(i)) - Dim RightValue As String = If(Rights.Count - 1 < i, "-1", Rights(i)) + Dim LeftValue As String = If(Lefts.Count - 1 < i, 0, Lefts(i)) + Dim RightValue As String = If(Rights.Count - 1 < i, 0, Rights(i)) If LeftValue = RightValue Then GoTo NextEntry - If LeftValue = "pre" OrElse LeftValue = "snapshot" Then LeftValue = "-3" - If LeftValue = "rc" Then LeftValue = "-2" - If LeftValue = "experimental" Then LeftValue = "-4" + If LeftValue = "rc" Then LeftValue = -1 + If LeftValue = "pre" Then LeftValue = -2 + If LeftValue = "snapshot" Then LeftValue = -3 + If LeftValue = "experimental" Then LeftValue = -4 Dim LeftValValue = Val(LeftValue) - If RightValue = "pre" OrElse RightValue = "snapshot" Then RightValue = "-3" - If RightValue = "rc" Then RightValue = "-2" - If RightValue = "experimental" Then RightValue = "-4" + If RightValue = "rc" Then RightValue = -1 + If RightValue = "pre" Then RightValue = -2 + If RightValue = "snapshot" Then RightValue = -3 + If RightValue = "experimental" Then RightValue = -4 Dim RightValValue = Val(RightValue) If LeftValValue = 0 AndAlso RightValValue = 0 Then '如果没有数值则直接比较字符串 @@ -2361,17 +2441,10 @@ NextEntry: Public Class VersionComparer Implements IComparer(Of String) Public Function Compare(x As String, y As String) As Integer Implements IComparer(Of String).Compare - Return VersionSortInteger(x, y) + Return CompareVersion(x, y) End Function End Class - ''' - ''' 判断版本名是否类似正式版。 - ''' - Public Function IsVersionNameLikeRelease(VerName As String) As Boolean - Return VerName.StartsWithF("1.") AndAlso Not (VerName.Contains("w") OrElse VerName.Contains("pre") OrElse VerName.Contains("rc") OrElse VerName.Contains("-")) - End Function - ''' ''' 打码字符串中的 AccessToken。 ''' @@ -2396,7 +2469,12 @@ NextEntry: Public Function FilterUserName(Raw As String, FilterChar As Char) As String If Raw.Contains(":\Users\") Then For Each Token In RegexSearch(Raw, "(?<=:\\Users\\)[^\\]+") - Raw = Raw.Replace(Token, New String(FilterChar, Token.Count)) + Raw = Raw.Replace("\Users\" & Token, "\Users\" & New String(FilterChar, Token.Count)) + Next + End If + If Raw.Contains(":/Users/") Then + For Each Token In RegexSearch(Raw, "(?<=:/Users/)[^/]+") + Raw = Raw.Replace("/Users/" & Token, "/Users/" & New String(FilterChar, Token.Count)) Next End If Return Raw diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb index bb9b3d5..4b53985 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb @@ -1,7 +1,7 @@ Imports System.IO.Compression Public Module ModMod - Private Const LocalModCacheVersion As Integer = 7 + Private Const LocalModCacheVersion As Integer = 13 Public Class McMod @@ -46,10 +46,7 @@ Public Module ModMod ''' Public ReadOnly Property State As McModState Get - Load() - If Not IsFileAvailable Then - Return McModState.Unavailable - ElseIf Path.EndsWithF(".disabled", True) OrElse Path.EndsWithF(".old", True) Then + If Path.EndsWithF(".disabled", True) OrElse Path.EndsWithF(".old", True) Then Return McModState.Disabled Else Return McModState.Fine @@ -59,7 +56,6 @@ Public Module ModMod Public Enum McModState As Integer Fine = 0 Disabled = 1 - Unavailable = 2 End Enum #End Region @@ -67,18 +63,23 @@ Public Module ModMod #Region "信息项" ''' - ''' Mod 的名称。若不可用则为 ModID 或无扩展的文件名。 + ''' 当任何信息在初始化后更新时触发。 ''' - Public Property Name As String + Public Event OnUpdate(sender As McMod) + + ''' + ''' Mod 的可读名称。 + ''' 可能为无扩展的文件名，但不会是 Nothing。 + ''' + Public Property DisplayName As String Get - If _Name Is Nothing Then Load() - If _Name Is Nothing Then _Name = _ModId - If _Name Is Nothing Then _Name = GetFileNameWithoutExtentionFromPath(Path) + If _Name Is Nothing Then _Name = CompFile?.DisplayName + If _Name Is Nothing Then _Name = IO.Path.GetFileNameWithoutExtension(Path) Return _Name End Get Set(value As String) If _Name Is Nothing AndAlso value IsNot Nothing AndAlso Not value.Contains("modname") AndAlso - value.ToLower <> "name" AndAlso value.Count > 1 AndAlso Val(value).ToString <> value Then + value.Lower <> "name" AndAlso value.Count > 1 AndAlso Val(value).ToString <> value Then _Name = value End If End Set @@ -87,226 +88,67 @@ Public Module ModMod ''' ''' Mod 的描述信息。 + ''' 可能为 Nothing。 ''' Public Property Description As String Get - If _Description Is Nothing Then Load() - If _Description Is Nothing AndAlso FileUnavailableReason IsNot Nothing Then _Description = FileUnavailableReason.Message - 'If _Description Is Nothing Then _Description = Path Return _Description End Get Set(value As String) If _Description Is Nothing AndAlso value IsNot Nothing AndAlso value.Count > 2 Then _Description = value.ToString.Trim(vbLf) '优化显示：若以 [a-zA-Z0-9] 结尾，加上小数点句号 - If _Description.ToLower.LastIndexOfAny("qwertyuiopasdfghjklzxcvbnm0123456789") = _Description.Count - 1 Then _Description += "." + If _Description.Lower.LastIndexOfAny("qwertyuiopasdfghjklzxcvbnm0123456789") = _Description.Count - 1 Then _Description += "." End If End Set End Property Private _Description As String = Nothing ''' - ''' Mod 的版本，不保证符合版本格式规范。 + ''' Mod 的版本。 + ''' 不保证符合版本格式规范，且可能为 Nothing。 ''' Public Property Version As String Get - If _Version Is Nothing Then Load() + If _Version Is Nothing Then _Version = CompFile?.Version Return _Version End Get Set(value As String) If _Version IsNot Nothing AndAlso RegexCheck(_Version, "[0-9.\-]+") Then Return - If value?.ContainsF("version", True) Then value = "version" '需要修改的标识 + If value IsNot Nothing AndAlso value.ContainsF("version", True) Then value = "version" '需要修改的标识 _Version = value End Set End Property Public _Version As String = Nothing - ''' - ''' 用于依赖检查的 ModID。 - ''' - Public Property ModId As String - Get - If _ModId Is Nothing Then Load() - Return _ModId - End Get - Set(value As String) - If value Is Nothing Then Return - value = RegexSeek(value, "[0-9a-zA-Z_-]+") - If value Is Nothing OrElse value.Count <= 1 OrElse Val(value).ToString = value Then Return - If value.ContainsF("name", True) OrElse value.ContainsF("modid", True) Then Return - If Not PossibleModId.Contains(value) Then PossibleModId.Add(value) - If _ModId Is Nothing Then _ModId = value - End Set - End Property - Private _ModId As String = Nothing - ''' - ''' 其他可能的 ModID。 - ''' - Public PossibleModId As New List(Of String) - - ''' - ''' Mod 的主页。 - ''' - Public Property Url As String - Get - If _Url Is Nothing Then Load() - Return _Url - End Get - Set(value As String) - If _Url Is Nothing AndAlso value IsNot Nothing AndAlso value.StartsWithF("http") Then - _Url = value - End If - End Set - End Property - Private _Url As String = Nothing - - ''' - ''' Mod 的作者列表。 - ''' - Public Property Authors As String - Get - If _Authors Is Nothing Then Load() - Return _Authors - End Get - Set(value As String) - If _Authors Is Nothing AndAlso Not String.IsNullOrWhiteSpace(value) Then - _Authors = value - End If - End Set - End Property - Private _Authors As String = Nothing - - ''' - ''' 依赖项，其中包括了 Minecraft 的版本要求。格式为 ModID - VersionRequirement，若无版本要求则为 Nothing。 - ''' - Public ReadOnly Property Dependencies As Dictionary(Of String, String) - Get - Load() - Return _Dependencies - End Get - End Property - Private _Dependencies As New Dictionary(Of String, String) - Private Sub AddDependency(ModID As String, Optional VersionRequirement As String = Nothing) - '确保信息正确 - If ModID Is Nothing OrElse ModID.Count < 2 Then Return - ModID = ModID.ToLower - If ModID = "name" OrElse Val(ModID).ToString = ModID Then Return '跳过 name 与纯数字 id - If VersionRequirement Is Nothing OrElse ((Not VersionRequirement.Contains(".")) AndAlso (Not VersionRequirement.Contains("-"))) OrElse VersionRequirement.Contains("$") Then - VersionRequirement = Nothing - Else - If (Not VersionRequirement.StartsWithF("[")) AndAlso (Not VersionRequirement.StartsWithF("(")) AndAlso (Not VersionRequirement.EndsWithF("]")) AndAlso (Not VersionRequirement.EndsWithF(")")) Then VersionRequirement = "[" & VersionRequirement & ",)" - End If - '向依赖项中添加 - If _Dependencies.ContainsKey(ModID) Then - If _Dependencies(ModID) Is Nothing Then _Dependencies(ModID) = VersionRequirement - Else - _Dependencies.Add(ModID, VersionRequirement) - End If - End Sub - #End Region -#Region "加载步骤标记" - - '1. 进行文件可用性检查 - ' 成功：继续第二步。 - ' 失败：标记 FileUnavailableReason， 并停止后续加载。 - ''' - ''' 是否已进行 Mod 文件的基础加载。（这包括第一步和第二步） - ''' - Private IsLoaded As Boolean = False - ''' - ''' Mod 文件是否可被正常读取。 - ''' - Public ReadOnly Property IsFileAvailable As Boolean - Get - Load() - Return FileUnavailableReason Is Nothing - End Get - End Property - ''' - ''' Mod 文件出错的原因。若无错误，则为 Nothing。 - ''' - Public ReadOnly Property FileUnavailableReason As Exception - Get - Load() - Return _FileUnavailableReason - End Get - End Property - Private _FileUnavailableReason As Exception = Nothing - - '2. 进行 .class 以外的信息获取 - ' 成功：标记 IsInfoWithoutClassAvailable。 - ' 失败：什么也不干。如果需要补充信息的话，检测到 IsInfoWithoutClassAvailable 为 False，会自动继续加载。 - ''' - ''' 是否已在不获取 .class 文件的前提下完成了所需信息的加载。 - ''' - Private IsInfoWithoutClassAvailable As Boolean = False - - '3. 尝试从 .class 文件中获取信息 - ' 成功：标记 IsInfoWithClassAvailable。 - ' 失败：什么也不干。 - ''' - ''' 是否已进行 .class 文件的信息获取。 - ''' - Private IsInfoWithClassLoaded As Boolean = False - ''' - ''' 是否已在 .class 文件中完成了所需信息的加载。 - ''' - Private IsInfoWithClassAvailable As Boolean = False - -#End Region - -#Region "加载" +#Region "从 JAR 获取信息" ''' - ''' 初始化所有数据。 + ''' 从 JAR 文件中获取 Mod 信息。 ''' - Private Sub Init() - _Name = Nothing - _Description = Nothing - _Version = Nothing - _ModId = Nothing - PossibleModId = New List(Of String) - _Dependencies = New Dictionary(Of String, String) - IsLoaded = False - _FileUnavailableReason = Nothing - IsInfoWithClassLoaded = False - IsInfoWithClassAvailable = False - End Sub - - ''' - ''' 进行文件可用性检查与 .class 以外的信息获取。 - ''' - Public Sub Load(Optional ForceReload As Boolean = False) - If IsLoaded AndAlso Not ForceReload Then Return - '初始化 - Init() + Public Sub LoadMetadataFromJar() + Static IsLoaded As Boolean = False + If IsLoaded Then Return + IsLoaded = True Dim Jar As ZipArchive = Nothing Try '基础可用性检查、打开 Jar 文件 If Path.Length < 2 Then Throw New FileNotFoundException("错误的 Mod 文件路径（" & If(Path, "null") & "）") If Not File.Exists(Path) Then Throw New FileNotFoundException("未找到 Mod 文件（" & Path & "）") - Jar = New ZipArchive(New FileStream(Path, FileMode.Open)) + Jar = New ZipArchive(New FileStream(Path, FileMode.Open, FileAccess.Read, FileShare.Read)) '信息获取 - LookupMetadata(Jar) + LoadMetadataFromJar(Jar) Catch ex As UnauthorizedAccessException Log(ex, "Mod 文件由于无权限无法打开（" & Path & "）", LogLevel.Developer) - _FileUnavailableReason = New UnauthorizedAccessException("没有读取此文件的权限，请尝试右键以管理员身份运行 PCL", ex) Catch ex As Exception Log(ex, "Mod 文件无法打开（" & Path & "）", LogLevel.Developer) - _FileUnavailableReason = ex Finally If Jar IsNot Nothing Then Jar.Dispose() End Try - '完成标记 - IsLoaded = True End Sub - - ''' - ''' 从 jar 文件中获取 Mod 信息。 - ''' - Private Sub LookupMetadata(Jar As ZipArchive) + Private Sub LoadMetadataFromJar(Jar As ZipArchive) #Region "尝试使用 mcmod.info" Try @@ -327,45 +169,9 @@ Public Module ModMod InfoObject = JsonObject("modList")(0) End If '从文件中获取 Mod 信息项 - Name = InfoObject("name") + DisplayName = InfoObject("name") Description = InfoObject("description") Version = InfoObject("version") - Url = InfoObject("url") - ModId = InfoObject("modid") - Dim AuthorJson As JArray = InfoObject("authorList") - If AuthorJson IsNot Nothing Then - Dim Author As New List(Of String) - For Each Token In AuthorJson - Author.Add(Token.ToString) - Next - If Author.Any Then Authors = Join(Author, ", ") - End If - Dim Reqs As JArray = InfoObject("requiredMods") - If Reqs IsNot Nothing Then - For Each Token As String In Reqs - If Not String.IsNullOrEmpty(Token) Then - Token = Token.Substring(Token.IndexOfF(":") + 1) - If Token.Contains("@") Then - AddDependency(Token.Split("@")(0), Token.Split("@")(1)) - Else - AddDependency(Token) - End If - End If - Next - End If - Reqs = InfoObject("dependancies") - If Reqs IsNot Nothing Then - For Each Token As String In Reqs - If Not String.IsNullOrEmpty(Token) Then - Token = Token.Substring(Token.IndexOfF(":") + 1) - If Token.Contains("@") Then - AddDependency(Token.Split("@")(0), Token.Split("@")(1)) - Else - AddDependency(Token) - End If - End If - Next - End If Catch ex As Exception Log(ex, "读取 mcmod.info 时出现未知错误（" & Path & "）", LogLevel.Developer) End Try @@ -383,37 +189,9 @@ Public Module ModMod Dim FabricObject As JObject = GetJson(FabricText) GotFabric: '从文件中获取 Mod 信息项 - If FabricObject.ContainsKey("name") Then Name = FabricObject("name") + If FabricObject.ContainsKey("name") Then DisplayName = FabricObject("name") If FabricObject.ContainsKey("version") Then Version = FabricObject("version") If FabricObject.ContainsKey("description") Then Description = FabricObject("description") - If FabricObject.ContainsKey("id") Then ModId = FabricObject("id") - If FabricObject.ContainsKey("contact") Then Url = If(FabricObject("contact")("homepage"), "") - Dim AuthorJson As JArray = FabricObject("authors") - If AuthorJson IsNot Nothing Then - Dim Author As New List(Of String) - For Each Token In AuthorJson - Author.Add(Token.ToString) - Next - If Author.Any Then Authors = Join(Author, ", ") - End If - 'If (Not FabricObject.ContainsKey("serverSideOnly")) OrElse FabricObject("serverSideOnly")("value").ToObject(Of Boolean) = False Then - ' '添加 Minecraft 依赖 - ' Dim DepMinecraft As String = If(If(FabricObject("acceptedMinecraftVersions") IsNot Nothing, FabricObject("acceptedMinecraftVersions")("value"), ""), "") - ' If DepMinecraft <> "" Then AddDependency("minecraft", DepMinecraft) - ' '添加其他依赖 - ' Dim Deps As String = If(If(FabricObject("dependencies") IsNot Nothing, FabricObject("dependencies")("value"), ""), "") - ' If Deps <> "" Then - ' For Each Dep In Deps.Split(";") - ' If Dep = "" OrElse Not Dep.StartsWithF("required-") Then Continue For - ' Dep = Dep.Substring(Dep.IndexOfF(":") + 1) - ' If Dep.Contains("@") Then - ' AddDependency(Dep.Split("@")(0), Dep.Split("@")(1)) - ' Else - ' AddDependency(Dep) - ' End If - ' Next - ' End If - 'End If '加载成功 GoTo Finished Catch ex As Exception @@ -474,10 +252,10 @@ GotFabric: End If Loop End If - Value = Join(ValueLines, vbLf).Trim(vbLf).Replace(vbLf, vbCrLf) - ElseIf RawValue.ToLower = "true" OrElse RawValue.ToLower = "false" Then + Value = ValueLines.Join(vbLf).Trim(vbLf).Replace(vbLf, vbCrLf) + ElseIf RawValue.Lower = "true" OrElse RawValue.Lower = "false" Then '布尔型 - Value = (RawValue.ToLower = "true") + Value = (RawValue.Lower = "true") ElseIf Val(RawValue).ToString = RawValue Then '数字型 Value = Val(RawValue) @@ -500,22 +278,9 @@ GotFabric: End If Next If ModEntry Is Nothing OrElse Not ModEntry.ContainsKey("modId") Then Exit Try - ModId = ModEntry("modId") - If _ModId Is Nothing Then Exit Try '设置了无效的 ModID - If ModEntry.ContainsKey("displayName") Then Name = ModEntry("displayName") + If ModEntry.ContainsKey("displayName") Then DisplayName = ModEntry("displayName") If ModEntry.ContainsKey("description") Then Description = ModEntry("description") If ModEntry.ContainsKey("version") Then Version = ModEntry("version") - If TomlData(0).Value.ContainsKey("displayURL") Then Url = TomlData(0).Value("displayURL") - If TomlData(0).Value.ContainsKey("authors") Then Authors = TomlData(0).Value("authors") - For Each TomlSubData In TomlData - If TomlSubData.Key.ToLower = $"dependencies.{ModId.ToLower}" Then - Dim DepEntry As Dictionary(Of String, Object) = TomlSubData.Value - If DepEntry.ContainsKey("modId") AndAlso DepEntry.ContainsKey("mandatory") AndAlso DepEntry("mandatory") AndAlso - DepEntry.ContainsKey("side") AndAlso Not DepEntry("side").ToString.ToLower = "server" Then - AddDependency(DepEntry("modId"), If(DepEntry.ContainsKey("versionRange"), DepEntry("versionRange"), Nothing)) - End If - End If - Next '加载成功 GoTo Finished Catch ex As Exception @@ -551,41 +316,16 @@ GotFabric: Exit Try Got: '从文件中获取 Mod 信息项 - If FmlObject.ContainsKey("useMetadata") AndAlso If(FmlObject("useMetadata")("value"), "").ToString.ToLower = "true" Then - '要求使用 mcmod.info 中的信息 - Dim value As String = FmlObject("modid")("value") - If value Is Nothing Then Exit Try - value = RegexSeek(value.ToLower, "[0-9a-z_]+") - If value IsNot Nothing AndAlso value.ToLower <> "name" AndAlso value.Count > 1 AndAlso Val(value).ToString <> value Then - If Not PossibleModId.Contains(value) Then PossibleModId.Add(value) - End If - Exit Try - End If - If FmlObject.ContainsKey("name") Then Name = FmlObject("name")("value") + If FmlObject.ContainsKey("name") Then DisplayName = FmlObject("name")("value") If FmlObject.ContainsKey("version") Then Version = FmlObject("version")("value") - If FmlObject.ContainsKey("modid") Then ModId = FmlObject("modid")("value") - If (Not FmlObject.ContainsKey("serverSideOnly")) OrElse FmlObject("serverSideOnly")("value").ToObject(Of Boolean) = False Then - '添加 Minecraft 依赖 - Dim DepMinecraft As String = If(If(FmlObject("acceptedMinecraftVersions") IsNot Nothing, FmlObject("acceptedMinecraftVersions")("value"), ""), "") - If DepMinecraft <> "" Then AddDependency("minecraft", DepMinecraft) - '添加其他依赖 - Dim Deps As String = If(If(FmlObject("dependencies") IsNot Nothing, FmlObject("dependencies")("value"), ""), "") - If Deps <> "" Then - For Each Dep In Deps.Split(";") - If Dep = "" OrElse Not Dep.StartsWithF("required-") Then Continue For - Dep = Dep.Substring(Dep.IndexOfF(":") + 1) - If Dep.Contains("@") Then - AddDependency(Dep.Split("@")(0), Dep.Split("@")(1)) - Else - AddDependency(Dep) - End If - Next - End If - End If + '加载成功 + GoTo Finished Catch ex As Exception Log(ex, "读取 fml_cache_annotation.json 时出现未知错误（" & Path & "）", LogLevel.Developer) End Try #End Region + Return '没能成功获取任何信息 + Finished: #Region "将 Version 代号转换为 META-INF 中的版本" If _Version = "version" Then @@ -606,6 +346,7 @@ Finished: End If If _Version IsNot Nothing AndAlso Not (_Version.Contains(".") OrElse _Version.Contains("-")) Then Version = Nothing #End Region + RaiseEvent OnUpdate(Me) End Sub @@ -613,11 +354,6 @@ Finished: #Region "网络信息" - ''' - ''' 当任何网络信息更新时触发。 - ''' - Public Event OnCompUpdate(sender As McMod) - ''' ''' 该 Mod 关联的网络项目。 ''' @@ -627,7 +363,7 @@ Finished: End Get Set(value As CompProject) _Comp = value - RaiseEvent OnCompUpdate(Me) + RaiseEvent OnUpdate(Me) End Set End Property Private _Comp As CompProject @@ -646,7 +382,7 @@ Finished: End Get Set(value As CompFile) _UpdateFile = value - RaiseEvent OnCompUpdate(Me) + RaiseEvent OnUpdate(Me) End Set End Property Private _UpdateFile As CompFile @@ -688,7 +424,7 @@ Finished: ''' Public ReadOnly Property CanUpdate As Boolean Get - Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso ChangelogUrls.Any() + Return Not Settings.Get("UiHiddenFunctionModUpdate") AndAlso Not Settings.Get("VersionAdvanceDisableModUpdate", Instance:=PageInstanceLeft.Instance) AndAlso UpdateFile IsNot Nothing End Get End Property @@ -787,10 +523,10 @@ Finished: #End Region ''' - ''' 是否可能为前置 Mod。 + ''' 是否可能为前置 Mod。目前非常不准确。 ''' Public Function IsPresetMod() As Boolean - Return Not Dependencies.Any() AndAlso Name IsNot Nothing AndAlso (Name.ToLower.Contains("core") OrElse Name.ToLower.Contains("lib")) + Return DisplayName IsNot Nothing AndAlso (DisplayName.Lower.Contains("core") OrElse DisplayName.Lower.Contains("lib")) End Function ''' @@ -798,7 +534,7 @@ Finished: ''' Public Shared Function IsModFile(Path As String) If Path Is Nothing OrElse Not Path.Contains(".") Then Return False - Path = Path.ToLower + Path = Path.Lower If Path.EndsWithF(".jar", True) OrElse Path.EndsWithF(".zip", True) OrElse Path.EndsWithF(".litemod", True) OrElse Path.EndsWithF(".jar.disabled", True) OrElse Path.EndsWithF(".zip.disabled", True) OrElse Path.EndsWithF(".litemod.disabled", True) OrElse Path.EndsWithF(".jar.old", True) OrElse Path.EndsWithF(".zip.old", True) OrElse Path.EndsWithF(".litemod.old", True) Then Return True @@ -811,33 +547,33 @@ Finished: Public McModLoader As New LoaderTask(Of String, List(Of McMod))("Mod List Loader", AddressOf McModLoad) Private Sub McModLoad(Loader As LoaderTask(Of String, List(Of McMod))) Try - RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.ShowProgress = False) + RunInUiWait(Sub() If FrmInstanceMod IsNot Nothing Then FrmInstanceMod.Load.ShowProgress = False) '等待 Mod 更新完成 - If PageVersionMod.UpdatingVersions.Contains(Loader.Input) Then + If PageInstanceMod.UpdatingInstanceModFolders.Contains(Loader.Input) Then 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) - If Loader.IsAborted Then Return + RunInUiWait(Sub() If FrmInstanceMod IsNot Nothing Then FrmInstanceMod.Load.Text = "正在更新 Mod") + Do Until Not PageInstanceMod.UpdatingInstanceModFolders.Contains(Loader.Input) + If Loader.IsInterrupted Then Return Thread.Sleep(100) Loop Finally - RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在加载 Mod 列表") + RunInUiWait(Sub() If FrmInstanceMod IsNot Nothing Then FrmInstanceMod.Load.Text = "正在加载 Mod 列表") End Try - FrmVersionMod.LoaderRun(LoaderFolderRunType.UpdateOnly) + FrmInstanceMod.LoaderRun(LoaderFolderRunType.UpdateOnly) End If '获取 Mod 文件夹下的可用文件列表 Dim ModFileList As New List(Of FileInfo) If Directory.Exists(Loader.Input) Then - Dim RawName As String = Loader.Input.ToLower + Dim RawName As String = Loader.Input.Lower For Each File As FileInfo In EnumerateFiles(Loader.Input) - If File.DirectoryName.ToLower & "\" <> RawName Then + If File.DirectoryName.Lower & "\" <> RawName Then '仅当 Forge 1.13- 且文件夹名与版本号相同时，才加载该子文件夹下的 Mod - If Not (PageVersionLeft.Version IsNot Nothing AndAlso PageVersionLeft.Version.Version.HasForge AndAlso - PageVersionLeft.Version.Version.McCodeMain < 13 AndAlso - File.Directory.Name = $"1.{PageVersionLeft.Version.Version.McCodeMain}.{PageVersionLeft.Version.Version.McCodeSub}") Then + If Not (PageInstanceLeft.Instance IsNot Nothing AndAlso PageInstanceLeft.Instance.Version.HasForge AndAlso + PageInstanceLeft.Instance.Version.Vanilla.Major < 13 AndAlso + File.Directory.Name = $"1.{PageInstanceLeft.Instance.Version.Vanilla.Major}.{PageInstanceLeft.Instance.Version.Vanilla.Build}") Then Continue For End If End If @@ -845,10 +581,6 @@ Finished: Next End If - '确定是否显示进度 - Loader.Progress = 0.05 - If ModFileList.Count > 50 Then RunInUi(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.ShowProgress = True) - '获取本地文件缓存 Dim CachePath As String = PathTemp & "Cache\LocalMod.json" Dim Cache As New JObject @@ -869,14 +601,10 @@ Finished: '加载 Mod 列表 Dim ModList As New List(Of McMod) - Dim ModUpdateList As New List(Of McMod) For Each ModFile As FileInfo In ModFileList - Loader.Progress += 0.94 / ModFileList.Count - If Loader.IsAborted Then Return - '加载 McMod 对象 + If Loader.IsInterrupted Then Return Dim ModEntry As New McMod(ModFile.FullName) - ModEntry.Load() - Dim DumpMod As McMod = ModList.FirstOrDefault(Function(m) m.RawFileName = ModEntry.RawFileName) + Dim DumpMod As McMod = ModList.FirstOrDefault(Function(m) m.RawFileName = ModEntry.RawFileName) '存在两个文件，名称相同，但一个启用一个禁用 If DumpMod IsNot Nothing Then Dim DisabledMod As McMod = If(DumpMod.State = McMod.McModState.Disabled, DumpMod, ModEntry) Log($"[Mod] 重复的 Mod 文件：{DumpMod.FileName} 与 {ModEntry.FileName}，已忽略 {DisabledMod.FileName}", LogLevel.Debug) @@ -884,42 +612,22 @@ Finished: Continue For Else ModList.Remove(DisabledMod) - ModUpdateList.Remove(DisabledMod) End If End If ModList.Add(ModEntry) - '读取 Comp 缓存 - 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)) - '如果缓存中的信息在 6 小时以内更新过，则无需重新获取 - If ModEntry.CompLoaded AndAlso Date.Now - Cache(CacheKey)("Comp")("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For - End If - ModUpdateList.Add(ModEntry) Next - Loader.Progress = 0.99 - Log($"[Mod] 共有 {ModList.Count} 个 Mod，其中 {ModUpdateList.Where(Function(m) m.Comp Is Nothing).Count} 个需要联网获取信息，{ModUpdateList.Where(Function(m) m.Comp IsNot Nothing).Count} 个需要更新信息") + Log($"[Mod] 共发现 {ModList.Count} 个 Mod") '排序 - ModList = ModList.Sort( - Function(Left As McMod, Right As McMod) As Boolean - 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 - End Function) + ModList = ModList.OrderBy(Function(m) m.FileName).ToList '回设 - If Loader.IsAborted Then Return + If Loader.IsInterrupted Then Return Loader.Output = ModList '开始联网加载 - If ModUpdateList.Any() Then - 'TODO: 添加信息获取中提示 - McModDetailLoader.Start(New KeyValuePair(Of List(Of McMod), JObject)(ModUpdateList, Cache), IsForceRestart:=True) - End If + 'TODO: 添加信息获取中提示 + McModDetailLoader.Start(New KeyValuePair(Of List(Of McMod), JObject)(ModList, Cache), IsForceRestart:=True) Catch ex As Exception Log(ex, "Mod 列表加载失败", LogLevel.Debug) @@ -929,15 +637,31 @@ Finished: '联网加载 Mod 详情 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 + Dim Mods As New List(Of McMod) Dim Cache As JObject = Loader.Input.Value + '读取 Comp 缓存，获取需要更新的 Mod 列表 + For Each ModEntry As McMod In Loader.Input.Key + If Loader.IsInterrupted Then Return + Dim CacheKey = ModEntry.ModrinthHash & PageInstanceLeft.Instance.Version.VanillaName & GetTargetModLoaders().Join("") + If Cache.ContainsKey(CacheKey) Then + ModEntry.FromJson(Cache(CacheKey)) + '如果缓存中的信息在 6 小时以内更新过，则无需重新获取 + If ModEntry.CompLoaded AndAlso Date.Now - Cache(CacheKey)("Comp")("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For + End If + Mods.Add(ModEntry) + Next + Log($"[Mod] 有 {Mods.Where(Function(m) m.Comp Is Nothing).Count} 个 Mod 需要联网获取信息，{Mods.Where(Function(m) m.Comp IsNot Nothing).Count} 个 Mod 需要更新信息") + If Not Mods.Any Then + Loader.Input.Key.Where(Function(m) m.Version Is Nothing).ForEach(Sub(m) m.LoadMetadataFromJar()) '从 JAR 中获取缺失的版本信息（下面有另一个分支） + Return + End If '获取作为检查目标的加载器和版本 '此处不应向下扩展检查的 MC 小版本，例如 Mod 在更新 1.16.5 后，对早期的 1.16.2 版本发布了修补补丁，这会导致 PCL 将 1.16.5 版本的 Mod 降级到 1.16.2 - Dim TargetMcVersion As McVersionInfo = PageVersionLeft.Version.Version + Dim TargetMcVersion As McVersion = PageInstanceLeft.Instance.Version Dim ModLoaders = GetTargetModLoaders() - Dim McVersion = TargetMcVersion.McName + Dim VanillaVersion = TargetMcVersion.VanillaName '开始网络获取 - Log($"[Mod] 目标加载器：{ModLoaders.Join("/")}，版本：{McVersion}") + Log($"[Mod] 目标加载器：{ModLoaders.Join("/")}，版本：{VanillaVersion}") Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False Dim CurrentTaskThread As Thread = Thread.CurrentThread '从 Modrinth 获取信息 @@ -946,8 +670,8 @@ Finished: Try '步骤 1：获取 Hash 与对应的工程 ID Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList() - Dim ModrinthVersion = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files", "POST", - $"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject) + Dim ModrinthVersion As JObject = DlModRequest("https://api.modrinth.com/v2/version_files", HttpMethod.Post, + $"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json") Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息") '步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系 If ModrinthVersion.Count = 0 Then Return @@ -961,15 +685,18 @@ Finished: ModrinthMapping(ProjectId).Add(Entry) '记录对应的 CompFile Dim File As New CompFile(ModrinthVersion(Entry.ModrinthHash), CompType.Mod) - If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File + If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then + Entry.CompFile = File + Else + Entry.CompFile.Version = File.Version '使用来自 Modrinth 的版本号 + End If Next - If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return + If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息") '步骤 3：获取工程信息 If Not ModrinthMapping.Any() Then Return - Dim ModrinthProject = CType(GetJson(DlModRequest( - $"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]", - "GET", "", "application/json")), JArray) + Dim ModrinthProject As JArray = DlModRequest( + $"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]") For Each ProjectJson In ModrinthProject Dim Project As New CompProject(ProjectJson) For Each Entry In ModrinthMapping(Project.Id) @@ -978,9 +705,9 @@ Finished: Next Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息，继续获取更新信息") '步骤 4：获取更新信息 - Dim ModrinthUpdate = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files/update", "POST", + Dim ModrinthUpdate As JObject = DlModRequest("https://api.modrinth.com/v2/version_files/update", HttpMethod.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) + ""loaders"": [""{ModLoaders.Join(""",""").Lower}""],""game_versions"": [""{VanillaVersion}""]}}", "application/json") For Each Entry In Mods If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod) @@ -989,11 +716,11 @@ Finished: If Entry.CompFile.ReleaseDate >= UpdateFile.ReleaseDate OrElse Entry.CompFile.Hash = UpdateFile.Hash Then Continue For '设置更新日志与更新文件 If Entry.UpdateFile IsNot Nothing AndAlso UpdateFile.Hash = Entry.UpdateFile.Hash Then '合并 - Entry.ChangelogUrls.Add($"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={McVersion}") + Entry.ChangelogUrls.Add($"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={VanillaVersion}") UpdateFile.DownloadUrls.AddRange(Entry.UpdateFile.DownloadUrls) '合并下载源 Entry.UpdateFile = UpdateFile '优先使用 Modrinth 的文件 ElseIf Entry.UpdateFile Is Nothing OrElse UpdateFile.ReleaseDate >= Entry.UpdateFile.ReleaseDate Then '替换 - Entry.ChangelogUrls = New List(Of String) From {$"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={McVersion}"} + Entry.ChangelogUrls = New List(Of String) From {$"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={VanillaVersion}"} Entry.UpdateFile = UpdateFile End If Next @@ -1013,10 +740,10 @@ Finished: Dim CurseForgeHashes As New List(Of UInteger) For Each Entry In Mods CurseForgeHashes.Add(Entry.CurseForgeHash) - If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return + If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return Next - Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST", - $"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer) + Dim CurseForgeRaw As JContainer = DlModRequest("https://api.curseforge.com/v1/fingerprints/432", HttpMethod.Post, + $"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")("data")("exactMatches") Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息") '步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系 If Not CurseForgeRaw.Any() Then Return @@ -1034,12 +761,12 @@ Finished: If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File Next Next - If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return + If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息") '步骤 3：获取工程信息 If Not CurseForgeMapping.Any() Then Return - Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST", - $"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data") + Dim CurseForgeProject = DlModRequest("https://api.curseforge.com/v1/mods", HttpMethod.Post, + $"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")("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 @@ -1054,15 +781,15 @@ Finished: Entry.Comp = Project Next '查找或许版本更新的文件列表 - If ModLoaders.Count = 1 Then + If ModLoaders.IsSingle Then Dim NewestVersion As String = Nothing Dim NewestFileIds As New List(Of Integer) For Each IndexEntry In ProjectJson("latestFilesIndexes") If IndexEntry("modLoader") Is Nothing OrElse ModLoaders.Single <> IndexEntry("modLoader").ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配 Dim IndexVersion As String = IndexEntry("gameVersion") - If IndexVersion <> McVersion Then Continue For 'MC 版本匹配 + If IndexVersion <> VanillaVersion Then Continue For 'MC 版本匹配 '由于 latestFilesIndexes 是按时间从新到老排序的，所以只需取第一个；如果需要检查多个 releaseType 下的文件，将 > -1 改为 = 1，但这应当并不会获取到更新的文件 - If NewestVersion IsNot Nothing AndAlso VersionSortInteger(NewestVersion, IndexVersion) > -1 Then Continue For '只保留最新 MC 版本 + If NewestVersion IsNot Nothing AndAlso CompareVersion(NewestVersion, IndexVersion) > -1 Then Continue For '只保留最新 MC 版本 If NewestVersion <> IndexVersion Then NewestVersion = IndexVersion NewestFileIds.Clear() @@ -1079,8 +806,8 @@ Finished: Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息，需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息") '步骤 4：获取更新文件信息 If Not UpdateFileIds.Any() Then Return - Dim CurseForgeFiles = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", - $"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data") + Dim CurseForgeFiles = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, + $"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")("data") Dim UpdateFiles As New Dictionary(Of McMod, CompFile) For Each FileJson In CurseForgeFiles Dim File As New CompFile(FileJson, CompType.Mod) @@ -1112,10 +839,12 @@ Finished: EndedThreadCount += 1 End Try End Sub, "Mod List Detail Loader CurseForge") + '从 JAR 中获取缺失的版本信息（上面有另一个分支） + Loader.Input.Key.Where(Function(m) m.Version Is Nothing).ForEach(Sub(m) m.LoadMetadataFromJar()) '等待线程结束 Do Until EndedThreadCount = 2 - If Loader.IsAborted Then Return Thread.Sleep(10) + If Loader.IsInterrupted Then Return Loop '保存缓存 Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList() @@ -1123,154 +852,25 @@ Finished: If Not Mods.Any() Then Return For Each Entry In Mods Entry.CompLoaded = Not IsFailed - Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson() + Cache(Entry.ModrinthHash & VanillaVersion & ModLoaders.Join("")) = Entry.ToJson() Next WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None))) '刷新边栏 - If FrmVersionMod?.Filter = PageVersionMod.FilterType.CanUpdate Then - RunInUi(Sub() FrmVersionMod?.RefreshUI()) '同步 “可更新” 列表 (#4677) + If Loader.IsInterrupted Then Return + If FrmInstanceMod?.Filter = PageInstanceMod.FilterType.CanUpdate Then + RunInUi(Sub() FrmInstanceMod?.RefreshUI()) '同步 “可更新” 列表 (#4677) Else - RunInUi(Sub() FrmVersionMod?.RefreshBars()) + RunInUi(Sub() FrmInstanceMod?.RefreshBars()) End If End Sub Public Function GetTargetModLoaders() As List(Of CompModLoaderType) Dim ModLoaders As New List(Of CompModLoaderType) - If PageVersionLeft.Version.Version.HasForge Then ModLoaders.Add(CompModLoaderType.Forge) - If PageVersionLeft.Version.Version.HasNeoForge Then ModLoaders.Add(CompModLoaderType.NeoForge) - If PageVersionLeft.Version.Version.HasFabric Then ModLoaders.Add(CompModLoaderType.Fabric) - If PageVersionLeft.Version.Version.HasLiteLoader Then ModLoaders.Add(CompModLoaderType.LiteLoader) + If PageInstanceLeft.Instance.Version.HasForge Then ModLoaders.Add(CompModLoaderType.Forge) + If PageInstanceLeft.Instance.Version.HasNeoForge Then ModLoaders.Add(CompModLoaderType.NeoForge) + If PageInstanceLeft.Instance.Version.HasFabric Then ModLoaders.Add(CompModLoaderType.Fabric) + If PageInstanceLeft.Instance.Version.HasLiteLoader Then ModLoaders.Add(CompModLoaderType.LiteLoader) If Not ModLoaders.Any() Then ModLoaders.AddRange({CompModLoaderType.Forge, CompModLoaderType.NeoForge, CompModLoaderType.Fabric, CompModLoaderType.LiteLoader, CompModLoaderType.Quilt}) Return ModLoaders End Function -#If DEBUG Then - ''' - ''' 检查 Mod 列表中存在的错误，返回错误信息的集合。 - ''' - Public Function McModCheck(Version As McVersion, Mods As List(Of McMod)) As List(Of String) - Dim Result As New List(Of String) - '令所有 Mod 进行基础检查，并归纳需要检查的 Mod - Dim CurrentModList As New List(Of McMod) - For Each ModEntity In Mods - If Not ModEntity.IsFileAvailable Then - Result.Add("无法读取的 Mod 文件。" & vbCrLf & " - " & ModEntity.Path) - Continue For - End If - If ModEntity.State = McMod.McModState.Fine AndAlso ModEntity.ModId IsNot Nothing Then CurrentModList.Add(ModEntity) - Next - '添加默认依赖 - Dim CurrentDependencies As New Dictionary(Of String, String()) '{DependencyVersion, Path} - If Version.State = McVersionState.Forge Then CurrentDependencies.Add("forge", {Version.Version.ForgeVersion, "Forge"}) - CurrentDependencies.Add("minecraft", {Version.Version.McName, "Minecraft"}) - '检查重复的 Mod，并添加对应的依赖 - For Each ModEntity In CurrentModList - For Each PossibleModId In ModEntity.PossibleModId - If CurrentDependencies.ContainsKey(PossibleModId) Then - If CurrentDependencies(PossibleModId)(2) = 1 Then - Result.Add("重复添加了相同的 Mod，请尝试删除其中一个（ModID：" & PossibleModId & "）。" & vbCrLf & - " - " & ModEntity.FileName & vbCrLf & - " - " & CurrentDependencies(PossibleModId)(1)) - Else - Log("[Minecraft] 由于可能有多个 ModID，跳过疑似的重复项（ModID：" & PossibleModId & "）。" & vbCrLf & - " - " & ModEntity.FileName & vbCrLf & - " - " & CurrentDependencies(PossibleModId)(1), LogLevel.Developer) - End If - Else - CurrentDependencies.Add(PossibleModId, {ModEntity.Version, ModEntity.FileName, ModEntity.PossibleModId.Count}) - End If - Next - Next - '检查依赖 - For Each ModEntity In CurrentModList - Try - For Each Dependency In ModEntity.Dependencies - Dim ReqId As String = Dependency.Key - If ReqId.Count < 2 Then Continue For '确保正常 - If ReqId = ModEntity.ModId Then Continue For '跳过自体引用 - If ReqId = "forgemultipartcbe" Then Continue For '跳过莫名其妙的引用 - If Dependency.Value IsNot Nothing Then - '获取分段后的详细版本信息 - Dim ReqVersion As String = Dependency.Value - Dim ReqVersionHeadCanEqual As Boolean = ReqVersion.StartsWithF("[") - Dim ReqVersionTailCanEqual As Boolean = ReqVersion.EndsWithF("]") - Dim ReqVersionHead As String - Dim ReqVersionTail As String - If ReqVersion.Contains(",") Then - ReqVersionHead = ReqVersion.Split(",")(0).Trim("([ ".ToCharArray()) - ReqVersionTail = ReqVersion.Split(",")(1).Trim("]) ".ToCharArray()) - Else - ReqVersionHead = ReqVersion.Trim("([]) ".ToCharArray()) - ReqVersionTail = ReqVersionHead - If ReqId = "minecraft" AndAlso ReqVersionHead.Split(".").Count = 2 Then - ReqVersionTail = ReqVersionHead.Split(".")(0) & "." & (Val(ReqVersionHead.Split(".")(1)) + 1) - ReqVersionTailCanEqual = False - End If - End If - If ReqVersionHead.StartsWithF("1.") AndAlso ReqVersionHead.Contains("-") Then ReqVersionHead = ReqVersionHead.Substring(ReqVersionHead.LastIndexOfF("-") + 1) - If ReqVersionTail.StartsWithF("1.") AndAlso ReqVersionTail.Contains("-") Then ReqVersionTail = ReqVersionTail.Substring(ReqVersionTail.LastIndexOfF("-") + 1) - '获取报错描述文本 - Dim VersionRequire As String - If ReqVersionHead = ReqVersionTail Then - VersionRequire = "应为 " & ReqVersionHead - ElseIf ReqVersionHead.Contains(".") AndAlso ReqVersionTail.Contains(".") Then - VersionRequire = "应为 " & ReqVersionHead & " 至 " & ReqVersionTail - ElseIf ReqVersionHead.Contains(".") Then - If ReqVersionHeadCanEqual Then - VersionRequire = "最低应为 " & ReqVersionHead - Else - VersionRequire = "应高于 " & ReqVersionHead - End If - ElseIf ReqVersionTail.Contains(".") Then - If ReqVersionTailCanEqual Then - VersionRequire = "最高应为 " & ReqVersionHead - Else - VersionRequire = "应低于 " & ReqVersionHead - End If - Else - VersionRequire = "" - End If - '检查前置 Mod 是否存在，并获取其版本 - If Not CurrentDependencies.ContainsKey(ReqId) Then - Result.Add("缺少前置 Mod：" & ReqId & If(VersionRequire = "", "", "，其版本" & VersionRequire) & "。" & vbCrLf & " - " & ModEntity.FileName) - Continue For - End If - Dim CurrentVersion As String = If(CurrentDependencies(ReqId)(0), "0.0") - If CurrentVersion.StartsWithF("1.") AndAlso CurrentVersion.Contains("-") Then CurrentVersion = CurrentVersion.Substring(CurrentVersion.LastIndexOfF("-") + 1) - '对比前置 Mod 头部版本 - If ReqVersionHead.Contains(".") Then - If VersionSortInteger(ReqVersionHead, CurrentVersion) > If(ReqVersionHeadCanEqual, 0, -1) Then - Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过低，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf & - " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), "")) - Continue For - End If - End If - '对比前置 Mod 尾部版本 - If ReqVersionTail.Contains(".") Then - If VersionSortInteger(CurrentVersion, ReqVersionTail) > If(ReqVersionTailCanEqual, 0, -1) Then - Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过高，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf & - " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), "")) - Continue For - End If - End If - Else - If Not CurrentDependencies.ContainsKey(Dependency.Key) Then - Result.Add("缺少前置 Mod：" & Dependency.Key & "。" & vbCrLf & " - " & ModEntity.FileName) - Continue For - End If - End If - Next - Catch ex As Exception - Result.Add("检查 Mod 时出错：" & GetExceptionSummary(ex) & vbCrLf & " - " & ModEntity.FileName) - Log(ex, "检查 Mod 时出错") - End Try - Next - If Not Result.Any() Then - Log("[Minecraft] Mod 检查未发现异常") - Else - Log("[Minecraft] Mod 检查异常结果：" & vbCrLf & Join(Result, vbCrLf)) - End If - Return Result - End Function -#End If - End Module \ No newline at end of file diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb index ce0c443..5fd25d2 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb @@ -24,14 +24,14 @@ Public Module ModModpack ''' 必须在工作线程执行。 ''' ''' - Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String) + Public Function ModpackInstall(File As String, Optional InstanceName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String) Log("[ModPack] 整合包安装请求：" & If(File, "null")) Dim Archive As ZipArchive = Nothing Dim ArchiveBaseFolder As String = "" Try '字符校验 - Dim TargetFolder As String = $"{PathMcFolder}versions\{VersionName}\" - If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("游戏路径中不能含有感叹号或分号：" & TargetFolder, HintType.Critical) : Throw New CancelledException + Dim TargetFolder As String = $"{McFolderSelected}versions\{InstanceName}\" + If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("游戏路径中不能含有感叹号或分号：" & TargetFolder, HintType.Red) : Throw New CancelledException '获取整合包种类与关键 Json Dim PackType As Integer = -1 Try @@ -72,7 +72,7 @@ Public Module ModModpack If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包 Next Catch ex As Exception - If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then + If ex.GetDetail(True).Contains("Error.WinIOError") Then Throw New Exception("打开整合包文件失败", ex) ElseIf File.EndsWithF(".rar", True) Then Throw New Exception("PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", ex) @@ -84,7 +84,7 @@ Public Module ModModpack Select Case PackType Case 0 Log("[ModPack] 整合包种类：CurseForge") - Return InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName, Logo) + Return InstallPackCurseForge(File, Archive, ArchiveBaseFolder, InstanceName, Logo) Case 1 Log("[ModPack] 整合包种类：HMCL") Return InstallPackHMCL(File, Archive, ArchiveBaseFolder) @@ -93,10 +93,10 @@ Public Module ModModpack Return InstallPackMMC(File, Archive, ArchiveBaseFolder) Case 3 Log("[ModPack] 整合包种类：MCBBS") - Return InstallPackMCBBS(File, Archive, ArchiveBaseFolder, VersionName) + Return InstallPackMCBBS(File, Archive, ArchiveBaseFolder, InstanceName) Case 4 Log("[ModPack] 整合包种类：Modrinth") - Return InstallPackModrinth(File, Archive, ArchiveBaseFolder, VersionName, Logo) + Return InstallPackModrinth(File, Archive, ArchiveBaseFolder, InstanceName, Logo) Case 9 Log("[ModPack] 整合包种类：带启动器的压缩包") Return InstallPackLauncherPack(File, Archive, ArchiveBaseFolder) @@ -112,19 +112,14 @@ Public Module ModModpack Private Sub ExtractModpackFiles(InstallTemp As String, FileAddress As String, Loader As LoaderBase, ProgressIncrement As Double) '解压文件 Dim RetryCount As Integer = 1 - Dim Encode = Encoding.GetEncoding("GB18030") Dim InitialProgress = Loader.Progress Try Retry: Loader.Progress = InitialProgress DeleteDirectory(InstallTemp) - ExtractFile(FileAddress, InstallTemp, Encode, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * ProgressIncrement) + ExtractCompressedFile(FileAddress, InstallTemp, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * ProgressIncrement) Catch ex As Exception Log(ex, "第 " & RetryCount & " 次解压尝试失败") - If TypeOf ex Is ArgumentException Then - Encode = Encoding.UTF8 - Log("[ModPack] 已切换压缩包解压编码为 UTF8") - End If '完全不知道为啥会出现文件正在被另一进程使用的问题，总之加个重试 If RetryCount < 5 Then Thread.Sleep(RetryCount * 2000) @@ -158,6 +153,7 @@ Retry: If File.Exists(OverridesIni) Then WriteIni(OverridesIni, "VersionArgumentIndie", 1) '开启版本隔离 WriteIni(OverridesIni, "VersionArgumentIndieV2", True) + WriteIni(OverridesIni, "IsStar", False) CopyFile(OverridesIni, VersionIni) '覆写已有的 ini Else WriteIni(VersionIni, "VersionArgumentIndie", 1) '开启版本隔离 @@ -165,12 +161,21 @@ Retry: End If IniClearCache(VersionIni) '重置缓存，避免被安装过程中写入的 ini 覆盖 End Sub + ''' + ''' 弹窗提示整合包中存在不兼容的加载器。 + ''' 如果取消，则抛出 CancelledException。 + ''' + ''' + Private Sub NotifyIncompatibleLoader(LoaderName As String) + If MyMsgBox($"整合包中存在不兼容的加载器：{LoaderName}{vbCrLf}如果你知道如何手动安装它，可以先选择跳过，然后在整合包下载结束后手动安装。", + "不兼容的加载器", "取消", $"不安装 {LoaderName} 并继续") = 1 Then Throw New CancelledException + End Sub #Region "不同类型整合包的安装方法" 'CurseForge 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) + Optional InstanceName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String) '读取 Json 文件 Dim Json As JObject @@ -182,12 +187,12 @@ Retry: If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("CurseForge 整合包未提供 Minecraft 版本信息") '获取版本名 - If VersionName Is Nothing Then - VersionName = If(Json("name"), "") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") - If Validate.Validate(VersionName) <> "" Then VersionName = "" - If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException + If InstanceName Is Nothing Then + InstanceName = If(Json("name"), "") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") + If Validate.Validate(InstanceName) <> "" Then InstanceName = "" + If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Throw New CancelledException End If '获取 Mod API 版本信息 @@ -195,7 +200,7 @@ Retry: Dim NeoForgeVersion As String = Nothing Dim FabricVersion As String = Nothing For Each Entry In If(Json("minecraft")("modLoaders"), {}) - Dim Id As String = If(Entry("id"), "").ToString.ToLower + Dim Id As String = If(Entry("id"), "").ToString.Lower If Id.StartsWithF("forge-") Then 'Forge 指定 If Id.Contains("recommended") Then Throw New Exception("该整合包版本过老，已不支持进行安装！") @@ -210,7 +215,8 @@ Retry: Log("[ModPack] 整合包 Fabric 版本：" & Id) FabricVersion = Id.Replace("fabric-", "") Else - Log("[ModPack] 未知 Mod 加载器：" & Id) + 'ElseIf Id.StartsWithF("quilt-") Then + NotifyIncompatibleLoader(Id) End If Next '解压 @@ -223,7 +229,7 @@ Retry: ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & If(OverrideHome = "." OrElse OverrideHome = "./", "", OverrideHome), '#5613 - $"{PathMcFolder}versions\{VersionName}", + $"{McFolderSelected}versions\{InstanceName}", Task, 0.4) End Sub) With { .ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s @@ -244,7 +250,7 @@ Retry: '获取 Mod 下载信息 ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息", Sub(Task As LoaderTask(Of Integer, JArray)) - Task.Output = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data") + Task.Output = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & ModList.Join(",") & "]}", "application/json")("data") '如果文件已被删除，则 API 会跳过那一项 If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除，所以没法继续安装了，请向整合包作者反馈该问题") End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s @@ -267,7 +273,7 @@ Retry: If ModJson("modules").Any Then 'modules 可能返回 null（#1006） Dim ModuleNames = CType(ModJson("modules"), JArray).Select(Function(l) l("name").ToString).ToList If ModuleNames.Contains("META-INF") OrElse ModuleNames.Contains("mcmod.info") OrElse - ModJson?("FileName")?.ToString?.EndsWithF(".jar", True) Then + ModJson?("FileName")?.ToString.EndsWithF(".jar", True) Then TargetFolder = "mods" : Type = CompType.Mod ElseIf ModuleNames.Contains("pack.mcmeta") Then TargetFolder = "resourcepacks" : Type = CompType.ResourcePack @@ -281,7 +287,7 @@ Retry: Dim File As New CompFile(ModJson, Type) If Not File.Available Then Continue For '实际的添加 - FileList.Add(Id, File.ToNetFile($"{PathMcFolder}versions\{VersionName}\{TargetFolder}\")) + FileList.Add(Id, File.ToNetFile($"{McFolderSelected}versions\{InstanceName}\{TargetFolder}\")) Task.Progress += 1 / (1 + ModList.Count) Next Task.Output = FileList.Values.ToList @@ -295,8 +301,8 @@ Retry: '构造加载器 Dim Request As New McInstallRequest With { - .TargetVersionName = VersionName, - .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\", + .NewInstanceName = InstanceName, + .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\", .MinecraftName = Json("minecraft")("version").ToString, .ForgeVersion = ForgeVersion, .NeoForgeVersion = NeoForgeVersion, @@ -310,7 +316,7 @@ Retry: Loaders.Add(New LoaderTask(Of String, String)("最终整理文件", Sub(Task As LoaderTask(Of String, String)) '设置图标 - Dim VersionFolder As String = $"{PathMcFolder}versions\{VersionName}\" + Dim VersionFolder As String = $"{McFolderSelected}versions\{InstanceName}\" If Logo IsNot Nothing AndAlso File.Exists(Logo) Then File.Copy(Logo, VersionFolder & "PCL\Logo.png", True) WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png") @@ -324,22 +330,22 @@ Retry: File.Delete(Target) End If Next - If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then + If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then Log("[ModPack] 删除安装整合包文件：" & FileAddress) File.Delete(FileAddress) End If End Sub) With {.ProgressWeight = 0.1, .Show = False}) '重复任务检查 - Dim LoaderName As String = "CurseForge 整合包安装：" & VersionName & " " + Dim LoaderName As String = "CurseForge 整合包安装：" & InstanceName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager)) @@ -347,7 +353,7 @@ Retry: End Function 'Modrinth - 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) + Private Function InstallPackModrinth(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional InstanceName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String) '读取 Json 文件 Dim Json As JObject @@ -363,7 +369,7 @@ Retry: Dim NeoForgeVersion As String = Nothing Dim FabricVersion As String = Nothing For Each Entry As JProperty In If(Json("dependencies"), {}) - Select Case Entry.Name.ToLower + Select Case Entry.Name.Lower Case "minecraft" MinecraftVersion = Entry.Value.ToString Case "forge" 'eg. 14.23.5.2859 / 1.19-41.1.0 @@ -375,21 +381,18 @@ Retry: Case "fabric-loader" 'eg. 0.14.14 FabricVersion = Entry.Value.ToString Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion) - Case "quilt-loader" 'eg. 1.0.0 - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) - Throw New CancelledException Case Else - Hint($"无法安装整合包，其中出现了未知的 Mod 加载器 {Entry.Value}！", HintType.Critical) - Throw New CancelledException + 'Case "quilt-loader" 'eg. 1.0.0 + NotifyIncompatibleLoader(Entry.Name) End Select Next '获取版本名 - If VersionName Is Nothing Then - VersionName = If(Json("name"), "") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") - If Validate.Validate(VersionName) <> "" Then VersionName = "" - If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException + If InstanceName Is Nothing Then + InstanceName = If(Json("name"), "") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") + If Validate.Validate(InstanceName) <> "" Then InstanceName = "" + If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Throw New CancelledException End If '解压 Dim InstallTemp As String = RequestTaskTempFolder() @@ -399,11 +402,11 @@ Retry: ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.5) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & "overrides", - PathMcFolder & "versions\" & VersionName, + McFolderSelected & "versions\" & InstanceName, Task, 0.4) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & "client-overrides", - PathMcFolder & "versions\" & VersionName, + McFolderSelected & "versions\" & InstanceName, Task, 0.1) End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s '获取下载文件列表 @@ -425,8 +428,8 @@ Retry: Dim Urls = File("downloads").SelectMany(Function(t) CompFile.HandleCurseForgeDownloadUrls(t.ToString)).ToList Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList) Urls = Urls.Distinct.ToList() - Dim TargetPath As String = $"{PathMcFolder}versions\{VersionName}\{File("path")}" - If Not IO.Path.GetFullPath(TargetPath).StartsWithF($"{PathMcFolder}versions\{VersionName}\", True) Then + Dim TargetPath As String = $"{McFolderSelected}versions\{InstanceName}\{File("path")}" + If Not IO.Path.GetFullPath(TargetPath).StartsWithF($"{McFolderSelected}versions\{InstanceName}\", True) Then MyMsgBox($"整合包的文件路径超出了版本文件夹，请向整合包作者反馈此问题！" & vbCrLf & "错误的文件：" & TargetPath, "文件路径校验失败", IsWarn:=True) Throw New CancelledException End If @@ -439,8 +442,8 @@ Retry: '构造加载器 Dim Request As New McInstallRequest With { - .TargetVersionName = VersionName, - .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\", + .NewInstanceName = InstanceName, + .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\", .MinecraftName = MinecraftVersion, .ForgeVersion = ForgeVersion, .NeoForgeVersion = NeoForgeVersion, @@ -454,7 +457,7 @@ Retry: Loaders.Add(New LoaderTask(Of String, String)("最终整理文件", Sub(Task As LoaderTask(Of String, String)) '设置图标 - Dim VersionFolder As String = $"{PathMcFolder}versions\{VersionName}\" + Dim VersionFolder As String = $"{McFolderSelected}versions\{InstanceName}\" If Logo IsNot Nothing AndAlso File.Exists(Logo) Then File.Copy(Logo, VersionFolder & "PCL\Logo.png", True) WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png") @@ -468,22 +471,22 @@ Retry: File.Delete(Target) End If Next - If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then + If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then Log("[ModPack] 删除安装整合包文件：" & FileAddress) File.Delete(FileAddress) End If End Sub) With {.ProgressWeight = 0.1, .Show = False}) '重复任务检查 - Dim LoaderName As String = $"Modrinth 整合包安装：{VersionName} " + Dim LoaderName As String = $"Modrinth 整合包安装：{InstanceName} " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager)) @@ -500,11 +503,11 @@ Retry: Throw New Exception("HMCL 整合包安装信息存在问题", ex) End Try '获取版本名 - Dim VersionName As String = If(Json("name"), "") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") - If Validate.Validate(VersionName) <> "" Then VersionName = "" - If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException + Dim InstanceName As String = If(Json("name"), "") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") + If Validate.Validate(InstanceName) <> "" Then InstanceName = "" + If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Throw New CancelledException '解压 Dim InstallTemp As String = RequestTaskTempFolder() Dim InstallLoaders As New List(Of LoaderBase) @@ -513,14 +516,14 @@ Retry: ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & "minecraft", - PathMcFolder & "versions\" & VersionName, + McFolderSelected & "versions\" & InstanceName, Task, 0.4) End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s '构造游戏本体安装加载器 If Json("gameVersion") Is Nothing Then Throw New Exception("该 HMCL 整合包未提供游戏版本信息，无法安装！") Dim Request As New McInstallRequest With { - .TargetVersionName = VersionName, - .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\", + .NewInstanceName = InstanceName, + .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\", .MinecraftName = Json("gameVersion").ToString } Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request) @@ -530,14 +533,14 @@ Retry: New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)} } '重复任务检查 - Dim LoaderName As String = "HMCL 整合包安装：" & VersionName & " " + Dim LoaderName As String = "HMCL 整合包安装：" & InstanceName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager)) @@ -555,21 +558,21 @@ Retry: Throw New Exception("MMC 整合包安装信息存在问题", ex) End Try '获取版本名 - Dim VersionName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") - If Validate.Validate(VersionName) <> "" Then VersionName = "" - If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException + Dim InstanceName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") + If Validate.Validate(InstanceName) <> "" Then InstanceName = "" + If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Throw New CancelledException '解压 Dim InstallTemp As String = RequestTaskTempFolder() - Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini" + Dim SetupFile As String = $"{McFolderSelected}versions\{InstanceName}\PCL\Setup.ini" Dim InstallLoaders As New List(Of LoaderBase) InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件", Sub(Task As LoaderTask(Of String, Integer)) ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.55) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & ".minecraft", - PathMcFolder & "versions\" & VersionName, + McFolderSelected & "versions\" & InstanceName, Task, 0.4) '读取 MMC 设置文件（#2655） Try @@ -581,7 +584,7 @@ Retry: If Not Line.Contains("=") Then Continue For Lines.Add(Line.BeforeFirst("=") & ":" & Line.AfterFirst("=")) Next - WriteFile(MMCSetupFile, Join(Lines, vbCrLf)) + WriteFile(MMCSetupFile, Lines.Join(vbCrLf)) '读取文件 If ReadIni(MMCSetupFile, "OverrideCommands", False) Then Dim PreLaunchCommand As String = ReadIni(MMCSetupFile, "PreLaunchCommand") @@ -608,7 +611,7 @@ Retry: If Logo <> "" AndAlso File.Exists($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png") Then WriteIni(SetupFile, "LogoCustom", True) WriteIni(SetupFile, "Logo", "PCL\Logo.png") - CopyFile($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png", $"{PathMcFolder}versions\{VersionName}\PCL\Logo.png") + CopyFile($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png", $"{McFolderSelected}versions\{InstanceName}\PCL\Logo.png") Log($"[ModPack] 迁移 MultiMC 版本独立设置：版本图标（{Logo}.png）") End If 'JVM 参数 @@ -618,7 +621,7 @@ Retry: WriteIni(SetupFile, "VersionAdvanceJvm", JvmArgs) Log("[ModPack] 迁移 MultiMC 版本独立设置：JVM 参数（覆盖）：" & JvmArgs) Else - JvmArgs += " " & Setup.Get("LaunchAdvanceJvm") + JvmArgs += " " & Settings.Get("LaunchAdvanceJvm") WriteIni(SetupFile, "VersionAdvanceJvm", JvmArgs) Log("[ModPack] 迁移 MultiMC 版本独立设置：JVM 参数（追加）：" & JvmArgs) End If @@ -630,11 +633,11 @@ Retry: End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s '构造版本安装请求 If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息，无法安装！") - Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"} - For Each Component In PackJson("components") - Select Case If(Component("uid"), "").ToString - Case "org.lwjgl" - Log("[ModPack] 已跳过 LWJGL 项") + Dim Request As New McInstallRequest With {.NewInstanceName = InstanceName, .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\"} + For Each Component As JObject In PackJson("components") + If Not Component.ContainsKey("uid") Then Continue For + Dim UID As String = Component("uid").ToString + Select Case UID Case "net.minecraft" Request.MinecraftName = Component("version") Case "net.minecraftforge" @@ -643,9 +646,13 @@ Retry: Request.NeoForgeVersion = Component("version") Case "net.fabricmc.fabric-loader" Request.FabricVersion = Component("version") - Case "org.quiltmc.quilt-loader" 'eg. 1.0.0 - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) - Throw New CancelledException + 'Case "org.quiltmc.quilt-loader" 'eg. 1.0.0 + Case Else + If UID.StartsWithF("org.lwjgl") Then '#8210 + Log("[ModPack] 已跳过 LWJGL 项：" & UID) + Else + NotifyIncompatibleLoader(UID) + End If End Select Next '构造加载器 @@ -656,15 +663,15 @@ Retry: Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)}) '重复任务检查 - Dim LoaderName As String = "MMC 整合包安装：" & VersionName & " " + Dim LoaderName As String = "MMC 整合包安装：" & InstanceName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager)) @@ -673,7 +680,7 @@ Retry: 'MCBBS Private Function InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, - Optional VersionName As String = Nothing) As LoaderCombo(Of String) + Optional InstanceName As String = Nothing) As LoaderCombo(Of String) '读取 Json 文件 Dim Json As JObject Try @@ -683,23 +690,23 @@ Retry: Throw New Exception("MCBBS 整合包安装信息存在问题", ex) End Try '获取版本名 - If VersionName Is Nothing Then - VersionName = If(Json("name"), "") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") - If Validate.Validate(VersionName) <> "" Then VersionName = "" - If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException + If InstanceName Is Nothing Then + InstanceName = If(Json("name"), "") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") + If Validate.Validate(InstanceName) <> "" Then InstanceName = "" + If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Throw New CancelledException End If '解压 Dim InstallTemp As String = RequestTaskTempFolder() - Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini" + Dim SetupFile As String = $"{McFolderSelected}versions\{InstanceName}\PCL\Setup.ini" Dim InstallLoaders As New List(Of LoaderBase) InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件", Sub(Task As LoaderTask(Of String, Integer)) ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6) CopyOverrideDirectory( InstallTemp & ArchiveBaseFolder & "overrides", - PathMcFolder & "versions\" & VersionName, + McFolderSelected & "versions\" & InstanceName, Task, 0.4) 'JVM 参数 If Json("launchInfo") IsNot Nothing Then @@ -716,12 +723,12 @@ Retry: Next If Not Addons.ContainsKey("game") Then Throw New Exception("该 MCBBS 整合包未提供游戏版本信息，无法安装！") If Addons.ContainsKey("quilt") Then - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) + Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Red) Throw New CancelledException End If Dim Request As New McInstallRequest With { - .TargetVersionName = VersionName, - .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\", + .NewInstanceName = InstanceName, + .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\", .MinecraftName = Addons("game"), .OptiFineVersion = If(Addons.ContainsKey("optifine"), Addons("optifine"), Nothing), .ForgeVersion = If(Addons.ContainsKey("forge"), Addons("forge"), Nothing), @@ -735,16 +742,16 @@ Retry: Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)}) '重复任务检查 - Dim LoaderName As String = "MCBBS 整合包安装：" & VersionName & " " + Dim LoaderName As String = "MCBBS 整合包安装：" & InstanceName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState} 'If Archive IsNot Nothing Then Archive.Dispose() '解除占用，以免在加载器中触发 “正由另一进程使用，因此该进程无法访问此文件” - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.DownloadManager)) @@ -757,7 +764,7 @@ Retry: MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True) Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）") If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException - If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Throw New CancelledException + If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException '解压 Dim Loader As New LoaderCombo(Of String)("解压压缩包", { New LoaderTask(Of String, Integer)("解压压缩包", @@ -786,7 +793,7 @@ Retry: Log("[Modpack] 找到压缩包中附带的启动器：" & Launcher) If MyMsgBox($"整合包里似乎自带了启动器，是否换用它继续安装？{vbCrLf}即将打开：{Launcher}", "换用整合包启动器？", "换用", "不换用") = 1 Then OpenExplorer(TargetFolder) - ShellOnly(Launcher, "--wait") '要求等待已有的 PCL 退出 + StartProcess(Launcher, "--wait") '要求等待已有的 PCL 退出 Log("[Modpack] 为换用整合包中的启动器启动，强制结束程序") FrmMain.EndProgram(False) Return @@ -796,11 +803,11 @@ Retry: End If OpenExplorer(TargetFolder) '加入文件夹列表 - Dim VersionName As String = GetFolderNameFromPath(TargetFolder) + Dim InstanceName As String = GetFolderNameFromPath(TargetFolder) Directory.CreateDirectory(TargetFolder & ".minecraft\") PageSelectLeft.AddFolder( TargetFolder & ".minecraft\" & ArchiveBaseFolder.Replace("/", "\").TrimStart("\"), '格式例如：包裹文件夹\.minecraft\（最短为空字符串） - VersionName, False) + InstanceName, False) '调用 modpack 文件进行安装 Dim ModpackFile = Directory.GetFiles(TargetFolder, "modpack.*", SearchOption.AllDirectories).First Log("[Modpack] 调用 modpack 文件继续安装：" & ModpackFile) @@ -826,16 +833,15 @@ Retry: Exit For End If Next - If Match Is Nothing Then Throw New Exception("未能找到适合的文件结构，这可能不是一个 MC 压缩包") '没有匹配 + If Match Is Nothing Then Throw New Exception("文件结构不匹配，这可能不是 Minecraft 客户端压缩包？") '没有匹配 Dim ArchiveBaseFolder As String = Match.Value.Replace("/", "\").TrimStart("\") '格式例如：包裹文件夹\.minecraft\（最短为空字符串） - Dim VersionName As String = Match.Groups(1).Value - Log("[ModPack] 检测到压缩包的 .minecraft 根目录：" & ArchiveBaseFolder & "，命中的版本名：" & VersionName) + Log("[ModPack] 检测到压缩包的 .minecraft 根目录：" & ArchiveBaseFolder & "，命中的版本名：" & Match.Groups(1).Value) '获取解压路径 MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True) Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）") If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException - If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Throw New CancelledException - If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Throw New CancelledException + If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Red) : Throw New CancelledException + If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException '解压 Dim Loader As New LoaderCombo(Of String)("解压压缩包", { New LoaderTask(Of String, Integer)("解压压缩包", @@ -844,7 +850,7 @@ Retry: '加入文件夹列表 PageSelectLeft.AddFolder(TargetFolder & ArchiveBaseFolder, GetFolderNameFromPath(TargetFolder), False) Thread.Sleep(400) '避免文件争用 - RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.VersionSelect)) + RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.InstanceSelect)) End Sub) }) With {.OnStateChanged = AddressOf McInstallState} Loader.Start(TargetFolder) diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb index 54ce14b..686ae40 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb @@ -33,13 +33,13 @@ HasRunningMinecraft = False FrmMain.BtnExtraShutdown.ShowRefresh() '音乐播放 - If Setup.Get("UiMusicStop") Then + If Settings.Get("UiMusicStop") Then RunInUi(Sub() If MusicResume() Then Log("[Music] 已根据设置，在结束后开始音乐播放")) - ElseIf Setup.Get("UiMusicStart") Then + ElseIf Settings.Get("UiMusicStart") Then RunInUi(Sub() If MusicPause() Then Log("[Music] 已根据设置，在结束后暂停音乐播放")) End If '启动器可见性 - Select Case Setup.Get("LaunchArgumentVisible") + Select Case Settings.Get("LaunchArgumentVisible") Case 2 '直接关闭 If TriggerLauncherShutdown Then @@ -58,13 +58,13 @@ '初始化 Public GameProcess As Process - Public Version As McVersion + Public Instance As McInstance Private WindowTitle As String = "" Private PID As Integer Public Loader As LoaderTask(Of Process, Integer) - Public Sub New(Loader As LoaderTask(Of Process, Integer), Version As McVersion, WindowTitle As String) + Public Sub New(Loader As LoaderTask(Of Process, Integer), Instance As McInstance, WindowTitle As String) Me.Loader = Loader - Me.Version = Version + Me.Instance = Instance Me.WindowTitle = WindowTitle Me.PID = Loader.Input.Id WatcherLog("开始 Minecraft 日志监控") @@ -91,13 +91,13 @@ RunInNewThread( Sub() Try - Do Until State = MinecraftState.Ended OrElse State = MinecraftState.Crashed OrElse State = MinecraftState.Canceled OrElse Loader.State = LoadState.Aborted + Do Until State = MinecraftState.Ended OrElse State = MinecraftState.Crashed OrElse State = MinecraftState.Canceled OrElse Loader.State = LoadState.Interrupted 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")) + 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) @@ -164,7 +164,7 @@ '窗口未出现 WatcherLog("Minecraft 尚未加载完成，可能已崩溃") Crashed() - ElseIf GameProcess.ExitCode <> 0 AndAlso State = MinecraftState.Running AndAlso Version.ReleaseTime.Year >= 2012 Then + ElseIf GameProcess.ExitCode <> 0 AndAlso State = MinecraftState.Running AndAlso Instance.ReleaseTime.Year >= 2012 Then '返回值不为 0 且未结束 WatcherLog("Minecraft 返回值异常，可能已崩溃") Crashed() @@ -277,7 +277,7 @@ WatcherLog($"Minecraft 窗口已加载：{MinecraftWindowName}（{MinecraftWindowHandle.ToInt64}）") IsWindowFinished = True '最大化 - If Setup.Get("LaunchArgumentWindowType") = 4 Then + If Settings.Get("LaunchArgumentWindowType") = 4 Then RunInNewThread( Sub() Try @@ -349,19 +349,19 @@ State = MinecraftState.Crashed '崩溃分析 WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析") - Hint("检测到 Minecraft 出现错误，错误分析已开始……") + Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Red) FeedbackInfo() RunInNewThread( Sub() Try Thread.Sleep(2000) WatcherLog("崩溃分析开始") - Dim Analyzer As New CrashAnalyzer(PID) - Analyzer.Collect(Version.PathIndie, LatestLog.ToList) + Dim Analyzer As New CrashAnalyzer(Instance) + Analyzer.Collect(Instance.PathIndie, LatestLog.ToList) Analyzer.Prepare() - Analyzer.Analyze(Version) + Analyzer.Analyze() Analyzer.Output(False, New List(Of String) From - {Version.Path & Version.Name & ".json", Path & "PCL\Log1.txt", Path & "PCL\LatestLaunch.bat"}) + {Instance.PathVersion & Instance.Name & ".json", Path & "PCL\Log1.txt", Path & "PCL\LatestLaunch.bat"}) Catch ex As Exception Log(ex, "崩溃分析失败", LogLevel.Feedback) End Try diff --git a/Plain Craft Launcher 2/Modules/ModEvent.vb b/Plain Craft Launcher 2/Modules/ModEvent.vb index 693f4ca..441ac30 100644 --- a/Plain Craft Launcher 2/Modules/ModEvent.vb +++ b/Plain Craft Launcher 2/Modules/ModEvent.vb @@ -1,125 +1,334 @@ -Public Module ModEvent + +#Region "附加属性" - Public Sub TryStartEvent(Type As String, Data As String) - If String.IsNullOrWhiteSpace(Type) Then Return - Dim RealData As String() = {""} - If Data IsNot Nothing Then RealData = Data.Split("|") - StartEvent(Type, RealData) +''' +''' 用于在 XAML 中初始化列表对象。 +''' 附加属性无法在 XAML 中为每个对象初始化独立的列表对象，因此需要一个包装类，然后在 XAML 中显式初始化。 +''' + +Public Class CustomEventCollection + Implements IEnumerable(Of CustomEvent) + Dim _Events As New List(Of CustomEvent) + Public ReadOnly Property Events As List(Of CustomEvent) + Get + Return _Events + End Get + End Property + Public Function GetEnumerator() As IEnumerator(Of CustomEvent) Implements IEnumerable(Of CustomEvent).GetEnumerator + Return DirectCast(Events, IEnumerable(Of CustomEvent)).GetEnumerator() + End Function + Private Function IEnumerable_GetEnumerator() As IEnumerator Implements IEnumerable.GetEnumerator + Return DirectCast(Events, IEnumerable).GetEnumerator() + End Function +End Class + +''' +''' 提供自定义事件的附加属性。 +''' +Public Class CustomEventService + + 'Events + Public Shared ReadOnly EventsProperty As DependencyProperty = + DependencyProperty.RegisterAttached("Events", GetType(CustomEventCollection), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEvents(d As DependencyObject, value As CustomEventCollection) + d.SetValue(EventsProperty, value) End Sub - Public Sub StartEvent(Type As String, Data As String()) - Try - Log("[Control] 执行自定义事件：" & Type & ", " & Join(Data, ", ")) - Select Case Type + + Public Shared Function GetEvents(d As DependencyObject) As CustomEventCollection + If d.GetValue(EventsProperty) Is Nothing Then d.SetValue(EventsProperty, New CustomEventCollection) + Return d.GetValue(EventsProperty) + End Function - Case "打开网页" - Data(0) = Data(0).Replace("\", "/") - If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议（#2200） + 'EventType + Public Shared ReadOnly EventTypeProperty As DependencyProperty = + DependencyProperty.RegisterAttached("EventType", GetType(CustomEvent.EventType), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEventType(d As DependencyObject, value As CustomEvent.EventType) + d.SetValue(EventTypeProperty, value) + End Sub + + Public Shared Function GetEventType(d As DependencyObject) As CustomEvent.EventType + Return d.GetValue(EventTypeProperty) + End Function + + 'EventData + Public Shared ReadOnly EventDataProperty As DependencyProperty = + DependencyProperty.RegisterAttached("EventData", GetType(String), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEventData(d As DependencyObject, value As String) + d.SetValue(EventDataProperty, value) + End Sub + + Public Shared Function GetEventData(d As DependencyObject) As String + Return d.GetValue(EventDataProperty) + End Function + +End Class + +Partial Public Module ModMain + + ''' + ''' 触发该控件上的自定义事件。 + ''' 事件会在新线程中执行。 + ''' + + Public Sub RaiseCustomEvent(Control As DependencyObject) + '收集事件列表 + Dim Events = CustomEventService.GetEvents(Control).ToList + Dim EventType = CustomEventService.GetEventType(Control) + If EventType <> CustomEvent.EventType.None Then Events.Add(New CustomEvent(EventType, CustomEventService.GetEventData(Control))) + '执行事件 + If Not Events.Any Then Return + RunInNewThread( + Sub() + For Each e In Events + e.Raise() + Next + End Sub, "执行自定义事件 " & GetUuid()) + End Sub + +End Module + +#End Region + +''' +''' 自定义事件。 +''' +Public Class CustomEvent + Inherits DependencyObject + +#Region "属性与触发" + + Public Property Type As EventType + Get + Dim Value As EventType = EventType.None + RunInUiWait(Sub() Value = GetValue(TypeProperty)) + Return Value + End Get + Set(value As EventType) + SetValue(TypeProperty, value) + End Set + End Property + Public Shared ReadOnly TypeProperty As DependencyProperty = + DependencyProperty.Register("Type", GetType(EventType), GetType(CustomEvent), New PropertyMetadata(EventType.None)) + + Public Property Data As String + Get + Dim Value As String = Nothing + RunInUiWait(Sub() Value = GetValue(DataProperty)) + Return Value + End Get + Set(value As String) + SetValue(DataProperty, value) + End Set + End Property + Public Shared ReadOnly DataProperty As DependencyProperty = + DependencyProperty.Register("Data", GetType(String), GetType(CustomEvent), New PropertyMetadata(Nothing)) + + Public Sub New() + End Sub + Public Sub New(Type As EventType, Data As String) + Me.Type = Type + Me.Data = Data + End Sub + + ''' + ''' 在当前线程中触发该自定义事件。 + ''' + Public Sub Raise() + Raise(Type, Data) + End Sub + +#End Region + + Public Enum EventType + None = 0 + 打开网页 + 打开文件 + 打开帮助 + 执行命令 + 启动游戏 + 复制文本 + 刷新主页 + 刷新页面 + 刷新帮助 + 今日人品 + 内存优化 + 清理垃圾 + 弹出窗口 + 弹出提示 + 切换页面 + 导入整合包 + 安装整合包 + 下载文件 + 修改设置 + 写入设置 + 修改变量 + 写入变量 + 加入房间 + 检查更新 + End Enum + + ''' + ''' 在当前线程中触发一个自定义事件。 + ''' + Public Shared Sub Raise(Type As EventType, Arg As String) + If Type = EventType.None Then Return + Log($"[Control] 执行自定义事件：{Type}, {Arg}") + If Arg Is Nothing Then Arg = "" + Dim Args As String() = Arg.Split("|") + Try + Select Case Type + Case EventType.打开网页 + Arg = Arg.Replace("\", "/") + If Not Arg.Contains("://") OrElse Arg.StartsWithF("file", True) Then '为了支持更多协议（#2200） MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败") Return End If - Hint("正在开启中，请稍候……") - OpenWebsite(Data(0)) + Hint("正在开启中，请稍候：" & Arg) + RunInThread(Sub() OpenWebsite(Arg)) - Case "打开文件", "打开帮助", "执行命令" + Case EventType.打开文件, EventType.打开帮助, EventType.执行命令 RunInThread( Sub() Try '确认实际路径 - Dim ActualPaths = GetEventAbsoluteUrls(Data(0), Type) + Dim ActualPaths = GetAbsoluteUrls(Args(0), Type) Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1) Log($"[Control] 打开类自定义事件实际路径：{Location}，工作目录：{WorkingDir}") '执行 - If Type = "打开帮助" Then + If Type = EventType.打开帮助 Then PageOtherHelp.EnterHelpPage(Location) Else - If Not Setup.Get("HintCustomCommand") Then - Select Case MyMsgBox( - "即将执行：" & Location & If(Data.Length >= 2, " " & Data(1), "") & vbCrLf & - "请在确认该操作没有安全隐患后继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消") - Case 2 - Setup.Set("HintCustomCommand", True) - Case 3 - Return - End Select - End If + If Not EventSafetyConfirm("即将执行：" & Location & If(Args.Length >= 2, " " & Args(1), "")) Then Return Dim Info As New ProcessStartInfo With { - .Arguments = If(Data.Length >= 2, Data(1), ""), + .Arguments = If(Args.Length >= 2, Args(1), ""), .FileName = Location, - .WorkingDirectory = ShortenPath(WorkingDir) + .WorkingDirectory = WorkingDir } - Process.Start(Info) + StartProcess(Info) End If Catch ex As Exception Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox) End Try End Sub) - Case "启动游戏" - If Data(0) = "\current" Then - If McVersionCurrent Is Nothing Then - Hint("请先选择一个 Minecraft 版本！", HintType.Critical) + Case EventType.启动游戏 + If Args(0) = "\current" Then + If McInstanceSelected Is Nothing Then + Hint("请先选择一个 Minecraft 版本！", HintType.Red) Return Else - Data(0) = McVersionCurrent.Name + Args(0) = McInstanceSelected.Name End If End If - If McLaunchStart(New McLaunchOptions With - {.ServerIp = If(Data.Length >= 2, Data(1), Nothing), .Version = New McVersion(Data(0))}) Then - Hint("正在启动 " & Data(0) & "……") + RunInUi( + Sub() + If McLaunchStart(New McLaunchOptions With + {.ServerIp = If(Args.Length >= 2, Args(1), Nothing), .Instance = New McInstance(Args(0))}) Then + Hint($"正在启动 {Args(0)}……") + End If + End Sub) + + Case EventType.复制文本 + ClipboardSet(Arg) + + Case EventType.刷新主页 + RunInUi( + Sub() + FrmLaunchRight.ForceRefresh() + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) + End Sub) + + Case EventType.刷新页面 + If TypeOf FrmMain.PageRight Is IRefreshable Then + RunInUiWait(Sub() CType(FrmMain.PageRight, IRefreshable).Refresh()) + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) + Else + Hint("当前页面不支持刷新操作！", HintType.Red) End If - Case "复制文本" - ClipboardSet(Join(Data, "|")) + Case EventType.刷新帮助 + RunInUiWait(Sub() PageOtherLeft.RefreshHelp()) + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) - Case "刷新主页" - FrmLaunchRight.ForceRefresh() - If Data(0) = "" Then Hint("已刷新主页！", HintType.Finish) - - Case "刷新帮助" - PageOtherLeft.RefreshHelp() - - Case "今日人品" + Case EventType.今日人品 PageOtherTest.Jrrp() - Case "内存优化" + Case EventType.内存优化 RunInThread(Sub() PageOtherTest.MemoryOptimize(True)) - Case "清理垃圾" + Case EventType.清理垃圾 RunInThread(Sub() PageOtherTest.RubbishClear()) - Case "弹出窗口" - MyMsgBox(Data(1).Replace("\n", vbCrLf), Data(0).Replace("\n", vbCrLf)) + Case EventType.弹出窗口 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 弹窗标题|弹窗内容") + MyMsgBox(Args(1).Replace("\n", vbCrLf), Args(0).Replace("\n", vbCrLf), If(Args.Length > 2, Args(2), "确定")) - Case "切换页面" - FrmMain.PageChange(Val(Data(0)), Val(Data(1))) + Case EventType.弹出提示 + Hint(Args(0).Replace("\n", vbCrLf), If(Args.Length = 1, HintType.Blue, Args(1).ParseToEnum(Of HintType))) - Case "导入整合包", "安装整合包" + Case EventType.切换页面 + RunInUi(Sub() FrmMain.PageChange( + Args(0).ParseToEnum(Of FormMain.PageType), + If(Args.Length = 1, FormMain.PageSubType.Default, Args(1).ParseToEnum(Of FormMain.PageSubType)))) + + Case EventType.导入整合包, EventType.安装整合包 RunInUi(Sub() ModpackInstall()) - Case "下载文件" - Data(0) = Data(0).Replace("\", "/") - If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then + Case EventType.下载文件 + Args(0) = Args(0).Replace("\", "/") + If Not (Args(0).StartsWithF("http://", True) OrElse Args(0).StartsWithF("https://", True)) Then MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败") Return End If - Try - Select Case Data.Length - Case 1 - PageOtherTest.StartCustomDownload(Data(0), GetFileNameFromPath(Data(0))) - Case 2 - PageOtherTest.StartCustomDownload(Data(0), Data(1)) - Case Else - PageOtherTest.StartCustomDownload(Data(0), Data(1), Data(2)) - End Select - Catch - PageOtherTest.StartCustomDownload(Data(0), "未知") - End Try + If Not EventSafetyConfirm("即将从该网址下载文件：" & vbCrLf & Args(0)) Then Return + RunInUi( + Sub() + Try + Select Case Args.Length + Case 1 + PageOtherTest.StartCustomDownload(Args(0), GetFileNameFromPath(Args(0))) + Case 2 + PageOtherTest.StartCustomDownload(Args(0), Args(1)) + Case Else + PageOtherTest.StartCustomDownload(Args(0), Args(1), Args(2)) + End Select + Catch + PageOtherTest.StartCustomDownload(Args(0), "未知") + End Try + End Sub) + + Case EventType.修改设置, EventType.写入设置 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 UiLauncherTransparent|400") + Settings.SetSafe(Args(0), Args(1), Instance:=McInstanceSelected) + If Args.Length = 2 Then Hint($"已写入设置：{Args(0)} → {Args(1)}", HintType.Green) + + Case EventType.修改变量, EventType.写入变量 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 VariableName|SomeValue") + WriteReg("CustomEvent" & Args(0), Args(1)) + If Args.Length = 2 Then Hint($"已写入变量：{Args(0)} → {Args(1)}", HintType.Green) + + Case EventType.加入房间 + RunInUi( + Sub() + If String.IsNullOrWhiteSpace(Arg) Then + PageLinkMain.Join() + Else + If Not EventSafetyConfirm("即将加入第三方联机房间。") Then Return + PageLinkMain.Join(Arg) + End If + End Sub) + + Case EventType.检查更新 + UpdateCheckByButton() Case Else MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败") End Select Catch ex As Exception - Log(ex, "事件执行失败", LogLevel.Msgbox) + Log(ex, $"事件执行失败（{Type}, {Arg}）", LogLevel.Msgbox) End Try End Sub @@ -127,7 +336,7 @@ ''' 返回自定义事件的绝对 Url。实际返回 {绝对 Url, WorkingDir}。 ''' 失败会抛出异常。 ''' - Public Function GetEventAbsoluteUrls(RelativeUrl As String, EventType As String) As String() + Public Shared Function GetAbsoluteUrls(RelativeUrl As String, Type As EventType) As String() '网页确认 If RelativeUrl.StartsWithF("http", True) Then @@ -160,7 +369,7 @@ End Try RelativeUrl = LocalTemp End If - RelativeUrl = RelativeUrl.Replace("/", "\").ToLower.TrimStart("\") + RelativeUrl = RelativeUrl.Replace("/", "\").Lower.TrimStart("\") '确认实际路径 Dim Location As String, WorkingDir As String = Path & "PCL" @@ -168,25 +377,25 @@ If RelativeUrl.Contains(":\") Then '绝对路径 Location = RelativeUrl - Log("[Control] 自定义事件中由绝对路径" & EventType & "：" & Location) + Log("[Control] 自定义事件中由绝对路径" & Type & "：" & Location) ElseIf File.Exists(Path & "PCL\" & RelativeUrl) Then '相对 PCL 文件夹的路径 Location = Path & "PCL\" & RelativeUrl - Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & EventType & "：" & Location) + Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & Type & "：" & Location) ElseIf File.Exists(Path & "PCL\Help\" & RelativeUrl) Then '相对 PCL 本地帮助文件夹的路径 Location = Path & "PCL\Help\" & RelativeUrl WorkingDir = Path & "PCL\Help\" - Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & EventType & "：" & Location) - ElseIf EventType = "打开帮助" AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then + Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & Type & "：" & Location) + ElseIf Type = EventType.打开帮助 AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then '相对 PCL 自带帮助文件夹的路径 Location = PathTemp & "Help\" & RelativeUrl WorkingDir = PathTemp & "Help\" - Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & EventType & "：" & Location) - ElseIf EventType = "打开文件" OrElse EventType = "执行命令" Then + Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & Type & "：" & Location) + ElseIf Type = EventType.打开文件 OrElse Type = EventType.执行命令 Then '直接使用原有路径启动程序 Location = RelativeUrl - Log("[Control] 自定义事件中直接" & EventType & "：" & Location) + Log("[Control] 自定义事件中直接" & Type & "：" & Location) Else '打开帮助，但是格式不对劲 Throw New FileNotFoundException("未找到 EventData 指向的本地 xaml 文件：" & RelativeUrl, RelativeUrl) @@ -195,4 +404,20 @@ Return {Location, WorkingDir} End Function -End Module + ''' + ''' 弹出安全确认弹窗。返回是否继续执行。 + ''' + Private Shared Function EventSafetyConfirm(Message As String) As Boolean + If Settings.Get("HintCustomCommand") Then Return True + Select Case MyMsgBox(Message & vbCrLf & "请在确认没有安全隐患后再继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消") + Case 1 + Return True + Case 2 + Settings.Set("HintCustomCommand", True) + Return True + Case Else + Return False + End Select + End Function + +End Class diff --git a/Plain Craft Launcher 2/Modules/ModMain.vb b/Plain Craft Launcher 2/Modules/ModMain.vb index 2ceb04c..96e2ba0 100644 --- a/Plain Craft Launcher 2/Modules/ModMain.vb +++ b/Plain Craft Launcher 2/Modules/ModMain.vb @@ -7,23 +7,12 @@ Public Module ModMain ''' ''' 提示信息的种类。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum HintType - ''' - ''' 信息，通常是蓝色的“i”。 - ''' - ''' - Info - ''' - ''' 已完成，通常是绿色的“√”。 - ''' - ''' - Finish - ''' - ''' 错误，通常是红色的“×”。 - ''' - ''' - Critical + Blue + Green + Red End Enum Private Structure HintMessage Public Text As String @@ -38,7 +27,7 @@ Public Module ModMain ''' ''' 在窗口左下角弹出提示文本。 ''' - Public Sub Hint(Text As String, Optional Type As HintType = HintType.Info, Optional Log As Boolean = True) + Public Sub Hint(Text As String, Optional Type As HintType = HintType.Blue, Optional Log As Boolean = True) If HintWaiting Is Nothing Then HintWaiting = New SafeList(Of HintMessage) HintWaiting.Add(New HintMessage With {.Text = If(Text, ""), .Type = Type, .Log = Log}) End Sub @@ -68,13 +57,13 @@ Public Module ModMain Dim TargetColor0, TargetColor1 As MyColor Dim Percent As Double = 0.3 Select Case CurrentHint.Type - Case HintType.Info + Case HintType.Blue TargetColor0 = New MyColor(215, 37, 155, 252) TargetColor1 = New MyColor(215, 10, 142, 252) - Case HintType.Finish + Case HintType.Green TargetColor0 = New MyColor(215, 33, 177, 33) TargetColor1 = New MyColor(215, 29, 160, 29) - Case Else 'HintType.Critical + Case Else 'HintType.Red TargetColor0 = New MyColor(215, 255, 53, 11) TargetColor1 = New MyColor(215, 255, 43, 0) End Select @@ -177,7 +166,7 @@ EndHint: Public Text As String ''' ''' 输入模式：文本框的文本。 - ''' 选择模式：需要放进去的 List(Of MyListItem)。 + ''' 选择模式：需要放进去的 IEnumberable(Of IMyRadio)。 ''' 登录模式：登录步骤 1 中返回的 JSON。 ''' Public Content As Object @@ -248,10 +237,6 @@ EndHint: '将弹窗列入队列 Dim Converter As New MyMsgBoxConverter With {.Type = MyMsgBoxType.Text, .Button1 = Button1, .Button2 = Button2, .Button3 = Button3, .Text = Caption, .IsWarn = IsWarn, .Title = Title, .HighLight = HighLight, .ForceWait = True, .Button1Action = Button1Action, .Button2Action = Button2Action, .Button3Action = Button3Action} WaitingMyMsgBox.Add(Converter) - If RunInUi() Then - '若为 UI 线程，立即执行弹窗刻， 避免快速（连点器）点击时多次弹窗 - MyMsgBoxTick() - End If If Button2.Length > 0 OrElse ForceWait Then '若有多个按钮则开始等待 If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing AndAlso RunInUi() Then @@ -275,6 +260,7 @@ EndHint: Else Try FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -306,6 +292,7 @@ EndHint: '虽然我也不知道这是啥但是能用就成了 :) Try If FrmMain IsNot Nothing Then FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -321,13 +308,14 @@ EndHint: ''' 显示的第一个按钮，默认为 “确定”。 ''' 显示的第二个按钮，默认为空。 ''' 是否为警告弹窗，若为 True，弹窗配色和背景会变为红色。 - Public Function MyMsgBoxSelect(Selections As List(Of IMyRadio), Optional Title As String = "提示", Optional Button1 As String = "确定", Optional Button2 As String = "", Optional IsWarn As Boolean = False) As Integer? + Public Function MyMsgBoxSelect(Selections As IEnumerable(Of IMyRadio), Optional Title As String = "提示", Optional Button1 As String = "确定", Optional Button2 As String = "", Optional IsWarn As Boolean = False) As Integer? '将弹窗列入队列 Dim Converter As New MyMsgBoxConverter With {.Type = MyMsgBoxType.Select, .Button1 = Button1, .Button2 = Button2, .Content = Selections, .IsWarn = IsWarn, .Title = Title} WaitingMyMsgBox.Add(Converter) '虽然我也不知道这是啥但是能用就成了 :) Try If FrmMain IsNot Nothing Then FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -350,7 +338,7 @@ EndHint: ElseIf WaitingMyMsgBox.Any Then '没有弹窗，显示一个等待的弹窗 FrmMain.PanMsg.Visibility = Visibility.Visible - Select Case CType(WaitingMyMsgBox(0), MyMsgBoxConverter).Type + Select Case WaitingMyMsgBox(0).Type Case MyMsgBoxType.Input FrmMain.PanMsg.Children.Add(New MyMsgInput(WaitingMyMsgBox(0))) Case MyMsgBoxType.Select @@ -363,7 +351,7 @@ EndHint: WaitingMyMsgBox.RemoveAt(0) Else '没有弹窗，没有等待的弹窗 - If Not FrmMain.PanMsg.Visibility = Visibility.Collapsed Then FrmMain.PanMsg.Visibility = Visibility.Collapsed + If FrmMain.PanMsg.Visibility <> Visibility.Collapsed Then FrmMain.PanMsg.Visibility = Visibility.Collapsed End If Catch ex As Exception Log(ex, "处理等待中的弹窗失败", LogLevel.Feedback) @@ -388,21 +376,11 @@ EndHint: Public FrmSpeedRight As PageSpeedRight '联机页面声明 - Public FrmLinkLeft As PageLinkLeft - Public FrmLinkIoi As PageLinkIoi - Public FrmLinkHiper As PageLinkHiper - Public FrmLinkHelp As PageOtherHelpDetail - Public FrmLinkFeedback As PageLinkFeedback + Public FrmLinkMain As PageLinkMain '下载页面声明 Public FrmDownloadLeft As PageDownloadLeft Public FrmDownloadInstall As PageDownloadInstall - Public FrmDownloadClient As PageDownloadClient - Public FrmDownloadOptiFine As PageDownloadOptiFine - Public FrmDownloadLiteLoader As PageDownloadLiteLoader - Public FrmDownloadForge As PageDownloadForge - Public FrmDownloadNeoForge As PageDownloadNeoForge - Public FrmDownloadFabric As PageDownloadFabric Public FrmDownloadMod As PageDownloadMod Public FrmDownloadPack As PageDownloadPack Public FrmDownloadDataPack As PageDownloadDataPack @@ -432,12 +410,12 @@ EndHint: Public FrmLoginMsSkin As PageLoginMsSkin '版本设置页面声明 - Public FrmVersionLeft As PageVersionLeft - Public FrmVersionOverall As PageVersionOverall - Public FrmVersionMod As PageVersionMod - Public FrmVersionModDisabled As PageVersionModDisabled - Public FrmVersionSetup As PageVersionSetup - Public FrmVersionExport As PageVersionExport + Public FrmInstanceLeft As PageInstanceLeft + Public FrmInstanceOverall As PageInstanceOverall + Public FrmInstanceMod As PageInstanceMod + Public FrmInstanceModDisabled As PageInstanceModDisabled + Public FrmInstanceSetup As PageInstanceSetup + Public FrmInstanceExport As PageInstanceExport '资源信息分页声明 Public FrmDownloadCompDetail As PageDownloadCompDetail @@ -496,7 +474,7 @@ EndHint: ''' 是否为 “执行事件”。 ''' Public IsEvent As Boolean - Public EventType As String + Public EventType As CustomEvent.EventType Public EventData As String ''' ''' 若非执行事件，其对应的 .xaml 本地文件内容。 @@ -510,7 +488,7 @@ EndHint: ''' Public Sub New(FilePath As String) RawPath = FilePath - Dim JsonData As JObject = GetJson(HelpArgumentReplace(ReadFile(FilePath))) + Dim JsonData As JObject = GetJson(ArgumentReplace(ReadFile(FilePath), AddressOf EscapeXML)) If JsonData Is Nothing Then Throw New FileNotFoundException("未找到帮助文件：" & FilePath, FilePath) '加载常规信息 If JsonData("Title") IsNot Nothing Then @@ -530,12 +508,11 @@ EndHint: Next '加载事件信息 If If(JsonData("IsEvent"), False) Then - EventType = JsonData("EventType") - If EventType Is Nothing Then Throw New ArgumentException("未找到 EventType 项") + EventType = [Enum].Parse(GetType(CustomEvent.EventType), JsonData("EventType").ToString) EventData = If(JsonData("EventData"), "") IsEvent = True Else - Dim XamlAddress As String = FilePath.ToLower.Replace(".json", ".xaml") + Dim XamlAddress As String = FilePath.Lower.Replace(".json", ".xaml") If File.Exists(XamlAddress) Then XamlContent = ReadFile(XamlAddress) IsEvent = False @@ -556,7 +533,7 @@ EndHint: Public Function SetToListItem(Item As MyListItem) As MyListItem Dim Logo As String If IsEvent Then - If EventType = "弹出窗口" Then + If EventType = CustomEvent.EventType.弹出窗口 Then Logo = PathImage & "Blocks/GrassPath.png" Else Logo = PathImage & "Blocks/CommandBlock.png" @@ -573,9 +550,9 @@ EndHint: .Height = 42 .Type = MyListItem.CheckType.Clickable .Tag = Me - .EventType = Nothing - .EventData = Nothing End With + CustomEventService.SetEventType(Item, CustomEvent.EventType.None) '清空自定义事件属性，它们会被下面的点击事件处理 + CustomEventService.SetEventData(Item, Nothing) '项目的点击事件 AddHandler Item.Click, Sub(sender, e) PageOtherHelp.OnItemClick(sender.Tag) Return Item @@ -602,7 +579,7 @@ EndHint: '读取自定义文件 If Directory.Exists(Path & "PCL\Help\") Then For Each File In EnumerateFiles(Path & "PCL\Help\") - Select Case File.Extension.ToLower + Select Case File.Extension.Lower Case ".helpignore" '加载忽略列表 Log("[Help] 发现 .helpignore 文件：" & File.FullName) @@ -621,7 +598,7 @@ EndHint: '读取自带文件 For Each File In EnumerateFiles(PathTemp & "Help") '跳过非 json 文件与以 . 开头的文件夹 - If File.Extension.ToLower <> ".json" OrElse File.Directory.FullName.Replace(PathTemp & "Help", "").Contains("\.") Then Continue For + If File.Extension.Lower <> ".json" OrElse File.Directory.FullName.Replace(PathTemp & "Help", "").Contains("\.") Then Continue For '检查忽略列表 Dim RealPath As String = File.FullName.Replace(PathTemp & "Help\", "") For Each Ignore In IgnoreList @@ -637,7 +614,7 @@ NextFile: Catch ex As Exception Log(ex, "检查帮助文件夹失败", LogLevel.Msgbox) End Try - If Loader.IsAborted Then Return + If Loader.IsInterrupted Then Return '将文件实例化 Dim Dict As New List(Of HelpEntry) @@ -653,7 +630,7 @@ NextFile: '回设 If Not Dict.Any() Then Throw New Exception("未找到可用的帮助；若不需要帮助页面，可以在 设置 → 个性化 → 功能隐藏 中将其隐藏") - If Loader.IsAborted Then Return + If Loader.IsInterrupted Then Return Loader.Output = Dict Catch ex As Exception @@ -666,34 +643,33 @@ NextFile: ''' 尝试解压内置帮助文件。 ''' Public Sub HelpTryExtract() - If Setup.Get("SystemHelpVersion") <> VersionCode OrElse Not File.Exists(PathTemp & "Help\启动器\备份设置.xaml") Then + If Settings.Get("SystemHelpVersion") <> VersionCode OrElse Not File.Exists(PathTemp & "Help\启动器\备份设置.xaml") Then DeleteDirectory(PathTemp & "Help") Directory.CreateDirectory(PathTemp & "Help") WriteFile(PathTemp & "Cache\Help.zip", GetResources("Help")) - ExtractFile(PathTemp & "Cache\Help.zip", PathTemp & "Help", Encoding.UTF8) - Setup.Set("SystemHelpVersion", VersionCode) + ExtractCompressedFile(PathTemp & "Cache\Help.zip", PathTemp & "Help") + Settings.Set("SystemHelpVersion", VersionCode) Log("[Help] 已解压内置帮助文件，目前状态：" & File.Exists(PathTemp & "Help\启动器\备份设置.xaml"), LogLevel.Debug) End If End Sub - ''' - ''' 对帮助文件约定的替换标记进行处理，如果遇到需要转义的字符会进行转义。 - ''' - Public Function HelpArgumentReplace(Xaml As String) As String - Dim Result = Xaml.Replace("{path}", EscapeXML(Path)) - Result = Result.RegexReplaceEach("\{hint\}", Function() EscapeXML(PageOtherTest.GetRandomHint())) - Result = Result.RegexReplaceEach("\{cave\}", Function() EscapeXML(PageOtherTest.GetRandomCave())) - Return Result - End Function #End Region #Region "愚人节" - Public IsAprilEnabled As Boolean = Date.Now.Month = 4 AndAlso Date.Now.Day = 1 + Private _IsAprilEnabled As Boolean? = Nothing + Public ReadOnly Property IsAprilEnabled As Boolean + Get + If _IsAprilEnabled Is Nothing Then + _IsAprilEnabled = + Date.Now.Month = 4 AndAlso Date.Now.Day = 1 AndAlso + Settings.Get("AprilDoneYear") <> Date.Now.Year '成功后同年内则不再触发 + End If + Return _IsAprilEnabled.Value + End Get + End Property Public IsAprilGiveup As Boolean = False - Private AprilSpeed As New Vector(0, 0) - Private AprilIdieCount As Integer = 0, AprilMousePosLast As New Point(0, 0) - Private AprilDistance As Integer = 0 + Private AprilDifficultiedDistance As Integer = 0 Private Sub TimerFool() Try If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing Then Return @@ -701,11 +677,13 @@ NextFile: '计算是否空闲 Dim MousePos = FrmMain.lastMouseArg.GetPosition(FrmMain) - If MousePos = AprilMousePosLast Then - AprilIdieCount += 1 + Static IdieCount As Integer = 0 + Static MousePosLast As New Point(0, 0) + If MousePos = MousePosLast Then + IdieCount += 1 Else - AprilMousePosLast = MousePos - AprilIdieCount = 0 + MousePosLast = MousePos + IdieCount = 0 End If '计算躲避移动 Dim Direction As Vector @@ -717,9 +695,11 @@ NextFile: Direction = -Dir Distance = New Vector(Math.Max(0, Math.Abs(Vec.X) - ButtonWidth), Math.Max(0, Math.Abs(Vec.Y) - ButtonHeight)).Length Dim BreathScale = Math.Sin(Timer150Count / 37.5 * Math.PI) - Dim Acc = Math.Max(0, BreathScale * 0.25 - 0.65 - Math.Log((Distance + 0.4) / 200)) * Direction '加速度 - '计算回归移动 - If AprilIdieCount >= 64 * 5 Then + Dim Difficulty As Double = 1 / (1 + (AprilDifficultiedDistance / 6000) ^ 2) + 0.25 '难度，初始为 1.25x，6000 距离为 0.75x，12000 为 0.5x，24000 为 0.256x，最低 0.25x + Dim Acc = Math.Max(0, -0.65 - Math.Log((Distance / Difficulty + 0.4) / 200)) * Direction * Difficulty '加速度 + 'FrmMain.Title = CInt(AprilTotalDistance) & " - " & Difficulty + '5s 不动时回到起始点 + If IdieCount >= 64 * 5 Then Dim SafeDist As Vector = FrmMain.lastMouseArg.GetPosition(FrmMain.PanMain) - New Vector(ButtonWidth, FrmMain.PanMain.ActualHeight - ButtonHeight * 3) Dim Back As New Vector(FrmLaunchLeft.AprilPosTrans.X, FrmLaunchLeft.AprilPosTrans.Y) If SafeDist.Length > 250 AndAlso Back.Length > 0.4 Then @@ -729,10 +709,11 @@ NextFile: End If End If '回到边界 + Static Speed As New Vector(0, 0) Dim Relative As Point = FrmLaunchLeft.BtnLaunch.TranslatePoint(New Point(0, 0), FrmMain.PanForm) If Relative.X < -ButtonWidth * 2 Then FrmLaunchLeft.AprilPosTrans.X += FrmMain.PanForm.ActualWidth + ButtonWidth * 2 '离开左边界 - AprilSpeed.X -= 80 + Speed.X -= 80 If Relative.Y < 0 Then FrmLaunchLeft.AprilPosTrans.Y += ButtonHeight * 2.5 ElseIf Relative.Y > FrmMain.PanForm.ActualHeight - ButtonHeight * 2 Then @@ -740,7 +721,7 @@ NextFile: End If ElseIf Relative.X > FrmMain.PanForm.ActualWidth Then FrmLaunchLeft.AprilPosTrans.X -= FrmMain.PanForm.ActualWidth + ButtonWidth * 2 '离开右边界 - AprilSpeed.X += 80 + Speed.X += 80 If Relative.Y < 0 Then FrmLaunchLeft.AprilPosTrans.Y += ButtonHeight * 2.5 ElseIf Relative.Y > FrmMain.PanForm.ActualHeight - ButtonHeight * 2 Then @@ -748,7 +729,7 @@ NextFile: End If ElseIf Relative.Y < -ButtonHeight * 2 Then FrmLaunchLeft.AprilPosTrans.Y += FrmMain.PanForm.ActualHeight + ButtonHeight * 2 '离开上边界 - AprilSpeed.Y -= 25 + Speed.Y -= 25 If Relative.X < 0 Then FrmLaunchLeft.AprilPosTrans.X += ButtonWidth * 2 ElseIf Relative.X > FrmMain.PanForm.ActualWidth - ButtonWidth * 2 Then @@ -756,7 +737,7 @@ NextFile: End If ElseIf Relative.Y > FrmMain.PanForm.ActualHeight Then FrmLaunchLeft.AprilPosTrans.Y -= FrmMain.PanForm.ActualHeight + ButtonHeight * 2 '离开下边界 - AprilSpeed.Y += 25 + Speed.Y += 25 If Relative.X < 0 Then FrmLaunchLeft.AprilPosTrans.X += ButtonWidth * 2 ElseIf Relative.X > FrmMain.PanForm.ActualWidth - ButtonWidth * 2 Then @@ -764,29 +745,31 @@ NextFile: End If End If '移动 - AprilSpeed = AprilSpeed * 0.8 + Acc - Dim SpeedValue = Math.Min(60, AprilSpeed.Length) + Speed = Speed * 0.8 + Acc + Dim SpeedValue = Math.Min(60, Speed.Length) If SpeedValue < 0.01 Then Return - AprilSpeed.Normalize() - AprilSpeed *= SpeedValue - AprilDistance += SpeedValue - FrmLaunchLeft.AprilPosTrans.X += AprilSpeed.X - FrmLaunchLeft.AprilPosTrans.Y += AprilSpeed.Y + Speed.Normalize() + Speed *= SpeedValue + AprilDifficultiedDistance += SpeedValue + FrmLaunchLeft.AprilPosTrans.X += Speed.X + FrmLaunchLeft.AprilPosTrans.Y += Speed.Y '大小改变 FrmLaunchLeft.AprilScaleTrans.ScaleX = MathClamp(1 - (Math.Abs(Direction.X) - Math.Abs(Direction.Y)) * (SpeedValue / 160), 0.2, 1.8) FrmLaunchLeft.AprilScaleTrans.ScaleY = MathClamp(1 - (Math.Abs(Direction.Y) - Math.Abs(Direction.X)) * (SpeedValue / 100), 0.2, 1.8) '放弃提示 - If AprilDistance > 4000 Then - AprilDistance = -4000 + Static GiveUpDistance As Double = -1500 + GiveUpDistance += SpeedValue + If GiveUpDistance > 2500 Then + GiveUpDistance = 0 Select Case RandomInteger(0, 3) Case 0 - Hint("放弃吧！只需要点一下右下角的小白旗……") + Hint("放弃吧！只需要点一下右下角的小白旗……", HintType.Red) Case 1 - Hint("看到右下角的那面小白旗了吗？") + Hint("看到右下角的那面小白旗了吗？", HintType.Red) Case 2 - Hint("这里建议点一下右下角的小白旗投降呢.jpg") + Hint("这里建议点一下右下角的小白旗投降呢.jpg", HintType.Red) Case 3 - Hint("右下角的小白旗永远等着你……") + Hint("右下角的小白旗永远等着你……", HintType.Red) End Select End If @@ -824,8 +807,7 @@ NextFile: '查看现有设置 Using ReadOnlyKey = My.Computer.Registry.CurrentUser.OpenSubKey(REG_KEY, False) If ReadOnlyKey IsNot Nothing Then - Dim CurrentValue = ReadOnlyKey.GetValue(Executeable) - If REG_VALUE = CurrentValue?.ToString() Then + If REG_VALUE = ReadOnlyKey.GetValue(Executeable)?.ToString() Then Log($"[System] 无需调整显卡设置：{Executeable}") Return End If @@ -842,6 +824,79 @@ NextFile: End Using End Sub + ''' + ''' 对替换标记进行处理。会对替换内容使用 EscapeHandler 进行转义。 + ''' + Public Function ArgumentReplace(Text As String, Optional EscapeHandler As Func(Of String, String) = Nothing, Optional ReplaceTime As Boolean = True) As String + '预处理 + If Text Is Nothing Then Return Nothing + Dim Replacer = + Function(s As String) As String + If s Is Nothing Then Return "" + If EscapeHandler Is Nothing Then Return s + If s.Contains(":\") Then s = ShortenPath(s) + Return EscapeHandler(s) + End Function + '基础 + Text = Text.Replace("{pcl_version}", Replacer(VersionBaseName)) + Text = Text.Replace("{pcl_version_code}", Replacer(VersionCode)) + Text = Text.Replace("{pcl_version_branch}", Replacer(VersionBranchName)) + Text = Text.Replace("{pcl_branch}", Replacer(VersionBranchMain)) + Text = Text.Replace("{identify}", Replacer(Identify)) + Text = Text.Replace("{path}", Replacer(Path)) + Text = Text.Replace("{path_with_name}", Replacer(PathWithName)) + Text = Text.Replace("{path_temp}", Replacer(PathTemp)) + '时间 + If ReplaceTime Then '在窗口标题中，时间会被后续动态替换，所以此时不应该替换 + Text = Text.Replace("{date}", Replacer(Date.Now.ToString("yyyy'/'M'/'d"))) + Text = Text.Replace("{time}", Replacer(Date.Now.ToString("HH':'mm':'ss"))) + End If + 'Minecraft + Text = Text.Replace("{java}", Replacer(McLaunchJavaSelected?.PathFolder)) + Text = Text.Replace("{minecraft}", Replacer(McFolderSelected)) + If McInstanceSelected?.IsLoaded Then + Text = Text.Replace("{version_path}", Replacer(McInstanceSelected.PathVersion)) : Text = Text.Replace("{verpath}", Replacer(McInstanceSelected.PathVersion)) + Text = Text.Replace("{version_indie}", Replacer(McInstanceSelected.PathIndie)) : Text = Text.Replace("{verindie}", Replacer(McInstanceSelected.PathIndie)) + Text = Text.Replace("{name}", Replacer(McInstanceSelected.Name)) + If {"unknown", "old", "pending"}.Contains(McInstanceSelected.Version.VanillaName.Lower) Then + Text = Text.Replace("{version}", Replacer(McInstanceSelected.Name)) + Else + Text = Text.Replace("{version}", Replacer(McInstanceSelected.Version.VanillaName)) + End If + Else + Text = Text.Replace("{version_path}", Replacer(Nothing)) : Text = Text.Replace("{verpath}", Replacer(Nothing)) + Text = Text.Replace("{version_indie}", Replacer(Nothing)) : Text = Text.Replace("{verindie}", Replacer(Nothing)) + Text = Text.Replace("{name}", Replacer(Nothing)) + Text = Text.Replace("{version}", Replacer(Nothing)) + End If + '登录信息 + If McLoginLoader.State = LoadState.Finished Then + Text = Text.Replace("{user}", Replacer(McLoginLoader.Output.Name)) + Text = Text.Replace("{uuid}", Replacer(McLoginLoader.Output.Uuid?.Lower)) + Select Case McLoginLoader.Input.Type + Case McLoginType.Legacy + Text = Text.Replace("{login}", Replacer("离线")) + Case McLoginType.Ms + Text = Text.Replace("{login}", Replacer("正版")) + Case McLoginType.Nide + Text = Text.Replace("{login}", Replacer("统一通行证")) + Case McLoginType.Auth + Text = Text.Replace("{login}", Replacer("Authlib-Injector")) + End Select + Else + Text = Text.Replace("{user}", Replacer(Nothing)) + Text = Text.Replace("{uuid}", Replacer(Nothing)) + Text = Text.Replace("{login}", Replacer(Nothing)) + End If + '高级 + Text = Text.RegexReplaceEach("\{hint\}", Function() Replacer(PageOtherTest.GetRandomHint())) + Text = Text.RegexReplaceEach("\{cave\}", Function() Replacer(PageOtherTest.GetRandomCave())) + Text = Text.RegexReplaceEach("\{setup:([a-zA-Z0-9]+)\}", Function(m) Replacer(Settings.GetSafe(m.Groups(1).Value, McInstanceSelected))) + Text = Text.RegexReplaceEach("\{varible:([^:\}]+)(?::([^\}]+))?\}", Function(m) Replacer(ReadReg("CustomEvent" & m.Groups(1).Value, m.Groups(2).Value))) + Text = Text.RegexReplaceEach("\{variable:([^:\}]+)(?::([^\}]+))?\}", Function(m) Replacer(ReadReg("CustomEvent" & m.Groups(1).Value, m.Groups(2).Value))) + Return Text + End Function + #End Region #Region "任务缓存" @@ -931,7 +986,7 @@ NextFile: Timer150Count = 0 Try #Region "每 7.5s 执行一次的代码" - If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDistance <> 0 Then FrmMain.BtnExtraApril.Ribble() + If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDifficultiedDistance <> 0 Then FrmMain.BtnExtraApril.Ribble() '以未知原因窗口被丢到一边去的修复（Top、Left = -25600），还有 #745 RunInUi( Sub() diff --git a/Plain Craft Launcher 2/Modules/ModMusic.vb b/Plain Craft Launcher 2/Modules/ModMusic.vb index 060091a..ffbe64a 100644 --- a/Plain Craft Launcher 2/Modules/ModMusic.vb +++ b/Plain Craft Launcher 2/Modules/ModMusic.vb @@ -24,13 +24,13 @@ Directory.CreateDirectory(Path & "PCL\Musics\") For Each File In EnumerateFiles(Path & "PCL\Musics\") '文件夹可能会被加入 .ini 文件夹配置文件、一些乱七八糟的 .jpg 文件啥的 - Dim Ext As String = File.Extension.ToLower + Dim Ext As String = File.Extension.Lower If {".ini", ".jpg", ".txt", ".cfg", ".lrc", ".db", ".png"}.Contains(Ext) Then Continue For MusicAllList.Add(File.FullName) Next End If '打乱顺序播放 - MusicWaitingList = If(Setup.Get("UiMusicRandom"), Shuffle(New List(Of String)(MusicAllList)), New List(Of String)(MusicAllList)) + MusicWaitingList = If(Settings.Get("UiMusicRandom"), New List(Of String)(MusicAllList).Shuffle().ToList, New List(Of String)(MusicAllList)) If PreventFirst IsNot Nothing AndAlso MusicWaitingList.FirstOrDefault = PreventFirst Then '若需要避免成为第一项的为第一项，则将它放在最后 MusicWaitingList.RemoveAt(0) @@ -79,7 +79,7 @@ If MusicState = MusicStates.Pause Then FrmMain.BtnExtraMusic.Logo = Logo.IconPlay FrmMain.BtnExtraMusic.LogoScale = 0.8 - ToolTipText = "已暂停：" & GetFileNameWithoutExtentionFromPath(MusicCurrent) + ToolTipText = "已暂停：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent) If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键恢复播放，右键播放下一曲。" Else @@ -88,7 +88,7 @@ Else FrmMain.BtnExtraMusic.Logo = Logo.IconMusic FrmMain.BtnExtraMusic.LogoScale = 1 - ToolTipText = "正在播放：" & GetFileNameWithoutExtentionFromPath(MusicCurrent) + ToolTipText = "正在播放：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent) If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键暂停，右键播放下一曲。" Else @@ -111,7 +111,7 @@ ''' Public Sub MusicControlPause() If MusicNAudio Is Nothing Then - Hint("音乐播放尚未开始！", HintType.Critical) + Hint("音乐播放尚未开始！", HintType.Red) Else Select Case MusicState Case MusicStates.Pause @@ -129,16 +129,16 @@ ''' 播放下一曲，并显示提示文本。 ''' Public Sub MusicControlNext() - If MusicAllList.Count = 1 Then + If MusicAllList.IsSingle Then MusicStartPlay(MusicCurrent) - Hint("重新播放：" & GetFileNameFromPath(MusicCurrent), HintType.Finish) + Hint("重新播放：" & GetFileNameFromPath(MusicCurrent), HintType.Green) Else Dim Address As String = DequeueNextMusicAddress() If Address Is Nothing Then - Hint("没有可以播放的音乐！", HintType.Critical) + Hint("没有可以播放的音乐！", HintType.Red) Else MusicStartPlay(Address) - Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Finish) + Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Green) End If End If MusicRefreshUI() @@ -182,19 +182,19 @@ MusicListInit(True) If Not MusicAllList.Any() Then If MusicNAudio Is Nothing Then - If ShowHint Then Hint("未检测到可用的背景音乐！", HintType.Critical) + If ShowHint Then Hint("未检测到可用的背景音乐！", HintType.Red) Else MusicNAudio = Nothing - If ShowHint Then Hint("背景音乐已清除！", HintType.Finish) + If ShowHint Then Hint("背景音乐已清除！", HintType.Green) End If Else Dim Address As String = DequeueNextMusicAddress() If Address Is Nothing Then - If ShowHint Then Hint("没有可以播放的音乐！", HintType.Critical) + If ShowHint Then Hint("没有可以播放的音乐！", HintType.Red) Else Try MusicStartPlay(Address, IsFirstLoad) - If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Finish, False) + If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Green, False) Catch End Try End If @@ -247,7 +247,7 @@ Log("[Music] 已恢复播放") Try MusicNAudio?.Play() - Catch 'https://github.com/Hex-Dragon/PCL2/pull/5415#issuecomment-2751135223 + Catch 'https://github.com/Meloong-Git/PCL/pull/5415#issuecomment-2751135223 MusicNAudio?.Stop() MusicNAudio?.Play() End Try @@ -261,6 +261,7 @@ ''' ''' 当前正在播放的 NAudio.Wave.WaveOutEvent。 + ''' 如果为它赋了类别，则会没有必要地加载 NAudio.dll。 ''' Public MusicNAudio = Nothing ''' @@ -279,18 +280,23 @@ CurrentWave = New NAudio.Wave.WaveOutEvent() MusicNAudio = CurrentWave CurrentWave.DeviceNumber = -1 - Reader = New NAudio.Wave.AudioFileReader(MusicCurrent) + Try + Reader = New NAudio.Wave.AudioFileReader(MusicCurrent) + Catch ex As Exception + Log(ex, "使用 AudioFileReader 加载音频文件失败，换用 MediaFoundationReader 重试", LogLevel.Developer) + Reader = New NAudio.Wave.MediaFoundationReader(MusicCurrent) + End Try CurrentWave.Init(Reader) CurrentWave.Play() '第一次打开的暂停 - If IsFirstLoad AndAlso Not Setup.Get("UiMusicAuto") Then CurrentWave.Pause() + If IsFirstLoad AndAlso Not Settings.Get("UiMusicAuto") Then CurrentWave.Pause() MusicRefreshUI() '停止条件：播放完毕或变化 Dim PreviousVolume = 0 While CurrentWave.Equals(MusicNAudio) AndAlso Not CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped - If Setup.Get("UiMusicVolume") <> PreviousVolume Then + If Settings.Get("UiMusicVolume") <> PreviousVolume Then '更新音量 - PreviousVolume = Setup.Get("UiMusicVolume") + PreviousVolume = Settings.Get("UiMusicVolume") CurrentWave.Volume = PreviousVolume / 1000 End If '更新进度条 @@ -303,18 +309,16 @@ Catch ex As Exception Log(ex, "播放音乐出现内部错误（" & MusicCurrent & "）", LogLevel.Developer) If TypeOf ex Is NAudio.MmException AndAlso ex.Message.Contains("AlreadyAllocated") Then - Hint("你的音频设备正被其他程序占用。请在关闭占用的程序后重启 PCL，才能恢复音乐播放功能！", HintType.Critical) + Hint("你的音频设备正被其他程序占用。请在关闭占用的程序后重启 PCL，才能恢复音乐播放功能！", HintType.Red) Thread.Sleep(1000000000) End If If TypeOf ex Is NAudio.MmException AndAlso (ex.Message.Contains("NoDriver") OrElse ex.Message.Contains("BadDeviceId")) Then - Hint("由于音频设备变更，音乐播放功能在重启 PCL 后才能恢复！", HintType.Critical) + Hint("由于音频设备变更，音乐播放功能在重启 PCL 后才能恢复！", HintType.Red) Thread.Sleep(1000000000) End If - If ex.Message.Contains("Got a frame at sample rate") OrElse ex.Message.Contains("does not support changes to") Then - Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 不支持播放音频属性在中途发生变化的音乐", HintType.Critical) - ElseIf Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) OrElse + If Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) OrElse ex.Message.Contains("0xC00D36C4") Then '#5096：不支持给定的 URL 的字节流类型。 (异常来自 HRESULT:0xC00D36C4) - Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Critical) + Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Red) Else Log(ex, "播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）", LogLevel.Hint) End If diff --git a/Plain Craft Launcher 2/Modules/ModSecret.vb b/Plain Craft Launcher 2/Modules/ModSecret.vb index 37abcf8..23b1f0a 100644 --- a/Plain Craft Launcher 2/Modules/ModSecret.vb +++ b/Plain Craft Launcher 2/Modules/ModSecret.vb @@ -1,18 +1,21 @@ '由于包含加解密等安全信息，本文件中的部分代码已被删除 -Imports System.Net.Http Imports System.Security.Cryptography Friend Module ModSecret #Region "杂项" + '标注 PCL 的不同分支，仅用于替换标记 + Public Const VersionBranchMain As String = "OpenSource" '在开源版的注册表与常规版的注册表隔离，以防数据冲突 Public Const RegFolder As String = "PCLDebug" '用于微软登录的 ClientId - Public Const OAuthClientId As String = "" + Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "") 'CurseForge API Key - Public Const CurseForgeAPIKey As String = "" + Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "") + '用于匿名数据收集的腾讯云日志服务上报 URL，形如 https://{region}.cls.tencentcs.com/track?topic_id={topic_id} + Public Const ClsBaseUrl As String = "" Friend Sub SecretOnApplicationStart() '提升 UI 线程优先级 @@ -55,43 +58,35 @@ Friend Module ModSecret ''' ''' 获取设备标识码。 ''' - Friend Function SecretGetUniqueAddress() As String + Friend Function SecretGetIdentify() As String Return "0000-0000-0000-0000" End Function - Friend Sub SecretLaunchJvmArgs(ByRef DataList As List(Of String)) - Dim DataJvmCustom As String = Setup.Get("VersionAdvanceJvm", Version:=McVersionCurrent) - DataList.Insert(0, If(DataJvmCustom = "", Setup.Get("LaunchAdvanceJvm"), DataJvmCustom)) '可变 JVM 参数 - McLaunchLog("当前剩余内存：" & Math.Round(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024 / 1024 * 10) / 10 & "G") - DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent) * 1024 * 0.15) & "m") - DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent) * 1024) & "m") - If Not DataList.Any(Function(d) d.Contains("-Dlog4j2.formatMsgNoLookups=true")) Then DataList.Add("-Dlog4j2.formatMsgNoLookups=true") - End Sub - #End Region #Region "网络鉴权" - Friend Function SecretCdnSign(UrlWithMark As String) + Friend Function SecretCdnSign(UrlWithMark As String) As String If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20") End Function ''' ''' 设置 Headers 的 UA、Referer。 ''' - Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional UseBrowserUserAgent As Boolean = False) - If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then - Req.Headers.Add("User-Agent", "LogStatistic") '#4951 - ElseIf UseBrowserUserAgent Then - Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36") - Else - Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}") + Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False) + If Not Req.Headers.UserAgent.Any Then + If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then + Req.Headers.Add("User-Agent", "LogStatistic") '#4951 + ElseIf SimulateBrowserHeaders Then + Req.Headers.Add("User-Agent", $"PCL2/{VersionBaseName}.{VersionBranchCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36") + Else + Req.Headers.Add("User-Agent", $"PCL2/{VersionBaseName}.{VersionBranchCode}") + End If End If - Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/") + If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/") If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey) End Sub - #End Region #Region "字符串加解密" @@ -213,13 +208,19 @@ Friend Module ModSecret If Not FrmMain.IsLoaded Then Return '顶部条背景 Dim Brush = New LinearGradientBrush With {.EndPoint = New Point(1, 0), .StartPoint = New Point(0, 0)} - Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - 21, ColorSat, 53 + ColorLightAdjust)}) - Brush.GradientStops.Add(New GradientStop With {.Offset = 0.33, .Color = New MyColor().FromHSL2(ColorHue - 7, ColorSat, 47 + ColorLightAdjust)}) - Brush.GradientStops.Add(New GradientStop With {.Offset = 0.67, .Color = New MyColor().FromHSL2(ColorHue + 7, ColorSat, 47 + ColorLightAdjust)}) - Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + 21, ColorSat, 53 + ColorLightAdjust)}) + If TypeOf ColorHueTopbarDelta Is Integer Then + Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)}) + Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 54 + ColorLightAdjust)}) + Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)}) + Else + Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + ColorLightAdjust)}) + Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + ColorLightAdjust)}) + Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)}) + End If FrmMain.PanTitle.Background = Brush + FrmMain.PanTitle.Background.Freeze() '主页面背景 - If Setup.Get("UiBackgroundColorful") Then + If Settings.Get("UiBackgroundColorful") Then Brush = New LinearGradientBrush With {.EndPoint = New Point(0.1, 1), .StartPoint = New Point(0.9, 0)} Brush.GradientStops.Add(New GradientStop With {.Offset = -0.1, .Color = New MyColor().FromHSL2(ColorHue - 15, ColorSat * 0.8, 91)}) Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.8, 91)}) @@ -271,9 +272,16 @@ Friend Module ModSecret #End Region -#Region "联网通知" +#Region "联网配置" - Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 服务", Sub() Log("[Server] 该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) + ''' + ''' 联网获取的配置信息。 + ''' 若获取失败或仍在获取中，可能为 Nothing。 + ''' + Public ServerConfig As JObject + + Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 配置更新", Sub() Log("[Server] 该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) With + {.ReloadTimeout = 1000 * 60 * 60} '超时 1 小时 #End Region diff --git a/Plain Craft Launcher 2/Modules/Reference/CookieWebClient.vb b/Plain Craft Launcher 2/Modules/Reference/CookieWebClient.vb deleted file mode 100644 index 1f5ea45..0000000 --- a/Plain Craft Launcher 2/Modules/Reference/CookieWebClient.vb +++ /dev/null @@ -1,59 +0,0 @@ -Imports System.Net - -Public Class CookieWebClient - Inherits WebClient - - Public Sub New(container As CookieContainer, Headers As Dictionary(Of String, String)) - Me.New(container) - For Each keyVal In Headers - Me.Headers(keyVal.Key) = keyVal.Value - Next - End Sub - - Public Sub New() - Me.New(New CookieContainer()) - End Sub - - Public Sub New(container As CookieContainer) - Me.container = container - End Sub - - Private Shadows ReadOnly container As New CookieContainer() - - ''' - ''' 以毫秒为单位的超时。 - ''' - Public Timeout As Integer = 600000 - - Protected Overrides Function GetWebRequest(address As Uri) As WebRequest - Dim r As WebRequest = MyBase.GetWebRequest(address) - Dim request = TryCast(r, HttpWebRequest) - - If request IsNot Nothing Then - request.CookieContainer = container - request.Timeout = Timeout - End If - - Return r - End Function - - Protected Overrides Function GetWebResponse(request As WebRequest, result As IAsyncResult) As WebResponse - Dim response As WebResponse = MyBase.GetWebResponse(request, result) - ReadCookies(response) - Return response - End Function - - Protected Overrides Function GetWebResponse(request As WebRequest) As WebResponse - Dim response As WebResponse = MyBase.GetWebResponse(request) - ReadCookies(response) - Return response - End Function - - Private Sub ReadCookies(r As WebResponse) - Dim response = TryCast(r, HttpWebResponse) - If response IsNot Nothing Then - Dim cookies As CookieCollection = response.Cookies - container.Add(cookies) - End If - End Sub -End Class diff --git a/Plain Craft Launcher 2/Modules/ThirdParty/DragHelper.vb b/Plain Craft Launcher 2/Modules/ThirdParty/DragHelper.vb new file mode 100644 index 0000000..e2d79e7 --- /dev/null +++ b/Plain Craft Launcher 2/Modules/ThirdParty/DragHelper.vb @@ -0,0 +1,151 @@ +'来源：https://blog.csdn.net/simpleman2000/article/details/140952294 + +Imports System.ComponentModel +Imports System.Runtime.InteropServices +Imports System.Windows.Interop + +Public Class DragHelper + + Public Event DragDrop As EventHandler + + Public Property DropFilePaths As String() + Get + Return _DropFilePathsBackingField + End Get + Private Set(value As String()) + _DropFilePathsBackingField = value + End Set + End Property + Private _DropFilePathsBackingField As String() + + Public Property DropPoint As POINT + Get + Return _DropPointBackingField + End Get + Private Set(value As POINT) + _DropPointBackingField = value + End Set + End Property + Private _DropPointBackingField As POINT + + Public Property HwndIntPtrSource As HwndSource + + Public Sub AddHook() + RemoveDragHook() + HwndIntPtrSource.AddHook(AddressOf WndProc) + Dim handle As IntPtr = HwndIntPtrSource.Handle + If IsUserAnAdmin() Then RevokeDragDrop(handle) + DragAcceptFiles(handle, True) + ChangeMessageFilter(handle) + End Sub + + Public Sub RemoveDragHook() + HwndIntPtrSource.RemoveHook(AddressOf WndProc) + DragAcceptFiles(HwndIntPtrSource.Handle, False) + End Sub + + Private Function WndProc(hwnd As IntPtr, msg As Integer, wParam As IntPtr, lParam As IntPtr, ByRef handled As Boolean) As IntPtr + Dim filePaths As String() = Nothing + Dim point As New POINT() + + If TryGetDropInfo(msg, wParam, filePaths, point) Then + DropPoint = point + DropFilePaths = filePaths + RaiseEvent DragDrop(Me, EventArgs.Empty) + handled = True + End If + Return IntPtr.Zero + End Function + + + Private Shared Function ChangeWindowMessageFilterEx(hWnd As IntPtr, msg As UInteger, action As UInteger, ByRef pChangeFilterStruct As CHANGEFILTERSTRUCT) As Boolean + End Function + + + Private Shared Function ChangeWindowMessageFilter(msg As UInteger, flags As UInteger) As Boolean + End Function + + + Private Shared Sub DragAcceptFiles(hWnd As IntPtr, fAccept As Boolean) + End Sub + + + Private Shared Function DragQueryFile(hWnd As IntPtr, iFile As UInteger, lpszFile As StringBuilder, cch As Integer) As UInteger + End Function + + + Private Shared Function DragQueryPoint(hDrop As IntPtr, ByRef lppt As POINT) As Boolean + End Function + + + Private Shared Sub DragFinish(hDrop As IntPtr) + End Sub + + + Private Shared Function RevokeDragDrop(hWnd As IntPtr) As Integer + End Function + + + Private Shared Function IsUserAnAdmin() As Boolean + End Function + + + Public Structure POINT + Public X As Integer + Public Y As Integer + End Structure + + + Private Structure CHANGEFILTERSTRUCT + Public cbSize As UInteger + Public ExtStatus As UInteger + End Structure + + Private Const WM_COPYGLOBALDATA As UInteger = &H49 + Private Const WM_COPYDATA As UInteger = &H4A + Private Const WM_DROPFILES As UInteger = &H233 + Private Const MSGFLT_ALLOW As UInteger = 1 + Private Const MSGFLT_ADD As UInteger = 1 + Private Const MAX_PATH As Integer = 260 + + Private Shared Sub ChangeMessageFilter(handle As IntPtr) + Dim ver As Version = Environment.OSVersion.Version + Dim isVistaOrHigher As Boolean = ver >= New Version(6, 0) + Dim isNt61OrHiger As Boolean = ver >= New Version(6, 1) + + If isVistaOrHigher Then + Dim status As New CHANGEFILTERSTRUCT With {.cbSize = 8} + For Each msg As UInteger In New UInteger() {WM_DROPFILES, WM_COPYGLOBALDATA, WM_COPYDATA} + Dim [error] As Boolean = False + If isNt61OrHiger Then + [error] = Not ChangeWindowMessageFilterEx(handle, msg, MSGFLT_ALLOW, status) + Else + [error] = Not ChangeWindowMessageFilter(msg, MSGFLT_ADD) + End If + + If [error] Then Throw New Win32Exception(Marshal.GetLastWin32Error()) + Next + End If + End Sub + + Private Shared Function TryGetDropInfo(msg As Integer, wParam As IntPtr, ByRef dropFilePaths As String(), ByRef dropPoint As POINT) As Boolean + dropFilePaths = Nothing + dropPoint = New POINT() + + If msg <> WM_DROPFILES Then Return False + + Dim fileCount As UInteger = DragQueryFile(wParam, UInteger.MaxValue, Nothing, 0) + ReDim dropFilePaths(CInt(fileCount) - 1) + + For i As UInteger = 0 To CInt(fileCount) - 1 + Dim sb As New StringBuilder(MAX_PATH) + Dim result As UInteger = DragQueryFile(wParam, i, sb, sb.Capacity) + If result > 0 Then dropFilePaths(i) = sb.ToString() + Next + + DragQueryPoint(wParam, dropPoint) + DragFinish(wParam) + Return True + End Function + +End Class diff --git a/Plain Craft Launcher 2/My Project/AssemblyInfo.vb b/Plain Craft Launcher 2/My Project/AssemblyInfo.vb index 8d8a259..629ff78 100644 --- a/Plain Craft Launcher 2/My Project/AssemblyInfo.vb +++ b/Plain Craft Launcher 2/My Project/AssemblyInfo.vb @@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices ' 可以指定所有值，也可以使用以下所示的 "*" 预置版本号和修订号 ' 方法是按如下所示使用“*” - - + + diff --git a/Plain Craft Launcher 2/My Project/Resources.Designer.vb b/Plain Craft Launcher 2/My Project/Resources.Designer.vb index 81e998d..3005963 100644 --- a/Plain Craft Launcher 2/My Project/Resources.Designer.vb +++ b/Plain Craft Launcher 2/My Project/Resources.Designer.vb @@ -63,9 +63,9 @@ Namespace My.Resources ''' ''' 查找 System.Byte[] 类型的本地化资源。 ''' - Friend ReadOnly Property Custom() As Byte() + Friend ReadOnly Property CacheCow_Client() As Byte() Get - Dim obj As Object = ResourceManager.GetObject("Custom", resourceCulture) + Dim obj As Object = ResourceManager.GetObject("CacheCow.Client", resourceCulture) Return CType(obj,Byte()) End Get End Property @@ -73,9 +73,29 @@ Namespace My.Resources ''' ''' 查找 System.Byte[] 类型的本地化资源。 ''' - Friend ReadOnly Property Dialogs() As Byte() + Friend ReadOnly Property CacheCow_Client_FileStore() As Byte() Get - Dim obj As Object = ResourceManager.GetObject("Dialogs", resourceCulture) + Dim obj As Object = ResourceManager.GetObject("CacheCow.Client.FileStore", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property CacheCow_Common() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("CacheCow.Common", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property Custom() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("Custom", resourceCulture) Return CType(obj,Byte()) End Get End Property @@ -105,7 +125,7 @@ Namespace My.Resources ''' Friend ReadOnly Property Imazen_WebP() As Byte() Get - Dim obj As Object = ResourceManager.GetObject("Imazen_WebP", resourceCulture) + Dim obj As Object = ResourceManager.GetObject("Imazen.WebP", resourceCulture) Return CType(obj,Byte()) End Get End Property @@ -123,9 +143,9 @@ Namespace My.Resources ''' ''' 查找 System.Byte[] 类型的本地化资源。 ''' - Friend ReadOnly Property Json() As Byte() + Friend ReadOnly Property libwebp64() As Byte() Get - Dim obj As Object = ResourceManager.GetObject("Json", resourceCulture) + Dim obj As Object = ResourceManager.GetObject("libwebp64", resourceCulture) Return CType(obj,Byte()) End Get End Property @@ -133,9 +153,9 @@ Namespace My.Resources ''' ''' 查找 System.Byte[] 类型的本地化资源。 ''' - Friend ReadOnly Property libwebp64() As Byte() + Friend ReadOnly Property LUA() As Byte() Get - Dim obj As Object = ResourceManager.GetObject("libwebp64", resourceCulture) + Dim obj As Object = ResourceManager.GetObject("LUA", resourceCulture) Return CType(obj,Byte()) End Get End Property @@ -160,6 +180,46 @@ Namespace My.Resources End Get End Property + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property Newtonsoft_Json() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("Newtonsoft.Json", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property Ookii_Dialogs_Wpf() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("Ookii.Dialogs.Wpf", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property System_Net_Http_Formatting() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("System.Net.Http.Formatting", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + + ''' + ''' 查找 System.Byte[] 类型的本地化资源。 + ''' + Friend ReadOnly Property System_ValueTuple() As Byte() + Get + Dim obj As Object = ResourceManager.GetObject("System.ValueTuple", resourceCulture) + Return CType(obj,Byte()) + End Get + End Property + ''' ''' 查找 System.Byte[] 类型的本地化资源。 ''' diff --git a/Plain Craft Launcher 2/My Project/Resources.resx b/Plain Craft Launcher 2/My Project/Resources.resx index 8f1da65..03d0719 100644 --- a/Plain Craft Launcher 2/My Project/Resources.resx +++ b/Plain Craft Launcher 2/My Project/Resources.resx @@ -118,36 +118,54 @@ System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + ..\Resources\CacheCow.Client.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + ..\Resources\CacheCow.Client.FileStore.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + ..\Resources\CacheCow.Common.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + ..\resources\custom.xaml;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 - - ..\resources\ookii.dialogs.wpf.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 - ..\Resources\forge-installer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 ..\Resources\Help.zip;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 - + ..\Resources\Imazen.WebP.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 ..\Resources\java-wrapper.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 - - ..\Resources\Newtonsoft.Json.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 - ..\Resources\libwebp64.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + ..\Resources\lwjgl-unsafe-agent.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + - ..\Resources\ModData.txt;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + ..\Resources\moddata.zip;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 ..\Resources\NAudio.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + ..\Resources\Newtonsoft.Json.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + ..\resources\ookii.dialogs.wpf.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + ..\Resources\System.Net.Http.Formatting.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + + + ..\Resources\System.ValueTuple.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 + ..\Resources\transformer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089 diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/MyCompItem.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/Comp/MyCompItem.xaml.vb index 12c51af..6843a0b 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/MyCompItem.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/MyCompItem.xaml.vb @@ -3,16 +3,6 @@ #Region "基础属性" Public Uuid As Integer = GetUuid() - 'Logo - Public Property Logo As String - Get - Return PathLogo.Source - End Get - Set(value As String) - PathLogo.Source = value - End Set - End Property - '标题 Public Property Title As String Get @@ -64,17 +54,17 @@ 'Tag Public WriteOnly Property Tags As List(Of String) - Set(value As List(Of String)) + Set(Tags As List(Of String)) PanTags.Children.Clear() - PanTags.Visibility = If(value.Any(), Visibility.Visible, Visibility.Collapsed) - For Each TagText In value - Dim NewTag = GetObjectFromXML( - " - - ") - PanTags.Children.Add(NewTag) + PanTags.Visibility = If(Tags.Any(), Visibility.Visible, Visibility.Collapsed) + For Each TagText In Tags + Dim BorderTag As New Border With { + .Background = New MyColor("#11000000"), .Padding = New Thickness(3, 1, 3, 1), .CornerRadius = New CornerRadius(3), + .Margin = New Thickness(0, 0, 3, 0), .SnapsToDevicePixels = True, .UseLayoutRounding = False} + Dim LabTag As New TextBlock With { + .Text = TagText, .Foreground = New MyColor("#868686"), .FontSize = 11} + BorderTag.Child = LabTag + PanTags.Children.Add(BorderTag) Next End Set End Property @@ -97,43 +87,43 @@ Dim Titles As New List(Of String) If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then For Each Card As MyCard In FrmDownloadCompDetail.PanResults.Children - If Card.Title <> "" AndAlso Not Card.IsSwaped Then Titles.Add(Card.Title) + If Card.Title <> "" AndAlso Not Card.IsSwapped Then Titles.Add(Card.Title) Next Log("[Comp] 记录当前已展开的卡片：" & String.Join("、", Titles)) FrmMain.PageCurrent.Additional(1) = Titles End If '打开详情页 Dim TargetType As CompType - Dim TargetVersion As String = Nothing + Dim TargetInstance As String = Nothing Dim TargetLoader As CompModLoaderType = CompModLoaderType.Any If FrmMain.PageCurrent.Page = FormMain.PageType.Download Then '从下载页进入 Select Case FrmMain.PageCurrentSub Case FormMain.PageSubType.DownloadMod TargetType = CompType.Mod - TargetVersion = FrmDownloadMod.Content.Loader.Input.GameVersion + TargetInstance = FrmDownloadMod.Content.Loader.Input.GameVersion TargetLoader = FrmDownloadMod.Content.Loader.Input.ModLoader Case FormMain.PageSubType.DownloadPack TargetType = CompType.ModPack - TargetVersion = FrmDownloadPack.Content.Loader.Input.GameVersion + TargetInstance = FrmDownloadPack.Content.Loader.Input.GameVersion Case FormMain.PageSubType.DownloadDataPack TargetType = CompType.DataPack - TargetVersion = FrmDownloadDataPack.Content.Loader.Input.GameVersion + TargetInstance = FrmDownloadDataPack.Content.Loader.Input.GameVersion Case FormMain.PageSubType.DownloadResourcePack TargetType = CompType.ResourcePack - TargetVersion = FrmDownloadResourcePack.Content.Loader.Input.GameVersion + TargetInstance = FrmDownloadResourcePack.Content.Loader.Input.GameVersion Case FormMain.PageSubType.DownloadShader TargetType = CompType.Shader - TargetVersion = FrmDownloadShader.Content.Loader.Input.GameVersion + TargetInstance = FrmDownloadShader.Content.Loader.Input.GameVersion End Select Else '从详情页进入（查看前置） TargetType = CompType.Any '允许任意类别 - TargetVersion = FrmMain.PageCurrent.Additional(2) + TargetInstance = FrmMain.PageCurrent.Additional(2) TargetLoader = FrmMain.PageCurrent.Additional(3) End If FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.CompDetail, - .Additional = {sender.Tag, New List(Of String), TargetVersion, TargetLoader, TargetType}}) + .Additional = {sender.Tag, New List(Of String), TargetInstance, TargetLoader, TargetType}}) End Sub '鼠标点击判定 @@ -208,9 +198,9 @@ Dim Ani As New List(Of AniData) If IsMouseOver Then Ani.AddRange({ - AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time), - AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent) - }) + AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time), + AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent) + }) If IsMouseDown Then Ani.Add(AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent)) Else @@ -218,11 +208,11 @@ End If Else Ani.AddRange({ - AaOpacity(RectBack, -RectBack.Opacity, Time), - AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrush7"), Time), - AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent), - AaScaleTransform(RectBack, -0.196, 1,,, True) - }) + AaOpacity(RectBack, -RectBack.Opacity, Time), + AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrush7"), Time), + AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent), + AaScaleTransform(RectBack, -0.196, 1,,, True) + }) End If AniStart(Ani, "CompItem Color " & Uuid) Else diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml index e66570e..d669f8d 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml @@ -32,22 +32,21 @@ - + - + + + + - - - - - + @@ -55,7 +54,7 @@ - + @@ -71,7 +70,7 @@ - + @@ -89,7 +88,7 @@ - + \ No newline at end of file diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml.vb index 18be6d0..9df5bb3 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml.vb @@ -67,7 +67,7 @@ Public Class PageComp ''' ''' 在切换到页面时，应自动将筛选项设置为与该目标 MC 版本和加载器相同。 ''' - Public Shared TargetVersion As McVersion = Nothing + Public Shared TargetInstance As McInstance = Nothing ''' ''' 在切换到该页面时自动设置的搜索框内的内容。 ''' @@ -76,13 +76,13 @@ Public Class PageComp '在点击 MyCompItem 时会获取 Loader 的输入，以使资源详情页面可以应用相同的筛选项 Public Loader As New LoaderTask(Of CompProjectRequest, Integer)("社区资源获取：XXX", AddressOf CompProjectsGet, AddressOf LoaderInput) With {.ReloadTimeout = 60 * 1000} - Private IsLoaderInited As Boolean = False Private Sub PageCompControls_Inited(sender As Object, e As EventArgs) Handles Me.Loaded + Static IsFirstLoaded As Boolean = False '不知道从 Initialized 改成 Loaded 会不会有问题，但用 Initialized 会导致初始的筛选器修改被覆盖回默认值 - If TargetVersion IsNot Nothing Then + If TargetInstance IsNot Nothing Then '设置目标 ResetFilter() '重置筛选器 - TextSearchVersion.Text = TargetVersion.Version.McName + TextSearchVersion.Text = TargetInstance.Version.VanillaName Dim GetTargetItemByName = Function(Name As String) As MyComboBoxItem For Each Item As MyComboBoxItem In ComboSearchLoader.Items @@ -90,39 +90,44 @@ Public Class PageComp Next Return ComboSearchLoader.Items(0) End Function - If TargetVersion.Version.HasForge Then + If TargetInstance.Version.HasForge Then ComboSearchLoader.SelectedItem = GetTargetItemByName("Forge") - ElseIf TargetVersion.Version.HasFabric Then + ElseIf TargetInstance.Version.HasFabric Then ComboSearchLoader.SelectedItem = GetTargetItemByName("Fabric") - ElseIf TargetVersion.Version.HasNeoForge Then + ElseIf TargetInstance.Version.HasNeoForge Then ComboSearchLoader.SelectedItem = GetTargetItemByName("NeoForge") End If - TargetVersion = Nothing + TargetInstance = Nothing If TargetName IsNot Nothing Then - '设置搜索框内容 TextSearchName.Text = TargetName TargetName = Nothing End If '如果已经完成请求，则重新开始 - If IsLoaderInited Then StartNewSearch() + If IsFirstLoaded Then StartNewSearch() ScrollToHome() End If '加载器初始化 - If IsLoaderInited Then Return - IsLoaderInited = True + If IsFirstLoaded Then Return + IsFirstLoaded = True CType(Parent, MyPageRight).PageLoaderInit(Load, PanLoad, PanContent, PanAlways, Loader, AddressOf Load_OnFinish, AddressOf LoaderInput) - If McVersionHighest = -1 Then McVersionHighest = Math.Max(McVersionHighest, Integer.Parse(CType(TextSearchVersion.Items(1), MyComboBoxItem).Content.ToString.Split(".")(1))) + '将最高 Drop 加入筛选 + If AllDrops IsNot Nothing AndAlso AllDrops.First > 250 Then + Dim HighestVersion As String = McVersion.DropToVersion(AllDrops.First) + If CType(TextSearchVersion.Items(1), MyComboBoxItem).Content.ToString <> HighestVersion Then '0 是全部 + TextSearchVersion.Items.Insert(1, New MyComboBoxItem With {.Content = HighestVersion}) + End If + End If End Sub Private Function LoaderInput() As CompProjectRequest - Dim Request As New CompProjectRequest(PageType, Storage, (Page + 1) * PageSize) + Dim Request As New CompProjectRequest(PageType, Storage, (Page + 1) * PAGE_SIZE) Dim GameVersion As String = If(TextSearchVersion.Text = "全部 (也可自行输入)", Nothing, - If(TextSearchVersion.Text.Contains(".") OrElse TextSearchVersion.Text.Contains("w"), TextSearchVersion.Text, Nothing)) + If(TextSearchVersion.Text.Contains(".") OrElse TextSearchVersion.Text.Contains("w"), TextSearchVersion.Text, Nothing)) With Request .SearchText = TextSearchName.Text .GameVersion = GameVersion .Tag = ComboSearchTag.SelectedItem.Tag .ModLoader = If(PageType = CompType.Mod, Val(ComboSearchLoader.SelectedItem.Tag), CompModLoaderType.Any) - .Source = CType(Val(ComboSearchSource.SelectedItem.Tag), CompSourceType) + .Sources = CType(Val(ComboSearchSource.SelectedItem.Tag), CompSourceType) End With Return Request End Function @@ -133,7 +138,7 @@ Public Class PageComp ''' ''' 每页展示的结果数量。 ''' - Public Const PageSize = 40 + Public Const PAGE_SIZE = 40 Public Page As Integer = 0 '结果 UI 化 @@ -142,8 +147,9 @@ Public Class PageComp Log($"[Comp] 开始可视化{TypeNameSpaced}列表，已储藏 {Storage.Results.Count} 个结果，当前在第 {Page + 1} 页") '列表项 PanProjects.Children.Clear() - For i = Math.Min(Page * PageSize, Storage.Results.Count - 1) To Math.Min((Page + 1) * PageSize - 1, Storage.Results.Count - 1) - PanProjects.Children.Add(Storage.Results(i).ToCompItem( + Dim Index As Integer = Math.Min(Page * PAGE_SIZE, Storage.Results.Count - 1) + For Each Result In Storage.Results.GetRange(Index, Math.Min(Storage.Results.Count - Index, PAGE_SIZE)) + PanProjects.Children.Add(Result.ToCompItem( ShowMcVersionDesc:=Loader.Input.GameVersion Is Nothing, ShowLoaderDesc:=Loader.Input.ModLoader = CompModLoaderType.Any AndAlso (PageType = CompType.Mod OrElse PageType = CompType.ModPack))) Next @@ -157,7 +163,7 @@ Public Class PageComp BtnPageLeft.IsEnabled = Page > 0 BtnPageLeft.Opacity = If(Page > 0, 1, 0.2) Dim IsRightEnabled As Boolean = '由于 WPF 的未知 bug，读取到的 IsEnabled 可能是错误的值（#3319） - Storage.Results.Count > PageSize * (Page + 1) OrElse + Storage.Results.Count > PAGE_SIZE * (Page + 1) OrElse Storage.CurseForgeOffset < Storage.CurseForgeTotal OrElse Storage.ModrinthOffset < Storage.ModrinthTotal BtnPageRight.IsEnabled = IsRightEnabled BtnPageRight.Opacity = If(IsRightEnabled, 1, 0.2) diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml index 3a52922..f95e25d 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadCompDetail" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> @@ -20,6 +20,7 @@ + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb index ea5c4c0..ec936d4 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb @@ -8,7 +8,7 @@ Sub(Task) LoadTargetFromAdditional() Dim Result = CompFilesGet(Project.Id, Project.FromCurseForge) - If Task.IsAborted Then Return + If Task.IsInterrupted Then Return Task.Output = Result End Sub) @@ -19,16 +19,17 @@ End Sub Public Sub LoadTargetFromAdditional() Handles Me.Loaded Project = FrmMain.PageCurrent.Additional(0) - TargetVersion = FrmMain.PageCurrent.Additional(2) + TargetInstance = FrmMain.PageCurrent.Additional(2) TargetLoader = FrmMain.PageCurrent.Additional(3) - PageType = FrmMain.PageCurrent.Additional(4) + TargetType = FrmMain.PageCurrent.Additional(4) End Sub Private Project As CompProject - Private TargetVersion As String, TargetLoader As CompModLoaderType + Private TargetInstance As String, TargetLoader As CompModLoaderType ''' - ''' 当前页面应展示的内容类别。可能为 Any。 + ''' 当前页面应展示的内容类别。 + ''' 若当前页面是在查看前置时进入，则也可能为 Any。 ''' - Private PageType As CompType + Private TargetType As CompType '自动重试 Private Sub Load_State(sender As Object, state As MyLoading.MyLoadingState, oldState As MyLoading.MyLoadingState) Handles Load.StateChanged Select Case CompFileLoader.State @@ -52,16 +53,16 @@ If x = Topmost Then Return -1 If y = Topmost Then Return 1 '特殊版本 - Dim IsXSpecial As Boolean = x.EndsWithF("版本") - Dim IsYSpecial As Boolean = y.EndsWithF("版本") + Dim IsXSpecial As Boolean = Not x.Contains(".") + Dim IsYSpecial As Boolean = Not y.Contains(".") If IsXSpecial AndAlso IsYSpecial Then Return x.CompareTo(y) If IsXSpecial Then Return 1 If IsYSpecial Then Return -1 '比较版本号 - Dim VersionCodeSort = -VersionSortInteger(x.Replace(x.BeforeFirst(" ") & " ", ""), y.Replace(y.BeforeFirst(" ") & " ", "")) + Dim VersionCodeSort = -CompareVersion(x.Replace(x.BeforeFirst(" ") & " ", ""), y.Replace(y.BeforeFirst(" ") & " ", "")) If VersionCodeSort <> 0 Then Return VersionCodeSort '比较全部 - Return -VersionSortInteger(x, y) + Return -CompareVersion(x, y) End Function Public Sub New(Optional Topmost As String = "") Me.Topmost = If(Topmost, "") @@ -69,49 +70,59 @@ End Class Private VersionFilter As String - Private IsMajorVersionFilter As Boolean '是否按大版本号筛选（1.21 / 1.20 / 1.19 / ...）而非小版本号（1.21.1 / 1.21 / 1.20.4 / ...） + Private GroupedDrop As Boolean '是否按 Drop 筛选（1.21 / 1.20 / 1.19 / ...）而非小版本号（1.21.1 / 1.21 / 1.20.4 / ...） + Private GroupedOld As Boolean '是否折叠远古版本为一个选项 '筛选类型相同的结果（Modrinth 会返回 Mod、服务端插件、数据包混合的列表） Private Function GetResults() As List(Of CompFile) Dim Results As List(Of CompFile) = CompFileLoader.Output - If PageType = CompType.Any Then - Results = Results.Where(Function(r) r.Type <> CompType.Plugin).ToList - ElseIf PageType = CompType.Shader OrElse PageType = CompType.ResourcePack Then - Results = Results.ToList - Else - Results = Results.Where(Function(r) r.Type = PageType).ToList - End If + Select Case TargetType + Case CompType.Any + Results = Results.Where(Function(r) r.Type <> CompType.Plugin).ToList + Case CompType.Shader, CompType.ResourcePack + '不筛选光影和资源包，否则原版光影会因为是资源包格式而被过滤（#6473） + Case Else + Results = Results.Where(Function(r) r.Type = TargetType).ToList + End Select Return Results End Function Private Sub Load_OnFinish() Dim Results = GetResults() '初始化筛选器 - Dim VersionFilters As List(Of String) - - '按小版本号筛选？ - IsMajorVersionFilter = False - VersionFilters = Results.SelectMany(Function(v) v.GameVersions).Select(Function(v) GetGroupedVersionName(v, IsMajorVersionFilter, True)). - Distinct.OrderByDescending(Function(s) s, New VersionComparer).ToList - '按大版本号筛选？ - If VersionFilters.Count >= 9 Then - IsMajorVersionFilter = True - VersionFilters = Results.SelectMany(Function(v) v.GameVersions).Select(Function(v) GetGroupedVersionName(v, IsMajorVersionFilter, True)). + Dim Filters As List(Of String) = Nothing + Dim UpdateFilters = + Sub() + Filters = Results.SelectMany(Function(v) v.GameVersions).Select(Function(v) GetGroupedVersionName(v, GroupedDrop, GroupedOld)). Distinct.OrderByDescending(Function(s) s, New VersionComparer).ToList - End If + End Sub + + '确定分组方式 + GroupedDrop = False : GroupedOld = False + UpdateFilters() + If Filters.Count < 9 Then GoTo GroupDone + GroupedDrop = True : GroupedOld = False + UpdateFilters() + If Filters.Count < 9 Then GoTo GroupDone + GroupedDrop = False : GroupedOld = True + UpdateFilters() + If Filters.Count < 9 Then GoTo GroupDone + GroupedDrop = True : GroupedOld = True + UpdateFilters() +GroupDone: 'UI 化筛选器 PanFilter.Children.Clear() - If VersionFilters.Count < 2 Then + If Filters.Count < 2 Then CardFilter.Visibility = Visibility.Collapsed VersionFilter = Nothing Else CardFilter.Visibility = Visibility.Visible - VersionFilters.Insert(0, "全部") + Filters.Insert(0, "全部") '转化为按钮 - For Each Version As String In VersionFilters + For Each Version As String In Filters Dim NewButton As New MyRadioButton With { .Text = Version, .Margin = New Thickness(2, 0, 2, 0), .ColorType = MyRadioButton.ColorState.Highlight} - NewButton.LabText.Margin = New Thickness(-2, 0, 8, 0) + NewButton.LabText.Margin = New Thickness(-2, 0, 10, 0) AddHandler NewButton.Check, Sub(sender As MyRadioButton, raiseByMouse As Boolean) VersionFilter = If(sender.Text = "全部", Nothing, sender.Text) @@ -121,10 +132,10 @@ Next '自动选择 Dim ToCheck As MyRadioButton = Nothing - If TargetVersion <> "" Then - Dim TargetFile = Results.FirstOrDefault(Function(v) v.GameVersions.Contains(TargetVersion)) + If TargetInstance <> "" Then + Dim TargetFile = Results.FirstOrDefault(Function(v) v.GameVersions.Contains(TargetInstance)) If TargetFile IsNot Nothing Then - Dim TargetGroup = GetGroupedVersionName(TargetVersion, IsMajorVersionFilter, True) + Dim TargetGroup = GetGroupedVersionName(TargetInstance, GroupedDrop, GroupedOld) For Each Button As MyRadioButton In PanFilter.Children If Button.Text <> TargetGroup Then Continue For ToCheck = Button @@ -142,26 +153,26 @@ Private Sub UpdateFilterResult() Dim Results = GetResults() - Dim TargetCardName As String = If(TargetVersion <> "" OrElse TargetLoader <> CompModLoaderType.Any, - $"所选版本：{If(TargetLoader <> CompModLoaderType.Any, TargetLoader.ToString & " ", "")}{TargetVersion}", "") + Dim TargetCardName As String = If(TargetInstance <> "" OrElse TargetLoader <> CompModLoaderType.Any, + $"{If(TargetLoader <> CompModLoaderType.Any, TargetLoader.ToString & " ", "")}{TargetInstance}（所选版本）", "") '归类到卡片下 Dim Dict As New SortedDictionary(Of String, List(Of CompFile))(New CardSorter(TargetCardName)) - Dict.Add("其他版本", New List(Of CompFile)) + Dict.Add("其他", New List(Of CompFile)) Dim SupportedLoaders As New List(Of Integer)([Enum].GetValues(GetType(CompModLoaderType))) For Each Version As CompFile In Results For Each GameVersion In Version.GameVersions '检查是否符合版本筛选器 If VersionFilter IsNot Nothing AndAlso - GetGroupedVersionName(GameVersion, IsMajorVersionFilter, True) <> VersionFilter Then Continue For + GetGroupedVersionName(GameVersion, GroupedDrop, GroupedOld) <> VersionFilter Then Continue For '决定添加到哪个卡片 Dim VerName As String = GetGroupedVersionName(GameVersion, False, False) '遍历加入的加载器列表 Dim Loaders As New List(Of String) If Project.ModLoaders.Count > 1 AndAlso '工程至少有两个加载器 Version.Type = CompType.Mod AndAlso '是 Mod - VerName.StartsWith("1.") Then '不是 “快照版本” 之类的 + McVersion.IsFormatFit(VerName) Then '不是 “快照版本” 之类的 For Each Loader In Version.ModLoaders - If Loader = CompModLoaderType.Quilt AndAlso Setup.Get("ToolDownloadIgnoreQuilt") Then Continue For + If Loader = CompModLoaderType.Quilt AndAlso Settings.Get("ToolDownloadIgnoreQuilt") Then Continue For If SupportedLoaders.Contains(Loader) Then Loaders.Add(Loader.ToString & " ") Next End If @@ -175,14 +186,14 @@ Next Next '添加筛选的版本的卡片 - If TargetCardName <> "" AndAlso (VersionFilter Is Nothing OrElse GetGroupedVersionName(TargetVersion, IsMajorVersionFilter, True).StartsWithF(VersionFilter)) Then + If TargetCardName <> "" AndAlso (VersionFilter Is Nothing OrElse GetGroupedVersionName(TargetInstance, GroupedDrop, GroupedOld).StartsWithF(VersionFilter)) Then Dict.Add(TargetCardName, New List(Of CompFile)) For Each Version As CompFile In Results - If Version.GameVersions.Contains(TargetVersion) AndAlso + If Version.GameVersions.Contains(TargetInstance) AndAlso (TargetLoader = CompModLoaderType.Any OrElse Version.ModLoaders.Contains(TargetLoader)) Then '检查是否符合版本筛选器 If VersionFilter IsNot Nothing AndAlso - Not Version.GameVersions.Any(Function(v) GetGroupedVersionName(v, IsMajorVersionFilter, True) = VersionFilter) Then Continue For + Not Version.GameVersions.Any(Function(v) GetGroupedVersionName(v, GroupedDrop, GroupedOld) = VersionFilter) Then Continue For If Not Dict(TargetCardName).Contains(Version) Then Dict(TargetCardName).Add(Version) End If Next @@ -192,8 +203,9 @@ PanResults.Children.Clear() For Each Pair As KeyValuePair(Of String, List(Of CompFile)) In Dict If Not Pair.Value.Any() Then Continue For + If Pair.Key = TargetCardName.Replace("（所选版本）", "") Then Continue For '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key, .Margin = New Thickness(0, 0, 0, 15), .SwapType = If(PageType = CompType.ModPack, 9, 8)} '9 是安装，8 是另存为 + Dim NewCard As New MyCard With {.Title = Pair.Key, .Margin = New Thickness(0, 0, 0, 15), .SwapType = If(TargetType = CompType.ModPack, 9, 8)} '9 是安装，8 是另存为 Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} NewCard.Children.Add(NewStack) NewCard.SwapControl = NewStack @@ -202,32 +214,43 @@ If Pair.Key = TargetCardName OrElse (FrmMain.PageCurrent.Additional IsNot Nothing AndAlso '#2761 CType(FrmMain.PageCurrent.Additional(1), List(Of String)).Contains(NewCard.Title)) Then - MyCard.StackInstall(NewStack, If(PageType = CompType.ModPack, 9, 8), Pair.Key) '9 是安装，8 是另存为 + MyCard.StackInstall(NewStack, If(TargetType = CompType.ModPack, 9, 8), Pair.Key) '9 是安装，8 是另存为 Else - NewCard.IsSwaped = True + NewCard.IsSwapped = True End If '增加提示 - If Pair.Key = "其他版本" Then + If Pair.Key = "其他" Then NewStack.Children.Add(New MyHint With {.Text = "由于版本信息更新缓慢，可能无法识别刚更新的 MC 版本。几天后即可正常识别。", .Theme = MyHint.Themes.Yellow, .Margin = New Thickness(5, 0, 0, 8)}) End If Next '如果只有一张卡片，展开第一张卡片 If PanResults.Children.Count = 1 Then - CType(PanResults.Children(0), MyCard).IsSwaped = False + CType(PanResults.Children(0), MyCard).IsSwapped = False + End If + '替代提示 + If Project.Types = CompType.ModOrDataPack AndAlso (TargetType = CompType.Mod OrElse TargetType = CompType.DataPack) Then + HintAlternative.Visibility = Visibility.Visible + HintAlternative.Text = If(TargetType = CompType.Mod, + "以下是该项目的 Mod 版本。点击这里查看其数据包版本。", "以下是该项目的数据包版本。点击这里查看其 Mod 版本。") + Else + HintAlternative.Visibility = Visibility.Collapsed End If Catch ex As Exception Log(ex, "可视化工程下载列表出错", LogLevel.Feedback) End Try End Sub - Private Function GetGroupedVersionName(Name As String, MajorOnly As Boolean, FoldOldRelease As Boolean) As String + Private Function GetGroupedVersionName(Name As String, GroupedByDrop As Boolean, FoldOld As Boolean) As String + Dim Drop = McVersion.VersionToDrop(Name) If Name Is Nothing Then - Return "其他版本" - ElseIf Name.Contains("w") Then - Return "快照版本" - ElseIf Name.StartsWith("1.0") OrElse Not Name.StartsWith("1.") OrElse (FoldOldRelease AndAlso Val(Name.Split(".")(1)) < 10) Then - Return "远古版本" + Return "其他" + ElseIf Name.Contains("w") OrElse Drop = 209 Then + Return "快照版" + ElseIf Not McVersion.IsFormatFit(Name) OrElse (FoldOld AndAlso Drop < 120) Then + Return "远古版" + ElseIf GroupedByDrop Then + Return McVersion.DropToVersion(Drop) Else - Return If(MajorOnly, "1." & Name.Split(".")(1).BeforeFirst(" "), Name) + Return Name End If End Function @@ -249,7 +272,7 @@ '放置当前工程 If CompItem IsNot Nothing Then PanIntro.Children.Remove(CompItem) - CompItem = Project.ToCompItem(True, True) + CompItem = Project.ToCompItem(True, True).Init() CompItem.CanInteraction = False CompItem.Margin = New Thickness(-7, -7, 0, 8) PanIntro.Children.Insert(0, CompItem) @@ -271,33 +294,33 @@ '获取版本名 Dim PackName As String = Project.TranslatedName.Replace(".zip", "").Replace(".rar", "").Replace(".mrpack", "").Replace("\", "＼").Replace("/", "／").Replace("|", "｜").Replace(":", "：").Replace("<", "＜").Replace(">", "＞").Replace("*", "＊").Replace("?", "？").Replace("""", "").Replace("： ", "：") - Dim Validate As New ValidateFolderName(PathMcFolder & "versions") + Dim Validate As New ValidateFolderName(McFolderSelected & "versions") If Validate.Validate(PackName) <> "" Then PackName = "" - Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate}) - If String.IsNullOrEmpty(VersionName) Then Return + Dim InstanceName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate}) + If String.IsNullOrEmpty(InstanceName) Then Return '构造步骤加载器 Dim Loaders As New List(Of LoaderBase) - Dim Target As String = $"{PathMcFolder}versions\{VersionName}\原始整合包.{If(Project.FromCurseForge, "zip", "mrpack")}" - Dim LogoFileAddress As String = MyImage.GetTempPath(CompItem.Logo) + Dim Target As String = $"{McFolderSelected}versions\{InstanceName}\原始整合包.{If(Project.FromCurseForge, "zip", "mrpack")}" + Dim LogoFileAddress As String = CompItem.PathLogo.ActualSource Loaders.Add(New LoaderDownload("下载整合包文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 10, .Block = True}) Loaders.Add(New LoaderTask(Of Integer, Integer)("准备安装整合包", - Sub() ModpackInstall(Target, VersionName, If(IO.File.Exists(LogoFileAddress), LogoFileAddress, Nothing))) With {.ProgressWeight = 0.1}) + Sub() ModpackInstall(Target, InstanceName, If(IO.File.Exists(LogoFileAddress), LogoFileAddress, Nothing))) With {.ProgressWeight = 0.1}) '启动 Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = Sub(MyLoader) Select Case MyLoader.State Case LoadState.Failed - Hint(MyLoader.Name & "失败：" & GetExceptionSummary(MyLoader.Error), HintType.Critical) - Case LoadState.Aborted - Hint(MyLoader.Name & "已取消！", HintType.Info) + Hint(MyLoader.Name & "失败：" & MyLoader.Error.GetBrief(), HintType.Red) + Case LoadState.Interrupted + Hint(MyLoader.Name & "已取消！", HintType.Blue) Case LoadState.Loading Return '不重新加载版本列表 End Select McInstallFailedClearFolder(MyLoader) End Sub} - Loader.Start(PathMcFolder & "versions\" & VersionName & "\") + Loader.Start(McFolderSelected & "versions\" & InstanceName & "\") LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() FrmMain.BtnExtraDownload.Ribble() @@ -307,7 +330,7 @@ End Try End Sub '资源下载；整合包另存为 - Public Shared CachedFolder As String = Nothing '仅在本次缓存的下载文件夹 + Public Shared CachedFolder As New Dictionary(Of CompType, String) '仅在本次缓存的下载文件夹 Public Sub Save_Click(sender As Object, e As EventArgs) Dim File As CompFile = If(TypeOf sender Is MyListItem, sender, sender.Parent).Tag RunInNewThread( @@ -325,13 +348,13 @@ Dim DefaultFolder As String = Nothing If File.Type <> CompType.ModPack Then Dim SubFolder As String = Nothing - Select Case Project.Type + Select Case File.Type Case CompType.Mod : SubFolder = "mods\" Case CompType.ResourcePack : SubFolder = "resourcepacks\" Case CompType.Shader : SubFolder = "shaderpacks\" Case CompType.DataPack : SubFolder = "" '导航到版本根目录 End Select - Dim IsVersionSuitable As Func(Of McVersion, Boolean) = Nothing + Dim IsInstanceSuitable As Func(Of McInstance, Boolean) = Nothing '获取资源所需的加载器 Dim AllowedLoaders As New List(Of CompModLoaderType) If File.ModLoaders.Any Then @@ -341,51 +364,81 @@ End If Log($"[Comp] {Desc}要求的加载器种类：" & If(AllowedLoaders.Any(), AllowedLoaders.Join(" / "), "无要求")) '判断某个版本是否符合资源要求 - IsVersionSuitable = - Function(Version) - If Not Version.IsLoaded Then Version.Load() + IsInstanceSuitable = + Function(Instance As McInstance) + If Not Instance.IsLoaded Then Instance.Load() '只对 Mod 和数据包进行版本检测 - If Project.Type = CompType.Mod OrElse Project.Type = CompType.DataPack Then - If File.GameVersions.Any(Function(v) v.Contains(".")) AndAlso - Not File.GameVersions.Any(Function(v) v.Contains(".") AndAlso v = Version.Version.McName) Then Return False + If File.Type = CompType.Mod OrElse File.Type = CompType.DataPack Then + If Not File.GameVersions.Any( '判断是否有任何一个版本匹配 + Function(FileVersion) + Dim FileIsSnapshot As Boolean = FileVersion.Contains("预览版") OrElse Not FileVersion.Contains(".") + Dim InstanceIsSnapshot As Boolean = Instance.Version.VanillaName.Contains("snapshot") OrElse Not Instance.Version.VanillaName.Contains(".") + If FileIsSnapshot <> InstanceIsSnapshot Then + '只有一种是预览版 + Return False + ElseIf Not FileIsSnapshot AndAlso Not InstanceIsSnapshot Then + '都不是预览版 + Return FileVersion = Instance.Version.VanillaName + Else + '都是预览版 + Dim FileIsNewFormat As Boolean = FileVersion.Contains(".") AndAlso Val(FileVersion.BeforeFirst(".")) > 1 + Dim InstanceIsNewFormat As Boolean = Instance.Version.Drop > 250 + If FileIsNewFormat <> InstanceIsNewFormat Then + '只有一种是新格式快照 + Return False + ElseIf FileIsNewFormat AndAlso InstanceIsNewFormat Then + '都是新格式快照 + Return FileVersion.BeforeFirst(" ") = Instance.Version.VanillaName.BeforeFirst("-") + Else + '都是旧格式快照 + If FileVersion.Contains("w") AndAlso Instance.Version.VanillaName.Contains("w") Then + '都是 w 快照 + Return FileVersion = Instance.Version.VanillaName + Else + '不全是 w 快照 + Return True '只能假定相同，无法判断 + End If + End If + End If + End Function) Then Return False End If '加载器 If Not AllowedLoaders.Any() Then Return True '无要求 - If AllowedLoaders.Contains(CompModLoaderType.Forge) AndAlso Version.Version.HasForge Then Return True - If AllowedLoaders.Contains(CompModLoaderType.Fabric) AndAlso Version.Version.HasFabric Then Return True - If AllowedLoaders.Contains(CompModLoaderType.NeoForge) AndAlso Version.Version.HasNeoForge Then Return True - If AllowedLoaders.Contains(CompModLoaderType.LiteLoader) AndAlso Version.Version.HasLiteLoader Then Return True + If AllowedLoaders.Contains(CompModLoaderType.Forge) AndAlso Instance.Version.HasForge Then Return True + If AllowedLoaders.Contains(CompModLoaderType.Fabric) AndAlso Instance.Version.HasFabric Then Return True + If AllowedLoaders.Contains(CompModLoaderType.NeoForge) AndAlso Instance.Version.HasNeoForge Then Return True + If AllowedLoaders.Contains(CompModLoaderType.LiteLoader) AndAlso Instance.Version.HasLiteLoader Then Return True Return False End Function '获取常规资源默认下载位置 - If CachedFolder IsNot Nothing Then - DefaultFolder = CachedFolder + If CachedFolder.ContainsKey(File.Type) Then + DefaultFolder = CachedFolder(File.Type) Log($"[Comp] 使用上次下载时的文件夹作为默认下载位置：{DefaultFolder}") - ElseIf McVersionCurrent IsNot Nothing AndAlso IsVersionSuitable(McVersionCurrent) Then - DefaultFolder = $"{McVersionCurrent.PathIndie}{SubFolder}" + ElseIf McInstanceSelected IsNot Nothing AndAlso IsInstanceSuitable(McInstanceSelected) Then + DefaultFolder = $"{McInstanceSelected.PathIndie}{SubFolder}" Directory.CreateDirectory(DefaultFolder) Log($"[Comp] 使用当前版本作为默认下载位置：{DefaultFolder}") Else '查找所有可能的版本 - Dim NeedLoad As Boolean = McVersionListLoader.State <> LoadState.Finished + Dim NeedLoad As Boolean = McInstanceListLoader.State <> LoadState.Finished If NeedLoad Then Hint("正在查找适合的游戏版本……") - LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True) + LoaderFolderRun(McInstanceListLoader, McFolderSelected, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True) End If - Dim SuitableVersions = McVersionList.Values.SelectMany(Function(l) l).Where(Function(v) IsVersionSuitable(v)). + Dim SuitableInstanceList = McInstanceList.Values.SelectMany(Function(l) l).Where(Function(v) IsInstanceSuitable(v)). Select(Function(v) New DirectoryInfo($"{v.PathIndie}{SubFolder}")) - If SuitableVersions.Any Then - Dim SelectedVersion = SuitableVersions. + If SuitableInstanceList.Any Then + Dim SelectedInstance = SuitableInstanceList. OrderByDescending(Function(Dir) If(Dir.Exists, Dir.LastWriteTimeUtc, Date.MinValue)). '先按文件夹更改时间降序 ThenByDescending(Function(Dir) If(Dir.Exists, Dir.GetFiles().Length, -1)). '再按文件夹中的文件数量降序 First() - DefaultFolder = SelectedVersion.FullName + DefaultFolder = SelectedInstance.FullName Directory.CreateDirectory(DefaultFolder) Log($"[Comp] 使用适合的游戏版本作为默认下载位置：{DefaultFolder}") Else - DefaultFolder = PathMcFolder + DefaultFolder = McFolderSelected If NeedLoad Then - Hint("当前 MC 文件夹中没有找到适合此资源的版本！") + Hint($"当前 MC 文件夹中没有找到合适的版本！") Else Log("[Comp] 由于当前版本不兼容，使用当前的 MC 文件夹作为默认下载位置") End If @@ -399,7 +452,7 @@ Else Dim ChineseName As String = Project.TranslatedName.BeforeFirst(" (").BeforeFirst(" - "). Replace("\", "＼").Replace("/", "／").Replace("|", "｜").Replace(":", "：").Replace("<", "＜").Replace(">", "＞").Replace("*", "＊").Replace("?", "？").Replace("""", "").Replace("： ", "：") - Select Case Setup.Get("ToolDownloadTranslateV2") + Select Case Settings.Get("ToolDownloadTranslateV2") Case 0 FileName = $"【{ChineseName}】{File.FileName}" Case 1 @@ -412,6 +465,7 @@ FileName = File.FileName End Select End If + If File.Type = CompType.Mod Then FileName = FileName.Replace("~", "-") '~ 会导致 Mixin 加载失败 RunInUi( Sub() '弹窗要求选择保存位置 @@ -419,12 +473,12 @@ Target = SelectSaveFile("选择保存位置", FileName, Desc & "文件|" & If(File.Type = CompType.Mod, - If(File.FileName.EndsWith(".litemod"), "*.litemod", "*.jar"), - If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder) + If(File.FileName.EndsWithF(".litemod"), "*.litemod", "*.jar"), + If(File.FileName.EndsWithF(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder) If Not Target.Contains("\") Then Return '构造步骤加载器 - Dim LoaderName As String = Desc & "下载：" & GetFileNameWithoutExtentionFromPath(Target) & " " - If Target <> DefaultFolder AndAlso File.Type = CompType.Mod Then CachedFolder = GetPathFromFullPath(Target) + Dim LoaderName As String = Desc & "下载：" & IO.Path.GetFileNameWithoutExtension(Target) & " " + If Target <> DefaultFolder Then CachedFolder(File.Type) = GetPathFromFullPath(Target) Dim Loaders As New List(Of LoaderBase) Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True}) '启动 @@ -450,4 +504,11 @@ ClipboardSet(CompItem.LabTitle.Text & CompItem.LabTitleRaw.Text) End Sub + 'Mod / 数据包 互相跳转 + Private Sub HintAlternative_Click() Handles HintAlternative.Click + TargetType = If(TargetType = CompType.Mod, CompType.DataPack, CompType.Mod) + FrmMain.PageCurrent.Additional(4) = TargetType '加载器会从这里重新拿数据 + PageLoaderRestart(IsForceRestart:=True) + End Sub + End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml index f7c01e9..c07469c 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadDataPack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml index c7914d9..4438d0d 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadMod" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> @@ -27,7 +27,8 @@ - + + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml index 51f04d6..0954583 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadPack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> @@ -17,7 +17,7 @@ - + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml index 91932d5..ec7ead0 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadResourcePack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml index 123ce1b..9d0ca3b 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadShader" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb b/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb index 5829841..036589a 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb @@ -1,73 +1,16 @@ Imports System.IO.Compression -Imports System.Net.Http Public Module ModDownloadLib - ''' - ''' 如果 OptiFine 与 Forge 同时开始安装，就会导致 Forge 安装失败。 - ''' - Private InstallSyncLock As New Object - ''' - ''' 如果 OptiFine 与 Forge 同时复制原版 Jar，就会导致复制文件时冲突。 - ''' - Private VanillaSyncLock As New Object - ''' - ''' 最高的 Minecraft 大版本号，-1 代表尚未获取。 - ''' - Public McVersionHighest As Integer = -1 - #Region "Minecraft 下载" - ''' - ''' 下载某个 Minecraft 版本，这会创造一个单独的下载任务，失败会跳过执行并要求反馈。 - ''' 返回正在下载的任务，若跳过或失败，则返回 Nothing。 - ''' - ''' 所下载的 Minecraft 的版本名。 - ''' Json 文件的 Mojang 官方地址。 - Public Function McDownloadClient(Behaviour As NetPreDownloadBehaviour, Id As String, Optional JsonUrl As String = Nothing) As LoaderCombo(Of String) - Try - Dim VersionFolder As String = PathMcFolder & "versions\" & Id & "\" - - '重复任务检查 - For Each OngoingLoader In LoaderTaskbar.ToList() - If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For - If Behaviour = NetPreDownloadBehaviour.ExitWhileExistsOrDownloading Then Return OngoingLoader - Hint("该版本正在下载中！", HintType.Critical) - Return OngoingLoader - Next - - '已有版本检查 - If Behaviour <> NetPreDownloadBehaviour.IgnoreCheck AndAlso File.Exists(VersionFolder & Id & ".json") AndAlso File.Exists(VersionFolder & Id & ".jar") Then - If Behaviour = NetPreDownloadBehaviour.ExitWhileExistsOrDownloading Then Return Nothing - If MyMsgBox("版本 " & Id & " 已存在，是否重新下载？" & vbCrLf & "这会覆盖版本的 json 与 jar 文件，但不会影响版本隔离的文件。", "版本已存在", "继续", "取消") = 1 Then - File.Delete(VersionFolder & Id & ".jar") - File.Delete(VersionFolder & Id & ".json") - Else - Return Nothing - End If - End If - - '启动 - Dim Loader As New LoaderCombo(Of String)("Minecraft " & Id & " 下载", McDownloadClientLoader(Id, JsonUrl)) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(VersionFolder) - LoaderTaskbarAdd(Loader) - FrmMain.BtnExtraDownload.ShowRefresh() - FrmMain.BtnExtraDownload.Ribble() - Return Loader - - Catch ex As Exception - Log(ex, "开始 Minecraft 下载失败", LogLevel.Feedback) - Return Nothing - End Try - End Function - ''' ''' 获取下载某个 Minecraft 版本的加载器列表。 - ''' 它必须安装到 PathMcFolder，但是可以自定义版本名（不过自定义的版本名不会修改 Json 中的 id 项）。 + ''' 它必须安装到 McFolderSelected，但是可以自定义版本名（不过自定义的版本名不会修改 Json 中的 id 项）。 ''' - Private Function McDownloadClientLoader(Id As String, Optional JsonUrl As String = Nothing, Optional VersionName As String = Nothing) As List(Of LoaderBase) - VersionName = If(VersionName, Id) - Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\" + Private Function McDownloadClientLoader(Id As String, Optional JsonUrl As String = Nothing, Optional InstanceName As String = Nothing) As List(Of LoaderBase) + InstanceName = If(InstanceName, Id) + Dim VersionFolder As String = McFolderSelected & "versions\" & InstanceName & "\" Dim Loaders As New List(Of LoaderBase) @@ -76,11 +19,11 @@ Public Module ModDownloadLib Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("获取原版 json 文件下载地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Dim JsonAddress As String = DlClientListGet(Id) - Task.Output = New List(Of NetFile) From {New NetFile(DlSourceLauncherOrMetaGet(JsonAddress), VersionFolder & VersionName & ".json")} + Task.Output = New List(Of NetFile) From {New NetFile(DlSourceLauncherOrMetaGet(JsonAddress), VersionFolder & InstanceName & ".json")} End Sub) With {.ProgressWeight = 2, .Show = False}) End If Loaders.Add(New LoaderDownload(McDownloadClientJsonName, New List(Of NetFile) From { - New NetFile(DlSourceLauncherOrMetaGet(If(JsonUrl, "")), VersionFolder & VersionName & ".json", New FileChecker(CanUseExistsFile:=False, IsJson:=True)) + New NetFile(DlSourceLauncherOrMetaGet(If(JsonUrl, "")), VersionFolder & InstanceName & ".json", New FileChecker(CanUseExistsFile:=False, IsJson:=True)) }) With {.ProgressWeight = 3}) '下载支持库文件 @@ -89,7 +32,7 @@ Public Module ModDownloadLib Sub(Task As LoaderTask(Of String, List(Of NetFile))) Thread.Sleep(50) '等待 JSON 文件实际写入硬盘（#3710） Log("[Download] 开始分析原版支持库文件：" & VersionFolder) - Task.Output = McLibFix(New McVersion(VersionFolder)) + Task.Output = McLibNetFilesFromInstance(New McInstance(VersionFolder)) End Sub) With {.ProgressWeight = 1, .Show = False}) LoadersLib.Add(New LoaderDownload("下载原版支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 13, .Show = False}) Loaders.Add(New LoaderCombo(Of String)(McDownloadClientLibName, LoadersLib) With {.Block = False, .ProgressWeight = 14}) @@ -99,27 +42,25 @@ Public Module ModDownloadLib LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析资源文件索引地址（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Try - Dim Version As New McVersion(VersionFolder) - Task.Output = New List(Of NetFile) From {DlClientAssetIndexGet(Version)} + Dim AssetIndex = DlClientAssetIndexGet(New McInstance(VersionFolder)) + Task.Output = If(AssetIndex Is Nothing, New List(Of NetFile), New List(Of NetFile) From {AssetIndex}) Catch ex As Exception Throw New Exception("分析资源文件索引地址失败", ex) End Try '顺手添加 Json 项目 Try - Dim VersionJson As JObject = GetJson(ReadFile(VersionFolder & VersionName & ".json")) - VersionJson.Add("clientVersion", Id) - WriteFile(VersionFolder & VersionName & ".json", VersionJson.ToString) + Dim InstanceJson As JObject = GetJson(ReadFile(VersionFolder & InstanceName & ".json")) + InstanceJson.Add("clientVersion", Id) + WriteFile($"{VersionFolder}{InstanceName}.json", InstanceJson.ToString) Catch ex As Exception Throw New Exception("添加客户端版本失败", ex) End Try End Sub) With {.ProgressWeight = 1, .Show = False}) LoadersAssets.Add(New LoaderDownload("下载资源文件索引（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 3, .Show = False}) LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析所需资源文件（副加载器）", - Sub(Task As LoaderTask(Of String, List(Of NetFile))) - Task.Output = McAssetsFixList(New McVersion(VersionFolder), True, Task) - End Sub) With {.ProgressWeight = 3, .Show = False}) + Sub(Task) Task.Output = McAssetsFixList(New McInstance(VersionFolder), True, Task)) With {.ProgressWeight = 0.01, .Show = False}) LoadersAssets.Add(New LoaderDownload("下载资源文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 14, .Show = False}) - Loaders.Add(New LoaderCombo(Of String)("下载原版资源文件", LoadersAssets) With {.Block = False, .ProgressWeight = 21}) + Loaders.Add(New LoaderCombo(Of String)("下载原版资源文件", LoadersAssets) With {.Block = False, .ProgressWeight = 18}) Return Loaders @@ -131,36 +72,39 @@ Public Module ModDownloadLib #Region "Minecraft 下载菜单" - Public Function McDownloadListItem(Entry As JObject, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyListItem - '确定图标 - Dim Logo As String - Select Case Entry("type") - Case "release" - Logo = PathImage & "Blocks/Grass.png" - Case "snapshot" - Logo = PathImage & "Blocks/CommandBlock.png" - Case "special" - Logo = PathImage & "Blocks/GoldBlock.png" - Case Else - Logo = PathImage & "Blocks/CobbleStone.png" - End Select - '建立控件 - Dim NewItem As New MyListItem With {.Logo = Logo, .SnapsToDevicePixels = True, .Title = Entry("id").ToString, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry} - If Entry("lore") Is Nothing Then - NewItem.Info = Entry("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - Else - NewItem.Info = Entry("lore").ToString - End If - If Entry("url").ToString.Contains("pcl") Then NewItem.Info = "[PCL 特供下载] " & NewItem.Info - AddHandler NewItem.Click, OnClick - '建立菜单 - If IsSaveOnly Then - NewItem.ContentHandler = AddressOf McDownloadSaveMenuBuild - Else - NewItem.ContentHandler = AddressOf McDownloadMenuBuild - End If - '结束 - Return NewItem + Public Function McDownloadListItem(Entry As JObject, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '确定图标 + Dim Logo As String + Select Case Entry("type") + Case "release" + Logo = PathImage & "Blocks/Grass.png" + Case "snapshot" + Logo = PathImage & "Blocks/CommandBlock.png" + Case "special" + Logo = PathImage & "Blocks/GoldBlock.png" + Case Else + Logo = PathImage & "Blocks/CobbleStone.png" + End Select + '建立控件 + Dim NewItem As New MyListItem With {.Logo = Logo, .SnapsToDevicePixels = True, .Title = Entry("id").ToString, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry} + If Entry("lore") Is Nothing Then + NewItem.Info = Entry("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") + Else + NewItem.Info = Entry("lore").ToString + End If + If Entry("url").ToString.Contains("pcl") Then NewItem.Info = "[PCL 特供下载] " & NewItem.Info + AddHandler NewItem.Click, OnClick + '建立菜单 + If IsSaveOnly Then + NewItem.ContentHandler = AddressOf McDownloadSaveMenuBuild + Else + NewItem.ContentHandler = AddressOf McDownloadMenuBuild + End If + '结束 + Return NewItem + End Function) With {.Height = 42} End Function Private Sub McDownloadSaveMenuBuild(sender As Object, e As EventArgs) Dim BtnInfo As New MyIconButton With {.LogoScale = 1.05, .Logo = Logo.IconButtonInfo, .ToolTip = "更新日志"} @@ -223,7 +167,7 @@ Public Module ModDownloadLib '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Minecraft {Id} 服务端下载" Then Continue For - Hint("该服务端正在下载中！", HintType.Critical) + Hint("该服务端正在下载中！", HintType.Red) Return Next @@ -234,23 +178,23 @@ Public Module ModDownloadLib }) With {.ProgressWeight = 2}) '构建服务端 Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("构建服务端", - Sub(Task As LoaderTask(Of String, List(Of NetFile))) - '分析服务端 JAR 文件下载地址 - Dim McVersion As New McVersion(VersionFolder) - If McVersion.JsonObject("downloads") Is Nothing OrElse McVersion.JsonObject("downloads")("server") Is Nothing OrElse McVersion.JsonObject("downloads")("server")("url") Is Nothing Then - File.Delete(VersionFolder & Id & ".json") - If Not New DirectoryInfo(VersionFolder).GetFileSystemInfos.Any() Then Directory.Delete(VersionFolder) - Task.Output = New List(Of NetFile) - Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载，没法下，撤退！", HintType.Critical) - Thread.Sleep(2000) '等玩家把上一个提示看完 - Task.Abort() - Return - End If - Dim JarUrl As String = McVersion.JsonObject("downloads")("server")("url") - Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(McVersion.JsonObject("downloads")("server")("size"), -1), Hash:=McVersion.JsonObject("downloads")("server")("sha1")) - Task.Output = New List(Of NetFile) From {New NetFile(DlSourceLauncherOrMetaGet(JarUrl), VersionFolder & Id & "-server.jar", Checker)} - '添加启动脚本 - Dim Bat As String = + Sub(Task As LoaderTask(Of String, List(Of NetFile))) + '分析服务端 JAR 文件下载地址 + Dim Instance As New McInstance(VersionFolder) + If Instance.JsonObject("downloads") Is Nothing OrElse Instance.JsonObject("downloads")("server") Is Nothing OrElse Instance.JsonObject("downloads")("server")("url") Is Nothing Then + File.Delete(VersionFolder & Id & ".json") + If Not New DirectoryInfo(VersionFolder).GetFileSystemInfos.Any() Then DeleteDirectory(VersionFolder) + Task.Output = New List(Of NetFile) + Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载，没法下，撤退！", HintType.Red) + Thread.Sleep(2000) '等玩家把上一个提示看完 + Task.Interrupt() + Return + End If + Dim JarUrl As String = Instance.JsonObject("downloads")("server")("url") + Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(Instance.JsonObject("downloads")("server")("size"), -1), Hash:=Instance.JsonObject("downloads")("server")("sha1")) + Task.Output = New List(Of NetFile) From {New NetFile(DlSourceLauncherOrMetaGet(JarUrl), VersionFolder & Id & "-server.jar", Checker)} + '添加启动脚本 + Dim Bat As String = $"@echo off title {Id} 原版服务端 echo 如果服务端立即停止，请右键编辑该脚本，将下一行开头的 java 替换为适合该 Minecraft 版本的完整 java.exe 的路径。 @@ -258,16 +202,15 @@ echo 你可以在 PCL 的 [设置 → 启动选项] 中查看已安装的 java echo ------------------------------ echo 如果提示 ""You need to agree to the EULA in order to run the server""，请打开 eula.txt，按说明阅读并同意 Minecraft EULA 后，将该文件最后一行中的 eula=false 改为 eula=true。 echo ------------------------------ -""java"" -server -XX:+UseG1GC -Xmx4096M -Xms1024M -XX:+UseCompressedOops -jar {Id}-server.jar nogui +""java"" -server -XX:+UseG1GC -Xmx6144M -Xms1024M -jar {Id}-server.jar nogui echo ---------------------- echo 服务端已停止。 pause" - WriteFile(VersionFolder & "Launch Server.bat", Bat, + WriteFile(VersionFolder & "Launch Server.bat", Bat, Encoding:=If(Encoding.Default.Equals(Encoding.UTF8), Encoding.UTF8, Encoding.GetEncoding("GB18030"))) - '删除版本 JSON - File.Delete(VersionFolder & Id & ".json") - End Sub - ) With {.ProgressWeight = 0.5, .Show = False}) + '删除版本 JSON + File.Delete(VersionFolder & Id & ".json") + End Sub) With {.ProgressWeight = 0.5, .Show = False}) '下载服务端文件 Loaders.Add(New LoaderDownload("下载服务端文件", New List(Of NetFile)) With {.ProgressWeight = 5}) @@ -300,7 +243,7 @@ pause" '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -311,7 +254,7 @@ pause" }) With {.ProgressWeight = 2}) '获取支持库文件地址 Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析核心 JAR 文件下载地址", - Sub(Task) Task.Output = New List(Of NetFile) From {DlClientJarGet(New McVersion(VersionFolder), False)} + Sub(Task) Task.Output = New List(Of NetFile) From {DlClientJarGet(New McInstance(VersionFolder), False)} ) With {.ProgressWeight = 0.5, .Show = False}) '下载支持库文件 Loaders.Add(New LoaderDownload("下载核心 JAR 文件", New List(Of NetFile)) With {.ProgressWeight = 5}) @@ -329,10 +272,10 @@ pause" ''' ''' 显示某 Minecraft 版本的更新日志。 ''' - ''' 在 version_manifest.json 中的对应项。 - Public Sub McUpdateLogShow(VersionJson As JToken) + ''' 在 version_manifest.json 中的对应项。 + Public Sub McUpdateLogShow(InstanceJson As JToken) Dim WikiName As String - Dim Id As String = VersionJson("id").ToString.ToLower + Dim Id As String = InstanceJson("id").ToString.Lower If Id = "3d shareware v1.34" Then WikiName = "3D_Shareware_v1.34" ElseIf Id = "2.0" Then @@ -365,7 +308,7 @@ pause" WikiName = "Java版Beta_1.9_Prerelease_6" ElseIf Id.Contains("b1.9") Then WikiName = "Java版Beta_1.9_Prerelease" - ElseIf VersionJson("type") = "release" OrElse VersionJson("type") = "snapshot" OrElse VersionJson("type") = "special" Then + ElseIf InstanceJson("type") = "release" OrElse InstanceJson("type") = "snapshot" OrElse InstanceJson("type") = "special" Then WikiName = If(Id.Contains("w"), "", "Java版") & Id.Replace(" Pre-Release ", "-pre") ElseIf Id.StartsWithF("b") Then WikiName = "Java版" & Id.TrimEnd("a", "b", "c", "d", "e").Replace("b", "Beta_") @@ -394,18 +337,18 @@ pause" Private Sub McDownloadOptiFineSave(DownloadInfo As DlOptiFineListEntry) Try - Dim Id As String = DownloadInfo.NameVersion - Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.NameFile, "OptiFine Jar (*.jar)|*.jar") + Dim Id As String = DownloadInfo.InstanceName + Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.FileName, "OptiFine Jar (*.jar)|*.jar") If Not Target.Contains("\") Then Return '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() - If OngoingLoader.Name <> $"OptiFine {DownloadInfo.NameDisplay} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + If OngoingLoader.Name <> $"OptiFine {DownloadInfo.DisplayName} 下载" Then Continue For + Hint("该版本正在下载中！", HintType.Red) Return Next - Dim Loader As New LoaderCombo(Of DlOptiFineListEntry)("OptiFine " & DownloadInfo.NameDisplay & " 下载", McDownloadOptiFineSaveLoader(DownloadInfo, Target)) With {.OnStateChanged = AddressOf LoaderStateChangedHintOnly} + Dim Loader As New LoaderCombo(Of DlOptiFineListEntry)("OptiFine " & DownloadInfo.DisplayName & " 下载", McDownloadOptiFineSaveLoader(DownloadInfo, Target)) With {.OnStateChanged = AddressOf LoaderStateChangedHintOnly} Loader.Start(DownloadInfo) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() @@ -421,35 +364,34 @@ pause" SyncLock JavaLock Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0)) If Java Is Nothing Then - If Not JavaDownloadConfirm("Java 8 或更高版本") Then Throw New Exception("由于未找到 Java，已取消安装。") '开始自动下载 - Dim JavaLoader = JavaFixLoaders(17) + Dim JavaLoader = GetJavaDownloadLoader() Try JavaLoader.Start(17, IsForceRestart:=True) - Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsAborted + Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsInterrupted Thread.Sleep(10) Loop Finally - JavaLoader.Abort() '确保取消时中止 Java 下载 + JavaLoader.Interrupt() '确保取消时中止 Java 下载 End Try '检查下载结果 Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0)) - If Task.IsAborted Then Return + If Task.IsInterrupted Then Return If Java Is Nothing Then Throw New Exception("由于未找到 Java，已取消安装。") End If End SyncLock '添加 Java Wrapper 作为主 Jar Dim Arguments As String - If UseJavaWrapper AndAlso Not Setup.Get("LaunchAdvanceDisableJLW") Then - Arguments = $"-Doolloo.jlw.tmpdir=""{PathPure.TrimEnd("\")}"" -Duser.home=""{BaseMcFolderHome.TrimEnd("\")}"" -cp ""{Target}"" -jar ""{ExtractJavaWrapper()}"" optifine.Installer" + If UseJavaWrapper AndAlso Not Settings.Get("LaunchAdvanceDisableJLW") Then + Arguments = $"-Doolloo.jlw.tmpdir=""{PathPure.TrimEnd("\")}"" -Duser.home=""{BaseMcFolderHome.TrimEnd("\")}"" -cp ""{Target}"" -jar ""{ExtractPatch("JavaWrapper")}"" optifine.Installer" Else Arguments = $"-Duser.home=""{BaseMcFolderHome.TrimEnd("\")}"" -cp ""{Target}"" optifine.Installer" End If - If Java.VersionCode >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments + If Java.MajorVersion >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments '开始启动 SyncLock InstallSyncLock Dim Info = New ProcessStartInfo With { - .FileName = Java.PathJavaw, + .FileName = Java.PathJava, .Arguments = Arguments, .UseShellExecute = False, .CreateNoWindow = True, @@ -484,7 +426,7 @@ pause" Log(ex, "读取 OptiFine 安装器信息失败") End Try Try - If Task.State = LoadState.Aborted AndAlso Not process.HasExited Then + If Task.State = LoadState.Interrupted AndAlso Not process.HasExited Then Log("[Installer] 由于任务取消，已中止 OptiFine 安装") process.Kill() End If @@ -508,7 +450,7 @@ pause" Log(ex, "读取 OptiFine 安装器错误信息失败") End Try Try - If Task.State = LoadState.Aborted AndAlso Not process.HasExited Then + If Task.State = LoadState.Interrupted AndAlso Not process.HasExited Then Log("[Installer] 由于任务取消，已中止 OptiFine 安装") process.Kill() End If @@ -535,47 +477,42 @@ pause" ''' ''' 获取下载某个 OptiFine 版本的加载器列表。 + ''' 这不会补全所需的支持库文件，需要后续手动补全支持库。 ''' - Private Function McDownloadOptiFineLoader(DownloadInfo As DlOptiFineListEntry, Optional McFolder As String = Nothing, Optional ClientDownloadLoader As LoaderCombo(Of String) = Nothing, Optional ClientFolder As String = Nothing, Optional FixLibrary As Boolean = True) As List(Of LoaderBase) + Private Function McDownloadOptiFineLoader(DownloadInfo As DlOptiFineListEntry, McFolder As String, ClientDownloadLoader As LoaderCombo(Of String), ClientFolder As String) As List(Of LoaderBase) '参数初始化 - McFolder = If(McFolder, PathMcFolder) - Dim IsCustomFolder As Boolean = McFolder <> PathMcFolder - Dim Id As String = DownloadInfo.NameVersion + Dim IsCustomFolder As Boolean = McFolder <> McFolderSelected + Dim Id As String = DownloadInfo.InstanceName Dim VersionFolder As String = McFolder & "versions\" & Id & "\" - Dim IsNewVersion As Boolean = DownloadInfo.Inherit.Contains("w") OrElse Val(DownloadInfo.Inherit.Split(".")(1)) >= 14 - Dim Target As String = If(IsNewVersion, + Dim IsNewerVersion As Boolean = DownloadInfo.Inherit.Contains("w") OrElse McVersion.VersionToDrop(DownloadInfo.Inherit) >= 140 + Dim Target As String = If(IsNewerVersion, $"{RequestTaskTempFolder()}OptiFine.jar", - $"{McFolder}libraries\optifine\OptiFine\{DownloadInfo.NameFile.Replace("OptiFine_", "").Replace(".jar", "").Replace("preview_", "")}\{DownloadInfo.NameFile.Replace("OptiFine_", "OptiFine-").Replace("preview_", "")}") + $"{McFolder}libraries\optifine\OptiFine\{DownloadInfo.FileName.Replace("OptiFine_", "").Replace(".jar", "").Replace("preview_", "")}\{DownloadInfo.FileName.Replace("OptiFine_", "OptiFine-").Replace("preview_", "")}") Dim Loaders As New List(Of LoaderBase) '获取下载地址 Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("获取 OptiFine 主文件下载地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) - '启动依赖版本的下载 - If ClientDownloadLoader Is Nothing Then - If IsCustomFolder Then Throw New Exception("如果没有指定原版下载器，则不能指定 MC 安装文件夹") - ClientDownloadLoader = McDownloadClient(NetPreDownloadBehaviour.ExitWhileExistsOrDownloading, DownloadInfo.Inherit) - End If - Task.Progress = 0.1 Dim Sources As New List(Of String) 'BMCLAPI 源 Dim BmclapiInherit As String = DownloadInfo.Inherit If BmclapiInherit = "1.8" OrElse BmclapiInherit = "1.9" Then BmclapiInherit &= ".0" '#4281 If DownloadInfo.IsPreview Then - Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U_" & DownloadInfo.NameDisplay.Replace(DownloadInfo.Inherit & " ", "").Replace(" ", "/")) + Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U_" & DownloadInfo.DisplayName.Replace(DownloadInfo.Inherit & " ", "").Replace(" ", "/")) Else - Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U/" & DownloadInfo.NameDisplay.Replace(DownloadInfo.Inherit & " ", "")) + Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U/" & DownloadInfo.DisplayName.Replace(DownloadInfo.Inherit & " ", "")) End If '官方源 Dim PageData As String Try - PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True) + PageData = NetRequestByClientRetry("https://optifine.net/adloadx?f=" & DownloadInfo.FileName, + Encoding:=New UTF8Encoding(False), Accept:="text/html", SimulateBrowserHeaders:=True) Task.Progress = 0.8 Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) - Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址：" & Sources.Last) + Log("[Download] OptiFine " & DownloadInfo.DisplayName & " 官方下载地址：" & Sources.Last) Catch ex As Exception - Log(ex, "获取 OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址失败") + Log(ex, "获取 OptiFine " & DownloadInfo.DisplayName & " 官方下载地址失败") End Try '构造文件请求 Task.Output = New List(Of NetFile) From {New NetFile(Sources.ToArray, Target, New FileChecker(MinSize:=300 * 1024))} @@ -584,16 +521,15 @@ pause" Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)("等待原版下载", Sub(Task As LoaderTask(Of List(Of NetFile), Boolean)) '等待原版文件下载完成 - If ClientDownloadLoader Is Nothing Then Return Dim TargetLoaders As List(Of LoaderBase) = ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName). Where(Function(l) l.State <> LoadState.Finished).ToList If TargetLoaders.Any Then Log("[Download] OptiFine 安装正在等待原版文件下载完成") - Do While TargetLoaders.Any AndAlso Not Task.IsAborted + Do While TargetLoaders.Any AndAlso Not Task.IsInterrupted TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList Thread.Sleep(50) Loop - If Task.IsAborted Then Return + If Task.IsInterrupted Then Return '拷贝原版文件 If Not IsCustomFolder Then Return SyncLock VanillaSyncLock @@ -609,7 +545,7 @@ pause" End Sub) With {.ProgressWeight = 0.1, .Show = False}) '安装（新旧方式均需要原版 Jar 和 Json） - If IsNewVersion Then + If IsNewerVersion Then Log("[Download] 检测为新版 OptiFine：" & DownloadInfo.Inherit) Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)("安装 OptiFine（方式 A）", Sub(Task As LoaderTask(Of List(Of NetFile), Boolean)) @@ -666,24 +602,24 @@ Retry: CopyFile(McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".jar", VersionFolder & Id & ".jar") Task.Progress = 0.7 '建立 Json 文件 - Dim InheritVersion As New McVersion(McFolder & "versions\" & DownloadInfo.Inherit) + Dim InheritInstance As New McInstance(McFolder & "versions\" & DownloadInfo.Inherit) Dim Json As String = "{ ""id"": """ & Id & """, ""inheritsFrom"": """ & DownloadInfo.Inherit & """, - ""time"": """ & If(DownloadInfo.ReleaseTime = "", InheritVersion.ReleaseTime.ToString("yyyy'-'MM'-'dd"), DownloadInfo.ReleaseTime.Replace("/", "-")) & "T23:33:33+08:00"", - ""releaseTime"": """ & If(DownloadInfo.ReleaseTime = "", InheritVersion.ReleaseTime.ToString("yyyy'-'MM'-'dd"), DownloadInfo.ReleaseTime.Replace("/", "-")) & "T23:33:33+08:00"", + ""time"": """ & If(DownloadInfo.ReleaseTime = "", InheritInstance.ReleaseTime.ToString("yyyy'-'MM'-'dd"), DownloadInfo.ReleaseTime.Replace("/", "-")) & "T23:33:33+08:00"", + ""releaseTime"": """ & If(DownloadInfo.ReleaseTime = "", InheritInstance.ReleaseTime.ToString("yyyy'-'MM'-'dd"), DownloadInfo.ReleaseTime.Replace("/", "-")) & "T23:33:33+08:00"", ""type"": ""release"", ""libraries"": [ - {""name"": ""optifine:OptiFine:" & DownloadInfo.NameFile.Replace("OptiFine_", "").Replace(".jar", "").Replace("preview_", "") & """}, + {""name"": ""optifine:OptiFine:" & DownloadInfo.FileName.Replace("OptiFine_", "").Replace(".jar", "").Replace("preview_", "") & """}, {""name"": ""net.minecraft:launchwrapper:1.12""} ], ""mainClass"": ""net.minecraft.launchwrapper.Launch""," Task.Progress = 0.8 - If InheritVersion.IsOldJson Then + If InheritInstance.IsOldJson Then '输出旧版 Json 格式 Json += " ""minimumLauncherVersion"": 18, - ""minecraftArguments"": """ & InheritVersion.JsonObject("minecraftArguments").ToString & " --tweakClass optifine.OptiFineTweaker"" + ""minecraftArguments"": """ & InheritInstance.JsonObject("minecraftArguments").ToString & " --tweakClass optifine.OptiFineTweaker"" }" Else '输出新版 Json 格式 @@ -704,13 +640,6 @@ Retry: End Sub) With {.ProgressWeight = 1}) End If - '下载支持库 - If FixLibrary Then - Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 OptiFine 支持库文件", - Sub(Task) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) - Loaders.Add(New LoaderDownload("下载 OptiFine 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 4}) - End If - Return Loaders End Function ''' @@ -726,19 +655,20 @@ Retry: Dim BmclapiInherit As String = DownloadInfo.Inherit If BmclapiInherit = "1.8" OrElse BmclapiInherit = "1.9" Then BmclapiInherit &= ".0" '#4281 If DownloadInfo.IsPreview Then - Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U_" & DownloadInfo.NameDisplay.Replace(DownloadInfo.Inherit & " ", "").Replace(" ", "/")) + Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U_" & DownloadInfo.DisplayName.Replace(DownloadInfo.Inherit & " ", "").Replace(" ", "/")) Else - Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U/" & DownloadInfo.NameDisplay.Replace(DownloadInfo.Inherit & " ", "")) + Sources.Add("https://bmclapi2.bangbang93.com/optifine/" & BmclapiInherit & "/HD_U/" & DownloadInfo.DisplayName.Replace(DownloadInfo.Inherit & " ", "")) End If '官方源 Dim PageData As String Try - PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True) + PageData = NetRequestByClientRetry("https://optifine.net/adloadx?f=" & DownloadInfo.FileName, + Encoding:=New UTF8Encoding(False), Accept:="text/html", SimulateBrowserHeaders:=True) Task.Progress = 0.8 Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) - Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址：" & Sources.Last) + Log("[Download] OptiFine " & DownloadInfo.DisplayName & " 官方下载地址：" & Sources.Last) Catch ex As Exception - Log(ex, "获取 OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址失败") + Log(ex, "获取 OptiFine " & DownloadInfo.DisplayName & " 官方下载地址失败") End Try Task.Progress = 0.9 '构造文件请求 @@ -753,24 +683,26 @@ Retry: #Region "OptiFine 下载菜单" - Public Function OptiFineDownloadListItem(Entry As DlOptiFineListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry.NameDisplay, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = If(Entry.IsPreview, "测试版", "正式版") & - If(Entry.ReleaseTime = "", "", "，发布于 " & Entry.ReleaseTime) & - If(Entry.RequiredForgeVersion Is Nothing, "，不兼容 Forge", If(Entry.RequiredForgeVersion = "", "", "，兼容 Forge " & Entry.RequiredForgeVersion)), - .Logo = PathImage & "Blocks/GrassPath.png" - } - AddHandler NewItem.Click, OnClick - '建立菜单 - If IsSaveOnly Then - NewItem.ContentHandler = AddressOf OptiFineSaveContMenuBuild - Else - NewItem.ContentHandler = AddressOf OptiFineContMenuBuild - End If - '结束 - Return NewItem + Public Function OptiFineDownloadListItem(Entry As DlOptiFineListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '建立控件 + Dim NewItem As New MyListItem With { + .Title = Entry.DisplayName, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = If(Entry.IsPreview, "测试版", "正式版") & + If(Entry.ReleaseTime = "", "", "，发布于 " & Entry.ReleaseTime) & + If(Entry.RequiredForgeVersion Is Nothing, "，不兼容 Forge", If(Entry.RequiredForgeVersion = "", "", "，兼容 Forge " & Entry.RequiredForgeVersion)), + .Logo = PathImage & "Blocks/GrassPath.png" + } + AddHandler NewItem.Click, OnClick + '建立菜单 + If IsSaveOnly Then + NewItem.ContentHandler = AddressOf OptiFineSaveContMenuBuild + Else + NewItem.ContentHandler = AddressOf OptiFineContMenuBuild + End If + Return NewItem + End Function) With {.Height = 42} End Function Private Sub OptiFineSaveContMenuBuild(sender As Object, e As EventArgs) Dim BtnInfo As New MyIconButton With {.LogoScale = 1.05, .Logo = Logo.IconButtonInfo, .ToolTip = "更新日志"} @@ -802,7 +734,7 @@ Retry: Else Version = sender.Parent.Parent.Tag End If - OpenWebsite("https://optifine.net/changelog?f=" & Version.NameFile) + OpenWebsite("https://optifine.net/changelog?f=" & Version.FileName) End Sub Public Sub OptiFineSave_Click(sender As Object, e As RoutedEventArgs) Dim Version As DlOptiFineListEntry @@ -820,41 +752,6 @@ Retry: #Region "LiteLoader 下载" - Public Sub McDownloadLiteLoader(DownloadInfo As DlLiteLoaderListEntry) - Try - Dim Id As String = DownloadInfo.Inherit - Dim Target As String = PathTemp & "Download\" & Id & "-Liteloader.jar" - Dim VersionName As String = DownloadInfo.Inherit & "-LiteLoader" - Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\" - - '重复任务检查 - For Each OngoingLoader In LoaderTaskbar.ToList() - If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) - Return - Next - - '已有版本检查 - If File.Exists(VersionFolder & VersionName & ".json") Then - If MyMsgBox("版本 " & VersionName & " 已存在，是否重新下载？" & vbCrLf & "这会覆盖版本的 json 和 jar 文件，但不会影响版本隔离的文件。", "版本已存在", "继续", "取消") = 1 Then - File.Delete(VersionFolder & VersionName & ".jar") - File.Delete(VersionFolder & VersionName & ".json") - Else - Return - End If - End If - - '启动 - Dim Loader As New LoaderCombo(Of String)("LiteLoader " & Id & " 下载", McDownloadLiteLoaderLoader(DownloadInfo)) With {.OnStateChanged = AddressOf McInstallState} - Loader.Start(VersionFolder) - LoaderTaskbarAdd(Loader) - FrmMain.BtnExtraDownload.ShowRefresh() - FrmMain.BtnExtraDownload.Ribble() - - Catch ex As Exception - Log(ex, "开始 LiteLoader 下载失败", LogLevel.Feedback) - End Try - End Sub Private Sub McDownloadLiteLoaderSave(DownloadInfo As DlLiteLoaderListEntry) Try Dim Id As String = DownloadInfo.Inherit @@ -864,7 +761,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -907,26 +804,18 @@ Retry: ''' ''' 获取下载某个 LiteLoader 版本的加载器列表。 + ''' 这不会补全所需的支持库文件，需要后续手动补全支持库。 ''' - Private Function McDownloadLiteLoaderLoader(DownloadInfo As DlLiteLoaderListEntry, Optional McFolder As String = Nothing, Optional ClientDownloadLoader As LoaderCombo(Of String) = Nothing, Optional FixLibrary As Boolean = True) As List(Of LoaderBase) + Private Function McDownloadLiteLoaderLoader(DownloadInfo As DlLiteLoaderListEntry, McFolder As String) As List(Of LoaderBase) '参数初始化 - McFolder = If(McFolder, PathMcFolder) - Dim IsCustomFolder As Boolean = McFolder <> PathMcFolder + Dim IsCustomFolder As Boolean = McFolder <> McFolderSelected Dim Id As String = DownloadInfo.Inherit Dim Target As String = PathTemp & "Download\" & Id & "-Liteloader.jar" Dim VersionName As String = DownloadInfo.Inherit & "-LiteLoader" Dim VersionFolder As String = McFolder & "versions\" & VersionName & "\" Dim Loaders As New List(Of LoaderBase) - '启动依赖版本的下载 - If ClientDownloadLoader Is Nothing Then - Loaders.Add(New LoaderTask(Of String, String)("启动 LiteLoader 依赖版本下载", - Sub() - If IsCustomFolder Then Throw New Exception("如果没有指定原版下载器，则不能指定 MC 安装文件夹") - ClientDownloadLoader = McDownloadClient(NetPreDownloadBehaviour.ExitWhileExistsOrDownloading, DownloadInfo.Inherit) - End Sub) With {.ProgressWeight = 0.2, .Show = False, .Block = False}) - End If '安装 Loaders.Add(New LoaderTask(Of String, String)("安装 LiteLoader", Sub(Task As LoaderTask(Of String, String)) @@ -936,8 +825,8 @@ Retry: '构造版本 Json Dim VersionJson As New JObject VersionJson.Add("id", VersionName) - VersionJson.Add("time", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.CurrentCulture)) - VersionJson.Add("releaseTime", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.CurrentCulture)) + VersionJson.Add("time", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.InvariantCulture)) + VersionJson.Add("releaseTime", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.InvariantCulture)) VersionJson.Add("type", "release") VersionJson.Add("arguments", GetJson("{""game"":[""--tweakClass"",""" & DownloadInfo.JsonToken("tweakClass").ToString & """]}")) VersionJson.Add("libraries", DownloadInfo.JsonToken("libraries")) @@ -952,12 +841,6 @@ Retry: Throw New Exception("安装新 LiteLoader 版本失败", ex) End Try End Sub) With {.ProgressWeight = 1}) - '下载支持库 - If FixLibrary Then - Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 LiteLoader 支持库文件", - Sub(Task) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) - Loaders.Add(New LoaderDownload("下载 LiteLoader 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 6}) - End If Return Loaders End Function @@ -966,22 +849,25 @@ Retry: #Region "LiteLoader 下载菜单" - Public Function LiteLoaderDownloadListItem(Entry As DlLiteLoaderListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry.Inherit, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = If(Entry.IsPreview, "测试版", "稳定版") & If(Entry.ReleaseTime = "", "", "，发布于 " & Entry.ReleaseTime), - .Logo = PathImage & "Blocks/Egg.png" - } - AddHandler NewItem.Click, OnClick - '建立菜单 - If IsSaveOnly Then - NewItem.ContentHandler = AddressOf LiteLoaderSaveContMenuBuild - Else - NewItem.ContentHandler = AddressOf LiteLoaderContMenuBuild - End If - '结束 - Return NewItem + Public Function LiteLoaderDownloadListItem(Entry As DlLiteLoaderListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '建立控件 + Dim NewItem As New MyListItem With { + .Title = Entry.Inherit, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = If(Entry.IsPreview, "测试版", "稳定版") & If(Entry.ReleaseTime = "", "", "，发布于 " & Entry.ReleaseTime), + .Logo = PathImage & "Blocks/Egg.png" + } + AddHandler NewItem.Click, OnClick + '建立菜单 + If IsSaveOnly Then + NewItem.ContentHandler = AddressOf LiteLoaderSaveContMenuBuild + Else + NewItem.ContentHandler = AddressOf LiteLoaderContMenuBuild + End If + '结束 + Return NewItem + End Function) With {.Height = 42} End Function Private Sub LiteLoaderSaveContMenuBuild(sender As MyListItem, e As EventArgs) If sender.Tag.IsLegacy Then @@ -1046,7 +932,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"{DisplayName} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -1054,8 +940,8 @@ Retry: Dim Files As New List(Of NetFile) If Info.IsNeoForge Then 'NeoForge - Dim Neo As DlNeoForgeListEntry = Info - Dim Url As String = Neo.UrlBase & "-installer.jar" + Dim NeoForge As DlNeoForgeListEntry = Info + Dim Url As String = NeoForge.UrlBase & "-installer.jar" Files.Add(New NetFile({ Url.Replace("maven.neoforged.net/releases", "bmclapi2.bangbang93.com/maven"), Url }, Target, New FileChecker(MinSize:=64 * 1024))) @@ -1090,35 +976,34 @@ Retry: SyncLock JavaLock Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60)) If Java Is Nothing Then - If Not JavaDownloadConfirm("Java 8 或更高版本") Then Throw New Exception("由于未找到 Java，已取消安装。") '开始自动下载 - Dim JavaLoader = JavaFixLoaders(17) + Dim JavaLoader = GetJavaDownloadLoader() Try JavaLoader.Start(17, IsForceRestart:=True) - Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsAborted + Do While JavaLoader.State = LoadState.Loading AndAlso Not Task.IsInterrupted Thread.Sleep(10) Loop Finally - JavaLoader.Abort() '确保取消时中止 Java 下载 + JavaLoader.Interrupt() '确保取消时中止 Java 下载 End Try '检查下载结果 Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60)) - If Task.IsAborted Then Return + If Task.IsInterrupted Then Return If Java Is Nothing Then Throw New Exception("由于未找到 Java，已取消安装。") End If End SyncLock '添加 Java Wrapper 作为主 Jar Dim Arguments As String - If UseJavaWrapper AndAlso Not Setup.Get("LaunchAdvanceDisableJLW") Then - Arguments = $"-Doolloo.jlw.tmpdir=""{PathPure.TrimEnd("\")}"" -cp ""{PathTemp}Cache\forge_installer.jar;{Target}"" -jar ""{ExtractJavaWrapper()}"" com.bangbang93.ForgeInstaller ""{McFolder}" + If UseJavaWrapper AndAlso Not Settings.Get("LaunchAdvanceDisableJLW") Then + Arguments = $"-Doolloo.jlw.tmpdir=""{PathPure.TrimEnd("\")}"" -cp ""{PathTemp}Cache\forge_installer.jar;{Target}"" -jar ""{ExtractPatch("JavaWrapper")}"" com.bangbang93.ForgeInstaller ""{McFolder}" Else Arguments = $"-cp ""{PathTemp}Cache\forge_installer.jar;{Target}"" com.bangbang93.ForgeInstaller ""{McFolder}" End If - If Java.VersionCode >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments + If Java.MajorVersion >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments '开始启动 SyncLock InstallSyncLock Dim Info = New ProcessStartInfo With { - .FileName = Java.PathJavaw, + .FileName = Java.PathJava, .Arguments = Arguments, .UseShellExecute = False, .CreateNoWindow = True, @@ -1146,7 +1031,7 @@ Retry: Log(ex, $"读取 {LoaderName} 安装器信息失败") End Try Try - If Task.State = LoadState.Aborted AndAlso Not process.HasExited Then + If Task.State = LoadState.Interrupted AndAlso Not process.HasExited Then Log($"[Installer] 由于任务取消，已中止 {LoaderName} 安装") process.Kill() End If @@ -1169,7 +1054,7 @@ Retry: Log(ex, $"读取 {LoaderName} 安装器错误信息失败") End Try Try - If Task.State = LoadState.Aborted AndAlso Not process.HasExited Then + If Task.State = LoadState.Interrupted AndAlso Not process.HasExited Then Log($"[Installer] 由于任务取消，已中止 {LoaderName} 安装") process.Kill() End If @@ -1190,7 +1075,7 @@ Retry: process.Dispose() '检查是否安装成功：最后 5 行中是否有 true（true 可能在倒数数行，见 #832） If LastResults.Reverse().Take(5).Any(Function(l) l = "true") Then Return - Log(Join(LastResults, vbCrLf)) + Log(LastResults.Join(vbCrLf)) Dim LastLines As String = "" For i As Integer = Math.Max(0, LastResults.Count - 5) To LastResults.Count - 1 '最后 5 行 LastLines &= vbCrLf & LastResults(i) @@ -1245,10 +1130,10 @@ Retry: ''' ''' 获取下载某个 Forgelike 版本的加载器列表。 ''' - Private Function McDownloadForgelikeLoader(IsNeoForge As Boolean, LoaderVersion As String, TargetVersion As String, Inherit As String, Optional Info As DlForgelikeEntry = Nothing, Optional McFolder As String = Nothing, Optional ClientDownloadLoader As LoaderCombo(Of String) = Nothing, Optional ClientFolder As String = Nothing) As List(Of LoaderBase) + Private Function McDownloadForgelikeLoader(IsNeoForge As Boolean, LoaderVersion As String, NewInstanceName As String, Inherit As String, Info As DlForgelikeEntry, McFolder As String, ClientDownloadLoader As LoaderCombo(Of String), ClientFolder As String) As List(Of LoaderBase) '参数初始化 - McFolder = If(McFolder, PathMcFolder) + McFolder = If(McFolder, McFolderSelected) If IsNeoForge AndAlso Info Is Nothing Then '需要传入 API Name，但整合包版本可能不以 1.20.1- 开头，所以需要进行特别处理 If Inherit = "1.20.1" AndAlso Not LoaderVersion.StartsWithF("1.20.1-") Then @@ -1263,12 +1148,12 @@ Retry: LoaderVersion = LoaderVersion.AfterLast("-") End If Dim LoaderName As String = If(IsNeoForge, "NeoForge", "Forge") - Dim IsCustomFolder As Boolean = McFolder <> PathMcFolder + Dim IsCustomFolder As Boolean = McFolder <> McFolderSelected Dim InstallerAddress As String = RequestTaskTempFolder() & "forge_installer.jar" - Dim VersionFolder As String = $"{McFolder}versions\{TargetVersion}\" + Dim VersionFolder As String = $"{McFolder}versions\{NewInstanceName}\" Dim DisplayName As String = $"{LoaderName} {Inherit} - {LoaderVersion}" Dim Loaders As New List(Of LoaderBase) - Dim LibVersionFolder As String = $"{PathMcFolder}versions\{TargetVersion}\" '作为 Lib 文件目标的版本文件夹 + Dim LibVersionFolder As String = $"{McFolderSelected}versions\{NewInstanceName}\" '作为 Lib 文件目标的版本文件夹 '获取 Forge 下载信息 If Info Is Nothing Then @@ -1280,7 +1165,7 @@ Retry: Task.Progress = 0.8 '查找对应版本 For Each ForgeVersion In ForgeLoader.Output - If VersionSortInteger(ForgeVersion.Version.ToString, LoaderVersion) = 0 Then + If CompareVersion(ForgeVersion.Version.ToString, LoaderVersion) = 0 Then Info = ForgeVersion Return End If @@ -1291,11 +1176,6 @@ Retry: '下载 Forgelike 主文件 Loaders.Add(New LoaderTask(Of String, List(Of NetFile))($"准备下载 {LoaderName}", Sub(Task As LoaderTask(Of String, List(Of NetFile))) - '启动依赖版本的下载 - If ClientDownloadLoader Is Nothing Then - If IsCustomFolder Then Throw New Exception("如果没有指定原版下载器，则不能指定 MC 安装文件夹") - ClientDownloadLoader = McDownloadClient(NetPreDownloadBehaviour.ExitWhileExistsOrDownloading, Inherit) - End If '添加主文件下载 Dim Files As New List(Of NetFile) If Info.IsNeoForge Then @@ -1329,7 +1209,7 @@ Retry: Dim Installer As ZipArchive = Nothing Try '解压并获取、合并两个 Json 的信息 - Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open)) + Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open, FileAccess.Read, FileShare.Read)) Task.Progress = 0.2 Dim Json As JObject = GetJson(ReadFile(Installer.GetEntry("install_profile.json").Open)) Dim Json2 As JObject = GetJson(ReadFile(Installer.GetEntry("version.json").Open)) @@ -1340,10 +1220,10 @@ Retry: If Json("data") IsNot Nothing AndAlso Json("data")("MOJMAPS") IsNot Nothing Then '下载原版 Json 文件 Task.Progress = 0.4 - Dim RawJson As JObject = GetJson(NetGetCodeByLoader(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True)) + Dim RawJson As JObject = GetJson(NetRequestByLoader(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True)) '[net.minecraft:client:1.17.1-20210706.113038:mappings@txt] 或 @tsrg] Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).BeforeFirst("@") - Dim Address = McLibGet(OriginalName).Replace(".jar", "-mappings." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1)) + Dim Address = McLibGet(OriginalName).Replace(".jar", "." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1)) Dim ClientMappings As JToken = RawJson("downloads")("client_mappings") Libs.Add(New McLibToken With { .IsNatives = False, .LocalPath = Address, .OriginalName = OriginalName, @@ -1353,28 +1233,28 @@ Retry: Task.Progress = 0.8 '去除其中的原始 Forgelike 项 For i = 0 To Libs.Count - 1 - If Libs(i).LocalPath.EndsWithF($"{LoaderName.ToLower}-{Inherit}-{LoaderVersion}.jar") OrElse - Libs(i).LocalPath.EndsWithF($"{LoaderName.ToLower}-{Inherit}-{LoaderVersion}-client.jar") Then + If Libs(i).LocalPath.EndsWithF($"{LoaderName.Lower}-{Inherit}-{LoaderVersion}.jar") OrElse + Libs(i).LocalPath.EndsWithF($"{LoaderName.Lower}-{Inherit}-{LoaderVersion}-client.jar") Then Log($"[Download] 已从待下载 {LoaderName} 支持库中移除：" & Libs(i).LocalPath, LogLevel.Debug) Libs.RemoveAt(i) Exit For End If Next - Task.Output = McLibFixFromLibToken(Libs, PathMcFolder) + Task.Output = McLibNetFilesFromTokens(Libs, McFolderSelected) Catch ex As Exception Throw New Exception($"获取{If(IsNeoForge, " Neo", "新版 ")}Forge 支持库列表失败", ex) Finally '释放文件 If Installer IsNot Nothing Then Installer.Dispose() End Try - End Sub) With {.ProgressWeight = 2}) + End Sub) With {.ProgressWeight = 1}) Loaders.Add(New LoaderDownload($"下载 {LoaderName} 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 12}) Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)($"获取 {LoaderName} 支持库文件", Sub(Task As LoaderTask(Of List(Of NetFile), Boolean)) #Region "Forgelike 文件" If IsCustomFolder Then For Each LibFile As McLibToken In Libs - Dim RealPath As String = LibFile.LocalPath.Replace(PathMcFolder, McFolder) + Dim RealPath As String = LibFile.LocalPath.Replace(McFolderSelected, McFolder) If Not File.Exists(RealPath) Then Directory.CreateDirectory(IO.Path.GetDirectoryName(RealPath)) CopyFile(LibFile.LocalPath, RealPath) @@ -1385,16 +1265,15 @@ Retry: #End Region #Region "原版文件" '等待原版文件下载完成 - If ClientDownloadLoader Is Nothing Then Return Dim TargetLoaders As List(Of LoaderBase) = ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName). Where(Function(l) l.State <> LoadState.Finished).ToList() If TargetLoaders.Any Then Log($"[Download] {LoaderName} 安装正在等待原版文件下载完成") - Do While TargetLoaders.Any AndAlso Not Task.IsAborted + Do While TargetLoaders.Any AndAlso Not Task.IsInterrupted TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList Thread.Sleep(50) Loop - If Task.IsAborted Then Return + If Task.IsInterrupted Then Return '拷贝原版文件 If Not IsCustomFolder Then Return SyncLock VanillaSyncLock @@ -1417,7 +1296,7 @@ Retry: '记录当前文件夹列表（在新建目标文件夹之前） Dim OldList = New DirectoryInfo(McFolder & "versions\").EnumerateDirectories.Select(Function(i) i.FullName).ToList() '解压并获取信息 - Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open)) + Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open, FileAccess.Read, FileShare.Read)) Dim Json As JObject = GetJson(ReadFile(Installer.GetEntry("install_profile.json").Open)) '新建目标版本文件夹 Directory.CreateDirectory(VersionFolder) @@ -1456,8 +1335,8 @@ Retry: '如果没有新增文件夹，那么预测的文件夹名就是正确的 '如果只新增 1 个文件夹，那么拷贝 json 文件 Dim JsonFile As FileInfo = DeltaList(0).EnumerateFiles.First() - WriteFile(VersionFolder & TargetVersion & ".json", ReadFile(JsonFile.FullName)) - Log($"[Download] 已拷贝新增的版本 JSON 文件：{JsonFile.FullName} -> {VersionFolder}{TargetVersion}.json") + WriteFile(VersionFolder & NewInstanceName & ".json", ReadFile(JsonFile.FullName)) + Log($"[Download] 已拷贝新增的版本 JSON 文件：{JsonFile.FullName} -> {VersionFolder}{NewInstanceName}.json") ElseIf DeltaList.Count > 1 Then '新增了多个文件夹 Log($"[Download] 有多个疑似的新增版本，无法确定：{DeltaList.Select(Function(d) d.Name).Join(";")}") @@ -1484,7 +1363,7 @@ Retry: Dim Installer As ZipArchive = Nothing Try '解压并获取信息 - Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open)) + Installer = New ZipArchive(New FileStream(InstallerAddress, FileMode.Open, FileAccess.Read, FileShare.Read)) Task.Progress = 0.2 Dim Json As JObject = GetJson(ReadFile(Installer.GetEntry("install_profile.json").Open)) Task.Progress = 0.4 @@ -1496,12 +1375,12 @@ Retry: Log("[Download] 开始进行 Forge 安装，Legacy 方式 1：" & InstallerAddress) '建立 Json 文件 Dim JsonVersion As JObject = GetJson(ReadFile(Installer.GetEntry(Json("json").ToString.TrimStart("/")).Open)) - JsonVersion("id") = TargetVersion - WriteFile(VersionFolder & TargetVersion & ".json", JsonVersion.ToString) + JsonVersion("id") = NewInstanceName + WriteFile(VersionFolder & NewInstanceName & ".json", JsonVersion.ToString) Task.Progress = 0.6 '解压支持库文件 Installer.Dispose() - ExtractFile(InstallerAddress, InstallerAddress & "_unrar\") + ExtractCompressedFile(InstallerAddress, InstallerAddress & "_unrar\") CopyDirectory(InstallerAddress & "_unrar\maven\", McFolder & "libraries\") DeleteDirectory(InstallerAddress & "_unrar\") Else @@ -1513,9 +1392,9 @@ Retry: WriteFile(JarAddress, Installer.GetEntry(Json("install")("filePath")).Open) Task.Progress = 0.9 '建立 Json 文件 - Json("versionInfo")("id") = TargetVersion + Json("versionInfo")("id") = NewInstanceName If Json("versionInfo")("inheritsFrom") Is Nothing Then CType(Json("versionInfo"), JObject).Add("inheritsFrom", Inherit) - WriteFile(VersionFolder & TargetVersion & ".json", Json("versionInfo").ToString) + WriteFile(VersionFolder & NewInstanceName & ".json", Json("versionInfo").ToString) End If Catch ex As Exception Throw New Exception("非新版方式安装 Forge 失败", ex) @@ -1541,13 +1420,13 @@ Retry: Public Sub ForgeDownloadListItemPreload(Stack As StackPanel, Entries As List(Of DlForgeVersionEntry), OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) '如果只有一个版本，则不特别列出 - If Entries.Count = 1 Then Return + If Entries.IsSingle Then Return '获取推荐版本与最新版本 Dim FreshVersion As DlForgeVersionEntry = Nothing If Entries.Any Then FreshVersion = Entries(0) Else - Log("[System] 未找到可用的 Forge 版本", LogLevel.Debug) + Log("[System] 未找到可用的 Forge 版本") End If Dim RecommendedVersion As DlForgeVersionEntry = Nothing For Each Entry In Entries @@ -1557,35 +1436,38 @@ Retry: If FreshVersion IsNot Nothing AndAlso FreshVersion Is RecommendedVersion Then FreshVersion = Nothing '显示各个版本 If RecommendedVersion IsNot Nothing Then - Dim Recommended = ForgeDownloadListItem(RecommendedVersion, OnClick, IsSaveOnly) + Dim Recommended = ForgeDownloadListItem(RecommendedVersion, OnClick, IsSaveOnly).Init() Recommended.Info = "推荐版" & If(Recommended.Info = "", "", "，" & Recommended.Info) Stack.Children.Add(Recommended) End If If FreshVersion IsNot Nothing Then - Dim Fresh = ForgeDownloadListItem(FreshVersion, OnClick, IsSaveOnly) + Dim Fresh = ForgeDownloadListItem(FreshVersion, OnClick, IsSaveOnly).Init() Fresh.Info = "最新版" & If(Fresh.Info = "", "", "，" & Fresh.Info) Stack.Children.Add(Fresh) End If '添加间隔 Stack.Children.Add(New TextBlock With {.Text = "全部版本 (" & Entries.Count & ")", .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 13, 0, 4)}) End Sub - Public Function ForgeDownloadListItem(Entry As DlForgeVersionEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry.VersionName, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = {If(Entry.ReleaseTime = "", "", "发布于 " & Entry.ReleaseTime), If(ModeDebug, "种类：" & Entry.Category, "")}. - Where(Function(d) d <> "").Join("，"), - .Logo = PathImage & "Blocks/Anvil.png" - } - AddHandler NewItem.Click, OnClick - '建立菜单 - If IsSaveOnly Then - NewItem.ContentHandler = AddressOf ForgeSaveContMenuBuild - Else - NewItem.ContentHandler = AddressOf ForgeContMenuBuild - End If - '结束 - Return NewItem + Public Function ForgeDownloadListItem(Entry As DlForgeVersionEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '建立控件 + Dim NewItem As New MyListItem With { + .Title = Entry.VersionName, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = {If(Entry.ReleaseTime = "", "", "发布于 " & Entry.ReleaseTime), If(ModeDebug, "种类：" & Entry.Category, "")}. + Where(Function(d) d <> "").Join("，"), + .Logo = PathImage & "Blocks/Anvil.png" + } + AddHandler NewItem.Click, OnClick + '建立菜单 + If IsSaveOnly Then + NewItem.ContentHandler = AddressOf ForgeSaveContMenuBuild + Else + NewItem.ContentHandler = AddressOf ForgeContMenuBuild + End If + '结束 + Return NewItem + End Function) With {.Height = 42} End Function Private Sub ForgeContMenuBuild(sender As MyListItem, e As EventArgs) Dim BtnSave As New MyIconButton With {.Logo = Logo.IconButtonSave, .ToolTip = "另存为"} @@ -1641,30 +1523,31 @@ Retry: Public Sub McDownloadForgeRecommendedRefresh() If IsForgeRecommendedRefreshed Then Return IsForgeRecommendedRefreshed = True - RunInNewThread(Sub() - Try - Log("[Download] 刷新 Forge 推荐版本缓存开始") - Dim Result As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/forge/promos") - If Result.Length < 1000 Then Throw New Exception("获取的结果过短（" & Result & "）") - Dim ResultJson As JContainer = GetJson(Result) - '获取所有推荐版本列表 - Dim RecommendedList As New List(Of String) - For Each Version As JObject In ResultJson - If Version("name") Is Nothing OrElse Version("build") Is Nothing Then Continue For - Dim Name As String = Version("name") - If Not Name.EndsWithF("-recommended") Then Continue For - '内容为："1.15.2":"31.2.0" - RecommendedList.Add("""" & Name.Replace("-recommended", """:""" & Version("build")("version").ToString & """")) - Next - If RecommendedList.Count < 5 Then Throw New Exception("获取的推荐版本数过少（" & Result & "）") - '保存 - Dim CacheJson As String = "{" & Join(RecommendedList, ",") & "}" - WriteFile(PathTemp & "Cache\ForgeRecommendedList.json", CacheJson) - Log("[Download] 刷新 Forge 推荐版本缓存成功") - Catch ex As Exception - Log(ex, "刷新 Forge 推荐版本缓存失败") - End Try - End Sub, "ForgeRecommendedRefresh") + RunInNewThread( + Sub() + Try + Log("[Download] 刷新 Forge 推荐版本缓存开始") + Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/promos", RequireJson:=True) + If Result.Length < 1000 Then Throw New Exception("获取的结果过短（" & Result & "）") + Dim ResultJson As JContainer = GetJson(Result) + '获取所有推荐版本列表 + Dim RecommendedList As New List(Of String) + For Each Version As JObject In ResultJson + If Version("name") Is Nothing OrElse Version("build") Is Nothing Then Continue For + Dim Name As String = Version("name") + If Not Name.EndsWithF("-recommended") Then Continue For + '内容为："1.15.2":"31.2.0" + RecommendedList.Add("""" & Name.Replace("-recommended", """:""" & Version("build")("version").ToString & """")) + Next + If RecommendedList.Count < 5 Then Throw New Exception("获取的推荐版本数过少（" & Result & "）") + '保存 + Dim CacheJson As String = "{" & RecommendedList.Join(",") & "}" + WriteFile(PathTemp & "Cache\ForgeRecommendedList.json", CacheJson) + Log("[Download] 刷新 Forge 推荐版本缓存成功") + Catch ex As Exception + Log(ex, "刷新 Forge 推荐版本缓存失败") + End Try + End Sub, "ForgeRecommendedRefresh") End Sub Private IsForgeRecommendedRefreshed As Boolean = False @@ -1680,7 +1563,7 @@ Retry: Return Nothing End If Dim Json As JObject = GetJson(List) - If Json Is Nothing OrElse (Not If(McVersion, "null").Contains(".")) OrElse Not Json.ContainsKey(McVersion) Then Return Nothing + If Json Is Nothing OrElse (Not If(McVersion, "").Contains(".")) OrElse Not Json.ContainsKey(McVersion) Then Return Nothing Return If(Json(McVersion), "").ToString Catch ex As Exception Log(ex, "获取 Forge 推荐版本失败（" & If(McVersion, "null") & "）", LogLevel.Feedback) @@ -1694,7 +1577,7 @@ Retry: Public Sub NeoForgeDownloadListItemPreload(Stack As StackPanel, Entries As List(Of DlNeoForgeListEntry), OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) '如果只有一个版本，则不特别列出 - If Entries.Count = 1 Then Return + If Entries.IsSingle Then Return '获取最新稳定版和测试版 Dim FreshStableVersion As DlNeoForgeListEntry = Nothing Dim FreshBetaVersion As DlNeoForgeListEntry = Nothing @@ -1712,34 +1595,37 @@ Retry: End If '显示各个版本 If FreshStableVersion IsNot Nothing Then - Dim Fresh = NeoForgeDownloadListItem(FreshStableVersion, OnClick, IsSaveOnly) + Dim Fresh = NeoForgeDownloadListItem(FreshStableVersion, OnClick, IsSaveOnly).Init() Fresh.Info = If(Fresh.Info = "", "最新稳定版", "最新" & Fresh.Info) Stack.Children.Add(Fresh) End If If FreshBetaVersion IsNot Nothing Then - Dim Fresh = NeoForgeDownloadListItem(FreshBetaVersion, OnClick, IsSaveOnly) + Dim Fresh = NeoForgeDownloadListItem(FreshBetaVersion, OnClick, IsSaveOnly).Init() Fresh.Info = If(Fresh.Info = "", "最新测试版", "最新" & Fresh.Info) Stack.Children.Add(Fresh) End If '添加间隔 Stack.Children.Add(New TextBlock With {.Text = "全部版本 (" & Entries.Count & ")", .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 13, 0, 4)}) End Sub - Public Function NeoForgeDownloadListItem(Info As DlNeoForgeListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Info.VersionName, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Info, - .Info = If(Info.IsBeta, "测试版", "稳定版"), - .Logo = PathImage & "Blocks/NeoForge.png" - } - AddHandler NewItem.Click, OnClick - '建立菜单 - If IsSaveOnly Then - NewItem.ContentHandler = AddressOf NeoForgeSaveContMenuBuild - Else - NewItem.ContentHandler = AddressOf NeoForgeContMenuBuild - End If - '结束 - Return NewItem + Public Function NeoForgeDownloadListItem(Info As DlNeoForgeListEntry, OnClick As MyListItem.ClickEventHandler, IsSaveOnly As Boolean) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + '建立控件 + Dim NewItem As New MyListItem With { + .Title = Info.VersionName, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Info, + .Info = If(Info.IsBeta, "测试版", "稳定版"), + .Logo = PathImage & "Blocks/NeoForge.png" + } + AddHandler NewItem.Click, OnClick + '建立菜单 + If IsSaveOnly Then + NewItem.ContentHandler = AddressOf NeoForgeSaveContMenuBuild + Else + NewItem.ContentHandler = AddressOf NeoForgeContMenuBuild + End If + Return NewItem + End Function + ) With {.Height = 42} End Function Private Sub NeoForgeContMenuBuild(sender As MyListItem, e As EventArgs) Dim BtnSave As New MyIconButton With {.Logo = Logo.IconButtonSave, .ToolTip = "另存为"} @@ -1800,7 +1686,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Fabric {Version} 安装器下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -1825,12 +1711,12 @@ Retry: ''' ''' 获取下载某个 Fabric 版本的加载器列表。 + ''' 这不会补全所需的支持库文件，需要后续手动补全支持库。 ''' - Private Function McDownloadFabricLoader(FabricVersion As String, MinecraftName As String, Optional McFolder As String = Nothing, Optional FixLibrary As Boolean = True) As List(Of LoaderBase) + Private Function McDownloadFabricLoader(FabricVersion As String, MinecraftName As String, McFolder As String) As List(Of LoaderBase) '参数初始化 - McFolder = If(McFolder, PathMcFolder) - Dim IsCustomFolder As Boolean = McFolder <> PathMcFolder + Dim IsCustomFolder As Boolean = McFolder <> McFolderSelected Dim Id As String = "fabric-loader-" & FabricVersion & "-" & MinecraftName Dim VersionFolder As String = McFolder & "versions\" & Id & "\" Dim Loaders As New List(Of LoaderBase) @@ -1839,26 +1725,13 @@ Retry: MinecraftName = MinecraftName.Replace("∞", "infinite") '放在 ID 后面避免影响版本文件夹名称 Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("获取 Fabric 主文件下载地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) - '启动依赖版本的下载 - If FixLibrary Then - McDownloadClient(NetPreDownloadBehaviour.ExitWhileExistsOrDownloading, MinecraftName) - End If - Task.Progress = 0.5 - '构造文件请求 Task.Output = New List(Of NetFile) From {New NetFile({ "https://bmclapi2.bangbang93.com/fabric-meta/v2/versions/loader/" & MinecraftName & "/" & FabricVersion & "/profile/json", "https://meta.fabricmc.net/v2/versions/loader/" & MinecraftName & "/" & FabricVersion & "/profile/json" - }, VersionFolder & Id & ".json", New FileChecker(IsJson:=True))} + }, VersionFolder & Id & ".json", New FileChecker(IsJson:=True))} '构造文件请求 End Sub) With {.ProgressWeight = 0.5}) Loaders.Add(New LoaderDownload("下载 Fabric 主文件", New List(Of NetFile)) With {.ProgressWeight = 2.5}) - '下载支持库 - If FixLibrary Then - Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 Fabric 支持库文件", - Sub(Task) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) - Loaders.Add(New LoaderDownload("下载 Fabric 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 8}) - End If - Return Loaders End Function @@ -1866,38 +1739,41 @@ Retry: #Region "Fabric 下载菜单" - Public Function FabricDownloadListItem(Entry As JObject, OnClick As MyListItem.ClickEventHandler) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry("version").ToString.Replace("+build", ""), .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = If(Entry("stable").ToObject(Of Boolean), "稳定版", "测试版"), - .Logo = PathImage & "Blocks/Fabric.png" - } - AddHandler NewItem.Click, OnClick - '结束 - Return NewItem + Public Function FabricDownloadListItem(Entry As JObject, OnClick As MyListItem.ClickEventHandler) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + Dim NewItem As New MyListItem With { + .Title = Entry("version").ToString.Replace("+build", ""), .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = If(Entry("stable").ToObject(Of Boolean), "稳定版", "测试版"), + .Logo = PathImage & "Blocks/Fabric.png" + } + AddHandler NewItem.Click, OnClick + Return NewItem + End Function) With {.Height = 42} End Function - Public Function FabricApiDownloadListItem(Entry As CompFile, OnClick As MyListItem.ClickEventHandler) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry.DisplayName.Split("]")(1).Replace("Fabric API ", "").Replace(" build ", ".").BeforeFirst("+").Trim, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = Entry.StatusDescription & "，发布于 " & Entry.ReleaseDate.ToString("yyyy'/'MM'/'dd HH':'mm"), - .Logo = PathImage & "Blocks/Fabric.png" - } - AddHandler NewItem.Click, OnClick - '结束 - Return NewItem + Public Function FabricApiDownloadListItem(Entry As CompFile, OnClick As MyListItem.ClickEventHandler) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + Dim NewItem As New MyListItem With { + .Title = Entry.DisplayName.Split("]")(1).Replace("Fabric API ", "").Replace(" build ", ".").BeforeFirst("+").Trim, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = Entry.StatusDescription & "，发布于 " & Entry.ReleaseDate.ToString("yyyy'/'MM'/'dd HH':'mm"), + .Logo = PathImage & "Blocks/Fabric.png" + } + AddHandler NewItem.Click, OnClick + Return NewItem + End Function) With {.Height = 42} End Function - Public Function OptiFabricDownloadListItem(Entry As CompFile, OnClick As MyListItem.ClickEventHandler) As MyListItem - '建立控件 - Dim NewItem As New MyListItem With { - .Title = Entry.DisplayName.ToLower.Replace("optifabric-", "").Replace(".jar", "").Trim.TrimStart("v"), .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, - .Info = Entry.StatusDescription & "，发布于 " & Entry.ReleaseDate.ToString("yyyy'/'MM'/'dd HH':'mm"), - .Logo = PathImage & "Blocks/OptiFabric.png" - } - AddHandler NewItem.Click, OnClick - '结束 - Return NewItem + Public Function OptiFabricDownloadListItem(Entry As CompFile, OnClick As MyListItem.ClickEventHandler) As MyVirtualizingElement(Of MyListItem) + Return New MyVirtualizingElement(Of MyListItem)( + Function() + Dim NewItem As New MyListItem With { + .Title = Entry.DisplayName.Lower.Replace("optifabric-", "").Replace(".jar", "").Trim.TrimStart("v"), .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry, + .Info = Entry.StatusDescription & "，发布于 " & Entry.ReleaseDate.ToString("yyyy'/'MM'/'dd HH':'mm"), + .Logo = PathImage & "Blocks/OptiFabric.png" + } + AddHandler NewItem.Click, OnClick + Return NewItem + End Function) With {.Height = 42} End Function #End Region @@ -1912,11 +1788,11 @@ Retry: ''' ''' 必填。安装目标版本名称。 ''' - Public TargetVersionName As String + Public NewInstanceName As String ''' ''' 必填。安装目标文件夹。 ''' - Public TargetVersionFolder As String + Public VersionFolder As String ''' ''' 必填。欲下载的 Minecraft 的版本名。 @@ -1983,38 +1859,39 @@ Retry: ''' 在加载器状态改变后显示一条提示。 ''' 不会进行任何其他操作。 ''' - Public Sub LoaderStateChangedHintOnly(Loader) + Public Sub LoaderStateChangedHintOnly(Loader As LoaderBase) Select Case Loader.State Case LoadState.Finished - Hint(Loader.Name & "成功！", HintType.Finish) + Hint(Loader.Name & "成功！", HintType.Green) Case LoadState.Failed - Hint(Loader.Name & "失败：" & GetExceptionSummary(Loader.Error), HintType.Critical) - Case LoadState.Aborted - Hint(Loader.Name & "已取消！", HintType.Info) + Hint(Loader.Name & "失败：" & Loader.Error.GetBrief(), HintType.Red) + Case LoadState.Interrupted + Hint(Loader.Name & "已取消！", HintType.Blue) End Select End Sub ''' ''' 安装加载器状态改变后进行提示和重载文件夹列表的方法。 ''' - Public Sub McInstallState(Loader) + Public Sub McInstallState(Loader As LoaderBase) Select Case Loader.State Case LoadState.Finished - WriteIni(PathMcFolder & "PCL.ini", "VersionCache", "") '清空缓存（合并安装会先生成文件夹，这会在刷新时误判为可以使用缓存） - Hint(Loader.Name & "成功！", HintType.Finish) + WriteIni(McFolderSelected & "PCL.ini", "InstanceCache", "") '清空缓存（合并安装会先生成文件夹，这会在刷新时误判为可以使用缓存） + Hint(Loader.Name & "成功！", HintType.Green) + 'TODO: 自动选择安装成功的版本 Case LoadState.Failed - Hint(Loader.Name & "失败：" & GetExceptionSummary(Loader.Error), HintType.Critical) - Case LoadState.Aborted - Hint(Loader.Name & "已取消！", HintType.Info) + MyMsgBox(Loader.Error.GetDetail, Loader.Name & "失败", IsWarn:=True) + Case LoadState.Interrupted + Hint(Loader.Name & "已取消！", HintType.Blue) Case LoadState.Loading Return '不重新加载版本列表 End Select McInstallFailedClearFolder(Loader) - LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") + LoaderFolderRun(McInstanceListLoader, McFolderSelected, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") End Sub Public Sub McInstallFailedClearFolder(Loader) Try Thread.Sleep(1000) '防止存在尚未完全释放的文件，导致清理失败（例如整合包安装） - If Loader.State = LoadState.Failed OrElse Loader.State = LoadState.Aborted Then + If Loader.State = LoadState.Failed OrElse Loader.State = LoadState.Interrupted Then '删除版本文件夹 If Directory.Exists(Loader.Input & "saves\") OrElse Directory.Exists(Loader.Input & "versions\") Then Log("[Download] 由于版本已被独立启动，不清理版本文件夹：" & Loader.Input, LogLevel.Developer) @@ -2035,10 +1912,10 @@ Retry: Try Dim SubLoaders = McInstallLoader(Request) If SubLoaders Is Nothing Then Return False - Dim Loader As New LoaderCombo(Of String)(Request.TargetVersionName & " 安装", SubLoaders) With {.OnStateChanged = AddressOf McInstallState} + Dim Loader As New LoaderCombo(Of String)(Request.NewInstanceName & " 安装", SubLoaders) With {.OnStateChanged = AddressOf McInstallState} '启动 - Loader.Start(Request.TargetVersionFolder) + Loader.Start(Request.VersionFolder) LoaderTaskbarAdd(Loader) FrmMain.BtnExtraDownload.ShowRefresh() FrmMain.BtnExtraDownload.Ribble() @@ -2060,21 +1937,21 @@ Retry: Dim TempMcFolder As String = RequestTaskTempFolder(Request.OptiFineEntry IsNot Nothing OrElse Request.ForgeEntry IsNot Nothing OrElse Request.NeoForgeEntry IsNot Nothing) '获取参数 - Dim VersionFolder As String = PathMcFolder & "versions\" & Request.TargetVersionName & "\" + Dim VersionFolder As String = McFolderSelected & "versions\" & Request.NewInstanceName & "\" If Directory.Exists(TempMcFolder) Then DeleteDirectory(TempMcFolder) Dim OptiFineFolder As String = Nothing If Request.OptiFineVersion IsNot Nothing Then If Request.OptiFineVersion.Contains("_HD_U_") Then Request.OptiFineVersion = "HD_U_" & Request.OptiFineVersion.AfterLast("_HD_U_") '#735 Request.OptiFineEntry = New DlOptiFineListEntry With { - .NameDisplay = Request.MinecraftName & " " & Request.OptiFineVersion.Replace("HD_U_", "").Replace("_", "").Replace("pre", " pre"), + .DisplayName = Request.MinecraftName & " " & Request.OptiFineVersion.Replace("HD_U_", "").Replace("_", "").Replace("pre", " pre"), .Inherit = Request.MinecraftName, .IsPreview = Request.OptiFineVersion.ContainsF("pre", True), - .NameVersion = Request.MinecraftName & "-OptiFine_" & Request.OptiFineVersion, - .NameFile = If(Request.OptiFineVersion.ContainsF("pre", True), "preview_", "") & + .InstanceName = Request.MinecraftName & "-OptiFine_" & Request.OptiFineVersion, + .FileName = If(Request.OptiFineVersion.ContainsF("pre", True), "preview_", "") & "OptiFine_" & Request.MinecraftName & "_" & Request.OptiFineVersion & ".jar" } End If - If Request.OptiFineEntry IsNot Nothing Then OptiFineFolder = TempMcFolder & "versions\" & Request.OptiFineEntry.NameVersion + If Request.OptiFineEntry IsNot Nothing Then OptiFineFolder = TempMcFolder & "versions\" & Request.OptiFineEntry.InstanceName Dim ForgeFolder As String = Nothing If Request.ForgeEntry IsNot Nothing Then Request.ForgeVersion = If(Request.ForgeVersion, Request.ForgeEntry.VersionName) If Request.ForgeVersion IsNot Nothing Then ForgeFolder = TempMcFolder & "versions\forge-" & Request.ForgeVersion @@ -2092,7 +1969,11 @@ Retry: Dim OptiFineAsMod As Boolean = Request.OptiFineEntry IsNot Nothing AndAlso Modable '选择了 OptiFine 与任意 Mod 加载器 If OptiFineAsMod Then Log("[Download] OptiFine 将作为 Mod 进行下载") - OptiFineFolder = ModsTempFolder + If Request.LiteLoaderEntry IsNot Nothing Then + OptiFineFolder = ModsTempFolder & Request.MinecraftName & "\" '#8147 + Else + OptiFineFolder = ModsTempFolder + End If End If '记录日志 @@ -2104,8 +1985,8 @@ Retry: Log("[Download] 对应的原版版本：" & Request.MinecraftName) '重复版本检查 - If File.Exists($"{VersionFolder}{Request.TargetVersionName}.json") Then - Hint("版本 " & Request.TargetVersionName & " 已经存在！", HintType.Critical) + If File.Exists($"{VersionFolder}{Request.NewInstanceName}.json") Then + Hint("版本 " & Request.NewInstanceName & " 已经存在！", HintType.Red) Throw New CancelledException End If @@ -2121,37 +2002,37 @@ Retry: LoaderList.Add(New LoaderDownload("下载 OptiFabric", New List(Of NetFile) From {Request.OptiFabric.ToNetFile(ModsTempFolder)}) With {.ProgressWeight = 3, .Block = False}) End If '原版 - Dim ClientLoader = New LoaderCombo(Of String)("下载原版 " & Request.MinecraftName, McDownloadClientLoader(Request.MinecraftName, Request.MinecraftJson, Request.TargetVersionName)) With {.Show = False, .ProgressWeight = 39, + Dim ClientLoader = New LoaderCombo(Of String)("下载原版 " & Request.MinecraftName, McDownloadClientLoader(Request.MinecraftName, Request.MinecraftJson, Request.NewInstanceName)) With {.Show = False, .ProgressWeight = 39, .Block = Request.ForgeVersion Is Nothing AndAlso Request.NeoForgeVersion Is Nothing AndAlso Request.OptiFineEntry Is Nothing AndAlso Request.FabricVersion Is Nothing AndAlso Request.LiteLoaderEntry Is Nothing} LoaderList.Add(ClientLoader) 'OptiFine If Request.OptiFineEntry IsNot Nothing Then If OptiFineAsMod Then - LoaderList.Add(New LoaderCombo(Of String)("下载 OptiFine " & Request.OptiFineEntry.NameDisplay, McDownloadOptiFineSaveLoader(Request.OptiFineEntry, OptiFineFolder & Request.OptiFineEntry.NameFile)) With {.Show = False, .ProgressWeight = 16, + LoaderList.Add(New LoaderCombo(Of String)("下载 OptiFine " & Request.OptiFineEntry.DisplayName, McDownloadOptiFineSaveLoader(Request.OptiFineEntry, OptiFineFolder & Request.OptiFineEntry.FileName)) With {.Show = False, .ProgressWeight = 16, .Block = Request.ForgeVersion Is Nothing AndAlso Request.NeoForgeVersion Is Nothing AndAlso Request.FabricVersion Is Nothing AndAlso Request.LiteLoaderEntry Is Nothing}) Else - LoaderList.Add(New LoaderCombo(Of String)("下载 OptiFine " & Request.OptiFineEntry.NameDisplay, McDownloadOptiFineLoader(Request.OptiFineEntry, TempMcFolder, ClientLoader, Request.TargetVersionFolder, False)) With {.Show = False, .ProgressWeight = 24, + LoaderList.Add(New LoaderCombo(Of String)("下载 OptiFine " & Request.OptiFineEntry.DisplayName, McDownloadOptiFineLoader(Request.OptiFineEntry, TempMcFolder, ClientLoader, Request.VersionFolder)) With {.Show = False, .ProgressWeight = 24, .Block = Request.ForgeVersion Is Nothing AndAlso Request.NeoForgeVersion Is Nothing AndAlso Request.FabricVersion Is Nothing AndAlso Request.LiteLoaderEntry Is Nothing}) End If End If 'Forge If Request.ForgeVersion IsNot Nothing Then - LoaderList.Add(New LoaderCombo(Of String)("下载 Forge " & Request.ForgeVersion, McDownloadForgelikeLoader(False, Request.ForgeVersion, "forge-" & Request.ForgeVersion, Request.MinecraftName, Request.ForgeEntry, TempMcFolder, ClientLoader, Request.TargetVersionFolder)) With {.Show = False, .ProgressWeight = 25, + LoaderList.Add(New LoaderCombo(Of String)("下载 Forge " & Request.ForgeVersion, McDownloadForgelikeLoader(False, Request.ForgeVersion, "forge-" & Request.ForgeVersion, Request.MinecraftName, Request.ForgeEntry, TempMcFolder, ClientLoader, Request.VersionFolder)) With {.Show = False, .ProgressWeight = 25, .Block = Request.FabricVersion Is Nothing AndAlso Request.LiteLoaderEntry Is Nothing AndAlso Request.NeoForgeEntry Is Nothing}) End If 'NeoForge If Request.NeoForgeVersion IsNot Nothing Then - LoaderList.Add(New LoaderCombo(Of String)("下载 NeoForge " & Request.NeoForgeVersion, McDownloadForgelikeLoader(True, Request.NeoForgeVersion, "neoforge-" & Request.NeoForgeVersion, Request.MinecraftName, Request.NeoForgeEntry, TempMcFolder, ClientLoader, Request.TargetVersionFolder)) With {.Show = False, .ProgressWeight = 25, + LoaderList.Add(New LoaderCombo(Of String)("下载 NeoForge " & Request.NeoForgeVersion, McDownloadForgelikeLoader(True, Request.NeoForgeVersion, "neoforge-" & Request.NeoForgeVersion, Request.MinecraftName, Request.NeoForgeEntry, TempMcFolder, ClientLoader, Request.VersionFolder)) With {.Show = False, .ProgressWeight = 25, .Block = Request.ForgeEntry Is Nothing AndAlso Request.FabricVersion Is Nothing AndAlso Request.LiteLoaderEntry Is Nothing}) End If 'LiteLoader If Request.LiteLoaderEntry IsNot Nothing Then - LoaderList.Add(New LoaderCombo(Of String)("下载 LiteLoader " & Request.MinecraftName, McDownloadLiteLoaderLoader(Request.LiteLoaderEntry, TempMcFolder, ClientLoader, False)) With {.Show = False, .ProgressWeight = 1, + LoaderList.Add(New LoaderCombo(Of String)("下载 LiteLoader " & Request.MinecraftName, McDownloadLiteLoaderLoader(Request.LiteLoaderEntry, TempMcFolder)) With {.Show = False, .ProgressWeight = 1, .Block = Request.FabricVersion Is Nothing}) End If 'Fabric If Request.FabricVersion IsNot Nothing Then - LoaderList.Add(New LoaderCombo(Of String)("下载 Fabric " & Request.FabricVersion, McDownloadFabricLoader(Request.FabricVersion, Request.MinecraftName, TempMcFolder, False)) With {.Show = False, .ProgressWeight = 2, + LoaderList.Add(New LoaderCombo(Of String)("下载 Fabric " & Request.FabricVersion, McDownloadFabricLoader(Request.FabricVersion, Request.MinecraftName, TempMcFolder)) With {.Show = False, .ProgressWeight = 2, .Block = True}) End If '合并安装 @@ -2161,24 +2042,24 @@ Retry: MergeJson(VersionFolder, VersionFolder, OptiFineFolder, OptiFineAsMod, ForgeFolder, Request.ForgeVersion, NeoForgeFolder, Request.NeoForgeVersion, FabricFolder, LiteLoaderFolder) Task.Progress = 0.2 '迁移文件 - If Directory.Exists(TempMcFolder & "libraries") Then CopyDirectory(TempMcFolder & "libraries", PathMcFolder & "libraries") + If Directory.Exists(TempMcFolder & "libraries") Then CopyDirectory(TempMcFolder & "libraries", McFolderSelected & "libraries") Task.Progress = 0.8 '创建 Mod 和资源包文件夹 - Dim ModsFolder = New McVersion(VersionFolder).PathIndie & "mods\" '版本隔离信息在此时被决定 + Dim ModsFolder = New McInstance(VersionFolder).PathIndie & "mods\" '版本隔离信息在此时被决定 If Directory.Exists(ModsTempFolder) Then CopyDirectory(ModsTempFolder, ModsFolder) ElseIf Modable Then Directory.CreateDirectory(ModsFolder) Log("[Download] 自动创建 Mod 文件夹：" & ModsFolder) End If - Dim ResourcepacksFolder = New McVersion(VersionFolder).PathIndie & "resourcepacks\" + Dim ResourcepacksFolder = New McInstance(VersionFolder).PathIndie & "resourcepacks\" Directory.CreateDirectory(ResourcepacksFolder) Log("[Download] 自动创建资源包文件夹：" & ResourcepacksFolder) End Sub) With {.ProgressWeight = 2, .Block = True}) '补全文件 If Request.OptiFineEntry IsNot Nothing OrElse (Request.ForgeVersion IsNot Nothing AndAlso Request.ForgeVersion.BeforeFirst(".") >= 20) OrElse Request.NeoForgeVersion IsNot Nothing OrElse Request.FabricVersion IsNot Nothing OrElse Request.LiteLoaderEntry IsNot Nothing Then Dim LoadersLib As New List(Of LoaderBase) - LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) + LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task) Task.Output = McLibNetFilesFromInstance(New McInstance(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False}) LoaderList.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8}) End If @@ -2303,7 +2184,7 @@ Retry: SplitArguments.Add(RawArguments(i)) End If Next - Dim RealArguments As String = Join(SplitArguments.Distinct.ToList, " ") + Dim RealArguments As String = SplitArguments.Distinct.Join(" ") '合并 '相关讨论见 #2801 OutputJson = MinecraftJson @@ -2358,4 +2239,48 @@ Retry: #End Region + ''' + ''' 如果 OptiFine 与 Forge 同时开始安装，就会导致 Forge 安装失败。 + ''' + Private InstallSyncLock As New Object + ''' + ''' 如果 OptiFine 与 Forge 同时复制原版 JAR，就会导致复制文件时冲突。 + ''' + Private VanillaSyncLock As New Object + + ''' + ''' 释放补丁文件并返回完整文件路径。 + ''' + ''' "LUA" 或 "JavaWrapper"。 + Public Function ExtractPatch(Patch As String) As String + Dim PatchPath As String = $"{PathPure}{Patch}.jar" + Log($"[Java] 选定的 {Patch} 路径：{PatchPath}") + Static Lock As New Object + SyncLock Lock '避免 OptiFine 和 Forge 安装时同时释放导致冲突 + Try + WriteFile(PatchPath, GetResources(Patch)) + Catch ex As Exception + If File.Exists(PatchPath) Then + '因为未知原因可能变为只读文件（#4243） + Log(ex, $"{Patch} 文件释放失败，但文件已存在，将在删除后尝试重新生成", LogLevel.Developer) + Try + File.Delete(PatchPath) + WriteFile(PatchPath, GetResources(Patch)) + Catch ex2 As Exception + Log(ex2, $"{Patch} 文件重新释放失败，将尝试更换文件名重新生成", LogLevel.Developer) + PatchPath = $"{PathPure}{Patch}2.jar" + Try + WriteFile(PatchPath, GetResources(Patch)) + Catch ex3 As Exception + Throw New FileNotFoundException($"释放 {Patch} 最终尝试失败", ex3) + End Try + End Try + Else + Throw New FileNotFoundException($"释放 {Patch} 失败", ex) + End If + End Try + End SyncLock + Return PatchPath + End Function + End Module diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml deleted file mode 100644 index e45317e..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml +++ /dev/null @@ -1,31 +0,0 @@ - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb deleted file mode 100644 index 2af82b7..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb +++ /dev/null @@ -1,111 +0,0 @@ -Public Class PageDownloadClient - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanBack, Nothing, DlClientListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of JObject)) From { - {"正式版", New List(Of JObject)}, {"预览版", New List(Of JObject)}, {"远古版", New List(Of JObject)}, {"愚人节版", New List(Of JObject)} - } - Dim Versions As JArray = DlClientListLoader.Output.Value("versions") - For Each Version As JObject In Versions - '确定分类 - Dim Type As String = Version("type") - Select Case Type - Case "release" - Type = "正式版" - Case "snapshot" - Type = "预览版" - 'Mojang 误分类 - If Version("id").ToString.StartsWith("1.") AndAlso - Not Version("id").ToString.ToLower.Contains("combat") AndAlso - Not Version("id").ToString.ToLower.Contains("rc") AndAlso - Not Version("id").ToString.ToLower.Contains("experimental") AndAlso - Not Version("id").ToString.ToLower.Contains("pre") Then - Type = "正式版" - Version("type") = "release" - End If - '愚人节版本 - Select Case Version("id").ToString.ToLower - Case "20w14infinite", "20w14∞" - Type = "愚人节版" - Version("id") = "20w14∞" - Version("type") = "special" - Version.Add("lore", GetMcFoolName(Version("id"))) - Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b", "24w14potato", "25w14craftmine" - Type = "愚人节版" - Version("type") = "special" - Version.Add("lore", GetMcFoolName(Version("id"))) - Case Else '4/1 自动视作愚人节版 - Dim ReleaseDate = Version("releaseTime").Value(Of Date).ToUniversalTime().AddHours(2) - If ReleaseDate.Month = 4 AndAlso ReleaseDate.Day = 1 Then - Type = "愚人节版" - Version("type") = "special" - End If - End Select - Case "special" - '已被处理的愚人节版 - Type = "愚人节版" - Case Else - Type = "远古版" - End Select - '加入辞典 - Dict(Type).Add(Version) - Next - '排序 - For i = 0 To Dict.Keys.Count - 1 - Dict(Dict.Keys(i)) = Dict.Values(i).OrderByDescending(Function(v) v("releaseTime").Value(Of Date)).ToList - Next - '清空当前 - PanMain.Children.Clear() - '添加最新版本 - Dim CardInfo As New MyCard With {.Title = "最新版本", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 2} - Dim TopestVersions As New List(Of JObject) - Dim Release As JObject = Dict("正式版")(0).DeepClone() - Release("lore") = "最新正式版，发布于 " & Release("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Release) - If Dict("正式版")(0)("releaseTime").Value(Of Date) < Dict("预览版")(0)("releaseTime").Value(Of Date) Then - Dim Snapshot As JObject = Dict("预览版")(0).DeepClone() - Snapshot("lore") = "最新预览版，发布于 " & Snapshot("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Snapshot) - End If - Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = TopestVersions} - MyCard.StackInstall(PanInfo, 2) - CardInfo.Children.Add(PanInfo) - PanMain.Children.Add(CardInfo) - '添加其他版本 - For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict - If Not Pair.Value.Any() Then Continue For - '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 2} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwaped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 MC 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Public Sub DownloadStart(sender As MyListItem, e As Object) - McDownloadClient(NetPreDownloadBehaviour.HintWhileExists, sender.Title, sender.Tag("url").ToString) - End Sub - - ''介绍栏 - 'Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - ' OpenWebsite("https://www.minecraft.net/zh-hans") - 'End Sub - 'Private Sub BtnInstall_Click(sender As Object, e As EventArgs) Handles BtnInstall.Click - ' FrmMain.PageChange(FormMain.PageType.Download, FormMain.PageSubType.DownloadInstall) - 'End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml deleted file mode 100644 index 0c19a78..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml +++ /dev/null @@ -1,28 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb deleted file mode 100644 index fa65b79..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb +++ /dev/null @@ -1,32 +0,0 @@ -Public Class PageDownloadFabric - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, CardVersions, CardTip, DlFabricListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - Dim Versions As JArray = DlFabricListLoader.Output.Value("installer") - PanVersions.Children.Clear() - For Each Version In Versions - PanVersions.Children.Add(FabricDownloadListItem(Version, AddressOf Fabric_Selected)) - Next - CardVersions.Title = "版本列表 (" & Versions.Count & ")" - Catch ex As Exception - Log(ex, "可视化 Fabric 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Private Sub Fabric_Selected(sender As MyListItem, e As EventArgs) - McDownloadFabricLoaderSave(sender.Tag) - End Sub - - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.fabricmc.net") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml deleted file mode 100644 index a4379c4..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb deleted file mode 100644 index 04a74e0..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb +++ /dev/null @@ -1,61 +0,0 @@ -Public Class PageDownloadForge - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlForgeListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Version As String In DlForgeListLoader.Output.Value.Sort(AddressOf VersionSortBoolean) - '增加卡片 - Dim NewCard As New MyCard With {.Title = Version.Replace("_p", " P"), .Margin = New Thickness(0, 0, 0, 15), .SwapType = 5} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Version} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwaped = True - PanMain.Children.Add(NewCard) - Next - ''非官方源警示 - 'If Setup.Get("ToolDownloadOutOfDate") AndAlso Not DlForgeListLoader.Output.IsOfficial Then - ' Dim CardWarn As New MyCard With {.Title = "过期提示", .Margin = New Thickness(0, 0, 0, 15)} - ' CardWarn.Children.Add(New TextBlock With { - ' .Margin = New Thickness(25, MyCard.SwapedHeight, 15, 15), .VerticalAlignment = VerticalAlignment.Top, .HorizontalAlignment = HorizontalAlignment.Left, .TextTrimming = TextTrimming.None, .TextWrapping = TextWrapping.Wrap, - ' .Text = "获取官方源失败，正在使用 " & DlForgeListLoader.Output.SourceName & " 镜像源，版本列表可能并非最新。" & vbCrLf & "官方源错误原因：" & If(DlForgeListLoader.Output.OfficialError, New Exception("连接服务器超时")).Message}) - ' PanMain.Children.Insert(0, CardWarn) - 'End If - Catch ex As Exception - Log(ex, "可视化 Forge 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - 'Forge 版本列表加载 - Public Sub Forge_Click(sender As MyLoading, e As MouseButtonEventArgs) - If sender.State.LoadingState = MyLoading.MyLoadingState.Error Then - CType(sender.State, LoaderTask(Of String, List(Of DlForgeVersionEntry))).Start(IsForceRestart:=True) - End If - End Sub - Public Sub Forge_StateChanged(sender As MyLoading, newState As MyLoading.MyLoadingState, oldState As MyLoading.MyLoadingState) - If newState <> MyLoading.MyLoadingState.Stop Then Return - - Dim Card As MyCard = CType(sender.Parent, FrameworkElement).Parent - Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = sender.State - '载入列表 - Card.SwapControl.Children.Clear() - Card.SwapControl.Tag = Loader.Output - Card.SwapType = 6 - Card.StackInstall() - End Sub - - '介绍栏 - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://files.minecraftforge.net") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml index 35c1a4e..74a753d 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadInstall" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> @@ -27,7 +27,7 @@ - + @@ -45,7 +45,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + @@ -63,7 +63,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + @@ -81,7 +81,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + @@ -99,7 +99,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + @@ -119,7 +119,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + @@ -137,7 +137,7 @@ Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> - + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb index dfd5042..14d943f 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb @@ -14,9 +14,9 @@ DlNeoForgeListLoader.Start() '重载预览 - TextSelectName.ValidateRules = New ObjectModel.Collection(Of Validate) From {New ValidateFolderName(PathMcFolder & "versions")} + TextSelectName.ValidateRules = New ObjectModel.Collection(Of Validate) From {New ValidateFolderName(McFolderSelected & "versions")} TextSelectName.Validate() - SelectReload() + ReloadSelected() '非重复加载部分 If IsLoad Then Return @@ -54,18 +54,13 @@ DisabledPageAnimControls.Remove(BtnStart) BtnStart.Show = True - CardOptiFine.IsSwaped = True - CardLiteLoader.IsSwaped = True - CardForge.IsSwaped = True - CardNeoForge.IsSwaped = True - CardFabric.IsSwaped = True - CardFabricApi.IsSwaped = True - CardOptiFabric.IsSwaped = True - - If Not Setup.Get("HintInstallBack") Then - Setup.Set("HintInstallBack", True) - Hint("点击 Minecraft 项即可返回游戏主版本选择页面！") - End If + CardOptiFine.IsSwapped = True + CardLiteLoader.IsSwapped = True + CardForge.IsSwapped = True + CardNeoForge.IsSwapped = True + CardFabric.IsSwapped = True + CardFabricApi.IsSwapped = True + CardOptiFabric.IsSwapped = True '如果在选择页面按了刷新键，选择页的东西可能会由于动画被隐藏，但不会由于加载结束而再次显示，因此这里需要手动恢复 For Each Control In GetAllAnimControls(PanSelect) @@ -76,10 +71,10 @@ Next '启动 Forge 加载 - If SelectedMinecraftId.StartsWith("1.") Then - Dim ForgeLoader = New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion " & SelectedMinecraftId, AddressOf DlForgeVersionMain) + If McVersion.IsFormatFit(VanillaName) Then + Dim ForgeLoader = New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion " & VanillaName, AddressOf DlForgeVersionMain) LoadForge.State = ForgeLoader - ForgeLoader.Start(SelectedMinecraftId) + ForgeLoader.Start(VanillaName) End If '启动 Fabric API、OptiFabric 加载 @@ -100,7 +95,7 @@ Fabric_Loaded() FabricApi_Loaded() OptiFabric_Loaded() - SelectReload() + ReloadSelected() PanMinecraft.Visibility = Visibility.Collapsed End Sub, After:=True), AaOpacity(PanSelect, 1 - PanSelect.Opacity, 70, 100), @@ -129,7 +124,7 @@ DisabledPageAnimControls.Add(BtnStart) BtnStart.Show = False - SelectClear() '清除已选择项 + ClearSelected() '清除已选择项 PanMinecraft.Visibility = Visibility.Visible PanSelect.IsHitTestVisible = False PanMinecraft.IsHitTestVisible = True @@ -150,9 +145,9 @@ }, "FrmDownloadInstall SelectPageSwitch") End Sub Public Sub MinecraftSelected(sender As MyListItem, e As MouseButtonEventArgs) - SelectedMinecraftId = sender.Title - SelectedMinecraftJsonUrl = sender.Tag("url").ToString - SelectedMinecraftIcon = sender.Logo + VanillaName = sender.Title + VanillaData = sender.Tag + VanillaIcon = sender.Logo EnterSelectPage() End Sub @@ -161,165 +156,39 @@ #Region "选择" 'Minecraft - Private SelectedMinecraftId As String - Private SelectedMinecraftJsonUrl As String - Private SelectedMinecraftIcon As String + Private VanillaName As String + Private VanillaData As JObject + Private VanillaIcon As String + Private ReadOnly Property VanillaDrop As Integer + Get + Return McVersion.VersionToDrop(VanillaName) + End Get + End Property - 'OptiFine + '附加组件 Private SelectedOptiFine As DlOptiFineListEntry = Nothing - Private Sub SetOptiFineInfoShow(IsShow As String) - If PanOptiFineInfo.Tag = IsShow Then Return - PanOptiFineInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanOptiFineInfo, -CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanOptiFineInfo, 1 - PanOptiFineInfo.Opacity, 80, 90) - }, "SetOptiFineInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanOptiFineInfo, 6 - CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanOptiFineInfo, -PanOptiFineInfo.Opacity, 50) - }, "SetOptiFineInfoShow") - End If - End Sub - - 'LiteLoader Private SelectedLiteLoader As DlLiteLoaderListEntry = Nothing - Private Sub SetLiteLoaderInfoShow(IsShow As String) - If PanLiteLoaderInfo.Tag = IsShow Then Return - PanLiteLoaderInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanLiteLoaderInfo, -CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanLiteLoaderInfo, 1 - PanLiteLoaderInfo.Opacity, 80, 90) - }, "SetLiteLoaderInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanLiteLoaderInfo, 6 - CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanLiteLoaderInfo, -PanLiteLoaderInfo.Opacity, 50) - }, "SetLiteLoaderInfoShow") - End If - End Sub - - 'Forge Private SelectedForge As DlForgeVersionEntry = Nothing - Private Sub SetForgeInfoShow(IsShow As String) - If PanForgeInfo.Tag = IsShow Then Return - PanForgeInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanForgeInfo, -CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanForgeInfo, 1 - PanForgeInfo.Opacity, 80, 90) - }, "SetForgeInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanForgeInfo, 6 - CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanForgeInfo, -PanForgeInfo.Opacity, 50) - }, "SetForgeInfoShow") - End If - End Sub - - 'NeoForge Private SelectedNeoForge As DlNeoForgeListEntry = Nothing - Private Sub SetNeoForgeInfoShow(IsShow As String) - If PanNeoForgeInfo.Tag = IsShow Then Return - PanNeoForgeInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanNeoForgeInfo, -CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanNeoForgeInfo, 1 - PanNeoForgeInfo.Opacity, 80, 90) - }, "SetNeoForgeInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanNeoForgeInfo, 6 - CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanNeoForgeInfo, -PanNeoForgeInfo.Opacity, 50) - }, "SetNeoForgeInfoShow") - End If - End Sub - - 'Fabric Private SelectedFabric As String = Nothing - Private Sub SetFabricInfoShow(IsShow As String) - If PanFabricInfo.Tag = IsShow Then Return - PanFabricInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanFabricInfo, -CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanFabricInfo, 1 - PanFabricInfo.Opacity, 80, 90) - }, "SetFabricInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanFabricInfo, 6 - CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanFabricInfo, -PanFabricInfo.Opacity, 50) - }, "SetFabricInfoShow") - End If - End Sub - - 'FabricApi Private SelectedFabricApi As CompFile = Nothing - Private Sub SetFabricApiInfoShow(IsShow As String) - If PanFabricApiInfo.Tag = IsShow Then Return - PanFabricApiInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanFabricApiInfo, -CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanFabricApiInfo, 1 - PanFabricApiInfo.Opacity, 80, 90) - }, "SetFabricApiInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanFabricApiInfo, 6 - CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanFabricApiInfo, -PanFabricApiInfo.Opacity, 50) - }, "SetFabricApiInfoShow") - End If - End Sub - - 'OptiFabric Private SelectedOptiFabric As CompFile = Nothing - Private Sub SetOptiFabricInfoShow(IsShow As String) - If PanOptiFabricInfo.Tag = IsShow Then Return - PanOptiFabricInfo.Tag = IsShow - If IsShow = "True" Then - '显示信息栏 - AniStart({ - AaTranslateY(PanOptiFabricInfo, -CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent), - AaOpacity(PanOptiFabricInfo, 1 - PanOptiFabricInfo.Opacity, 80, 90) - }, "SetOptiFabricInfoShow") - Else - '隐藏信息栏 - AniStart({ - AaTranslateY(PanOptiFabricInfo, 6 - CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 120), - AaOpacity(PanOptiFabricInfo, -PanOptiFabricInfo.Opacity, 50) - }, "SetOptiFabricInfoShow") - End If - End Sub - Private IsReloading As Boolean = False '#3742 中，LoadOptiFineGetError 会初始化 LoadOptiFine，触发事件 LoadOptiFine.StateChanged，导致再次调用 SelectReload ''' ''' 重载已选择的项目的显示。 ''' - Private Sub SelectReload() Handles CardOptiFine.Swap, LoadOptiFine.StateChanged, CardForge.Swap, LoadForge.StateChanged, CardNeoForge.Swap, LoadNeoForge.StateChanged, CardFabric.Swap, LoadFabric.StateChanged, CardFabricApi.Swap, LoadFabricApi.StateChanged, CardOptiFabric.Swap, LoadOptiFabric.StateChanged, CardLiteLoader.Swap, LoadLiteLoader.StateChanged - If SelectedMinecraftId Is Nothing OrElse IsReloading Then Return - IsReloading = True + Private Sub ReloadSelected() Handles CardOptiFine.Swap, LoadOptiFine.StateChanged, CardForge.Swap, LoadForge.StateChanged, CardNeoForge.Swap, LoadNeoForge.StateChanged, CardFabric.Swap, LoadFabric.StateChanged, CardFabricApi.Swap, LoadFabricApi.StateChanged, CardOptiFabric.Swap, LoadOptiFabric.StateChanged, CardLiteLoader.Swap, LoadLiteLoader.StateChanged + Static Ongoing As Boolean = False '#3742 中，LoadOptiFineGetError 会初始化 LoadOptiFine，触发事件 LoadOptiFine.StateChanged，导致再次调用 SelectReload + If VanillaName Is Nothing OrElse Ongoing Then Return + Ongoing = True '主预览 SelectNameUpdate() ImgLogo.Source = GetSelectLogo() 'OptiFine Dim OptiFineError As String = LoadOptiFineGetError() CardOptiFine.MainSwap.Visibility = If(OptiFineError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If OptiFineError IsNot Nothing Then CardOptiFine.IsSwaped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 - SetOptiFineInfoShow(CardOptiFine.IsSwaped) + If OptiFineError IsNot Nothing Then CardOptiFine.IsSwapped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 + SetPanelVisibility(PanOptiFineInfo, CardOptiFine.IsSwapped) If SelectedOptiFine Is Nothing Then BtnOptiFineClear.Visibility = Visibility.Collapsed ImgOptiFine.Visibility = Visibility.Collapsed @@ -328,18 +197,18 @@ Else BtnOptiFineClear.Visibility = Visibility.Visible ImgOptiFine.Visibility = Visibility.Visible - LabOptiFine.Text = SelectedOptiFine.NameDisplay.Replace(SelectedMinecraftId & " ", "") + LabOptiFine.Text = SelectedOptiFine.DisplayName.Replace(VanillaName & " ", "") LabOptiFine.Foreground = ColorGray1 End If 'LiteLoader - If Not SelectedMinecraftId.Contains("1.") OrElse Val(SelectedMinecraftId.Split(".")(1)) > 12 Then + If VanillaDrop >= 130 Then CardLiteLoader.Visibility = Visibility.Collapsed Else CardLiteLoader.Visibility = Visibility.Visible Dim LiteLoaderError As String = LoadLiteLoaderGetError() CardLiteLoader.MainSwap.Visibility = If(LiteLoaderError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If LiteLoaderError IsNot Nothing Then CardLiteLoader.IsSwaped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 - SetLiteLoaderInfoShow(CardLiteLoader.IsSwaped) + If LiteLoaderError IsNot Nothing Then CardLiteLoader.IsSwapped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 + SetPanelVisibility(PanLiteLoaderInfo, CardLiteLoader.IsSwapped) If SelectedLiteLoader Is Nothing Then BtnLiteLoaderClear.Visibility = Visibility.Collapsed ImgLiteLoader.Visibility = Visibility.Collapsed @@ -353,30 +222,35 @@ End If End If 'Forge - Dim ForgeError As String = LoadForgeGetError() - CardForge.MainSwap.Visibility = If(ForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If ForgeError IsNot Nothing Then CardForge.IsSwaped = True - SetForgeInfoShow(CardForge.IsSwaped) - If SelectedForge Is Nothing Then - BtnForgeClear.Visibility = Visibility.Collapsed - ImgForge.Visibility = Visibility.Collapsed - LabForge.Text = If(ForgeError, "可以添加") - LabForge.Foreground = ColorGray4 + If Not McVersion.IsFormatFit(VanillaName) Then + CardForge.Visibility = Visibility.Collapsed Else - BtnForgeClear.Visibility = Visibility.Visible - ImgForge.Visibility = Visibility.Visible - LabForge.Text = SelectedForge.VersionName - LabForge.Foreground = ColorGray1 + CardForge.Visibility = Visibility.Visible + Dim ForgeError As String = LoadForgeGetError() + CardForge.MainSwap.Visibility = If(ForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed) + If ForgeError IsNot Nothing Then CardForge.IsSwapped = True + SetPanelVisibility(PanForgeInfo, CardForge.IsSwapped) + If SelectedForge Is Nothing Then + BtnForgeClear.Visibility = Visibility.Collapsed + ImgForge.Visibility = Visibility.Collapsed + LabForge.Text = If(ForgeError, "可以添加") + LabForge.Foreground = ColorGray4 + Else + BtnForgeClear.Visibility = Visibility.Visible + ImgForge.Visibility = Visibility.Visible + LabForge.Text = SelectedForge.VersionName + LabForge.Foreground = ColorGray1 + End If End If 'NeoForge - If Not SelectedMinecraftId.Contains("1.") OrElse Val(SelectedMinecraftId.Split(".")(1)) <= 19 Then + If VanillaData("releaseTime").ToObject(Of Date) < New Date(2023, 6, 11) Then '匹配 1.20.1+ 与一些愚人节版本 CardNeoForge.Visibility = Visibility.Collapsed Else CardNeoForge.Visibility = Visibility.Visible Dim NeoForgeError As String = LoadNeoForgeGetError() CardNeoForge.MainSwap.Visibility = If(NeoForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If NeoForgeError IsNot Nothing Then CardNeoForge.IsSwaped = True - SetNeoForgeInfoShow(CardNeoForge.IsSwaped) + If NeoForgeError IsNot Nothing Then CardNeoForge.IsSwapped = True + SetPanelVisibility(PanNeoForgeInfo, CardNeoForge.IsSwapped) If SelectedNeoForge Is Nothing Then BtnNeoForgeClear.Visibility = Visibility.Collapsed ImgNeoForge.Visibility = Visibility.Collapsed @@ -390,14 +264,14 @@ End If End If 'Fabric - If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) <= 13 Then + If VanillaDrop <= 130 Then CardFabric.Visibility = Visibility.Collapsed Else CardFabric.Visibility = Visibility.Visible Dim FabricError As String = LoadFabricGetError() CardFabric.MainSwap.Visibility = If(FabricError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If FabricError IsNot Nothing Then CardFabric.IsSwaped = True - SetFabricInfoShow(CardFabric.IsSwaped) + If FabricError IsNot Nothing Then CardFabric.IsSwapped = True + SetPanelVisibility(PanFabricInfo, CardFabric.IsSwapped) If SelectedFabric Is Nothing Then BtnFabricClear.Visibility = Visibility.Collapsed ImgFabric.Visibility = Visibility.Collapsed @@ -417,8 +291,8 @@ CardFabricApi.Visibility = Visibility.Visible Dim FabricApiError As String = LoadFabricApiGetError() CardFabricApi.MainSwap.Visibility = If(FabricApiError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If FabricApiError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardFabricApi.IsSwaped = True - SetFabricApiInfoShow(CardFabricApi.IsSwaped) + If FabricApiError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardFabricApi.IsSwapped = True + SetPanelVisibility(PanFabricApiInfo, CardFabricApi.IsSwapped) If SelectedFabricApi Is Nothing Then BtnFabricApiClear.Visibility = Visibility.Collapsed ImgFabricApi.Visibility = Visibility.Collapsed @@ -438,8 +312,8 @@ CardOptiFabric.Visibility = Visibility.Visible Dim OptiFabricError As String = LoadOptiFabricGetError() CardOptiFabric.MainSwap.Visibility = If(OptiFabricError Is Nothing, Visibility.Visible, Visibility.Collapsed) - If OptiFabricError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardOptiFabric.IsSwaped = True - SetOptiFabricInfoShow(CardOptiFabric.IsSwaped) + If OptiFabricError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardOptiFabric.IsSwapped = True + SetPanelVisibility(PanOptiFabricInfo, CardOptiFabric.IsSwapped) If SelectedOptiFabric Is Nothing Then BtnOptiFabricClear.Visibility = Visibility.Collapsed ImgOptiFabric.Visibility = Visibility.Collapsed @@ -448,7 +322,7 @@ Else BtnOptiFabricClear.Visibility = Visibility.Visible ImgOptiFabric.Visibility = Visibility.Visible - LabOptiFabric.Text = SelectedOptiFabric.DisplayName.ToLower.Replace("optifabric-", "").Replace(".jar", "").Trim.TrimStart("v") + LabOptiFabric.Text = SelectedOptiFabric.DisplayName.Lower.Replace("optifabric-", "").Replace(".jar", "").Trim.TrimStart("v") LabOptiFabric.Foreground = ColorGray1 End If End If @@ -459,7 +333,7 @@ HintFabricAPI.Visibility = Visibility.Collapsed End If If SelectedFabric IsNot Nothing AndAlso SelectedOptiFine IsNot Nothing AndAlso SelectedOptiFabric Is Nothing Then - If SelectedMinecraftId.StartsWith("1.14") OrElse SelectedMinecraftId.StartsWith("1.15") Then + If VanillaDrop >= 140 AndAlso VanillaDrop <= 150 Then HintOptiFabric.Visibility = Visibility.Collapsed HintOptiFabricOld.Visibility = Visibility.Visible Else @@ -470,22 +344,22 @@ HintOptiFabric.Visibility = Visibility.Collapsed HintOptiFabricOld.Visibility = Visibility.Collapsed End If - If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) >= 16 AndAlso SelectedOptiFine IsNot Nothing AndAlso + If VanillaDrop >= 160 AndAlso SelectedOptiFine IsNot Nothing AndAlso (SelectedForge IsNot Nothing OrElse SelectedFabric IsNot Nothing) Then HintModOptiFine.Visibility = Visibility.Visible Else HintModOptiFine.Visibility = Visibility.Collapsed End If '结束 - IsReloading = False + Ongoing = False End Sub ''' ''' 清空已选择的项目。 ''' - Private Sub SelectClear() - SelectedMinecraftId = Nothing - SelectedMinecraftJsonUrl = Nothing - SelectedMinecraftIcon = Nothing + Private Sub ClearSelected() + VanillaName = Nothing + VanillaData = Nothing + VanillaIcon = Nothing SelectedOptiFine = Nothing SelectedLiteLoader = Nothing SelectedForge = Nothing @@ -493,6 +367,23 @@ SelectedFabric = Nothing SelectedFabricApi = Nothing SelectedOptiFabric = Nothing + IsSelectNameEdited = False + End Sub + '信息栏动画 + Private Sub SetPanelVisibility(Panel As Grid, IsVisible As Boolean) + If Panel.Tag = IsVisible.ToString Then Return + Panel.Tag = IsVisible.ToString + If IsVisible Then + AniStart({ + AaTranslateY(Panel, -CType(Panel.RenderTransform, TranslateTransform).Y, 150, Ease:=New AniEaseOutFluent), + AaOpacity(Panel, 1 - Panel.Opacity, 60) + }, "PageDownloadInstall Visibility " & Panel.Name) + Else + AniStart({ + AaTranslateY(Panel, 6 - CType(Panel.RenderTransform, TranslateTransform).Y, 60), + AaOpacity(Panel, -Panel.Opacity, 60) + }, "PageDownloadInstall Visibility " & Panel.Name) + End If End Sub ''' @@ -510,7 +401,7 @@ ElseIf SelectedOptiFine IsNot Nothing Then Return "pack://application:,,,/images/Blocks/GrassPath.png" Else - Return SelectedMinecraftIcon + Return VanillaIcon End If End Function @@ -519,22 +410,12 @@ ''' 获取默认版本名。 ''' Private Function GetSelectName() As String - Dim Name As String = SelectedMinecraftId - If SelectedFabric IsNot Nothing Then - Name += "-Fabric " & SelectedFabric.Replace("+build", "") - End If - If SelectedForge IsNot Nothing Then - Name += "-Forge_" & SelectedForge.VersionName - End If - If SelectedNeoForge IsNot Nothing Then - Name += "-NeoForge_" & SelectedNeoForge.VersionName - End If - If SelectedLiteLoader IsNot Nothing Then - Name += "-LiteLoader" - End If - If SelectedOptiFine IsNot Nothing Then - Name += "-OptiFine_" & SelectedOptiFine.NameDisplay.Replace(SelectedMinecraftId & " ", "").Replace(" ", "_") - End If + Dim Name As String = VanillaName + If SelectedFabric IsNot Nothing Then Name += "-Fabric " & SelectedFabric.BeforeFirst("+") + If SelectedForge IsNot Nothing Then Name += "-Forge_" & SelectedForge.VersionName + If SelectedNeoForge IsNot Nothing Then Name += "-NeoForge_" & SelectedNeoForge.VersionName.BeforeFirst("+") + If SelectedLiteLoader IsNot Nothing Then Name += "-LiteLoader" + If SelectedOptiFine IsNot Nothing Then Name += "-OptiFine_" & SelectedOptiFine.DisplayName.Replace(VanillaName & " ", "").Replace(" ", "_") Return Name End Function Private IsSelectNameEdited As Boolean = False @@ -548,7 +429,7 @@ Private Sub TextSelectName_TextChanged(sender As Object, e As TextChangedEventArgs) Handles TextSelectName.TextChanged If IsSelectNameChanging Then Return IsSelectNameEdited = True - SelectReload() + ReloadSelected() End Sub Private Sub TextSelectName_ValidateChanged(sender As Object, e As EventArgs) Handles TextSelectName.ValidateChanged BtnStart.IsEnabled = TextSelectName.IsValidated @@ -575,22 +456,22 @@ Case "snapshot" Type = "预览版" 'Mojang 误分类 - If Version("id").ToString.StartsWith("1.") AndAlso - Not Version("id").ToString.ToLower.Contains("combat") AndAlso - Not Version("id").ToString.ToLower.Contains("rc") AndAlso - Not Version("id").ToString.ToLower.Contains("experimental") AndAlso - Not Version("id").ToString.ToLower.Contains("pre") Then + If Version("id").ToString.StartsWithF("1.") AndAlso + Not Version("id").ToString.Lower.Contains("combat") AndAlso + Not Version("id").ToString.Lower.Contains("rc") AndAlso + Not Version("id").ToString.Lower.Contains("experimental") AndAlso + Not Version("id").ToString.Lower.Contains("pre") Then Type = "正式版" Version("type") = "release" End If '愚人节版本 - Select Case Version("id").ToString.ToLower + Select Case Version("id").ToString.Lower Case "20w14infinite", "20w14∞" Type = "愚人节版" Version("id") = "20w14∞" Version("type") = "special" Version.Add("lore", GetMcFoolName(Version("id"))) - Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b", "24w14potato", "25w14craftmine" + Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b", "24w14potato", "25w14craftmine", "26w14a" Type = "愚人节版" Version("type") = "special" Version.Add("lore", GetMcFoolName(Version("id"))) @@ -618,16 +499,16 @@ PanMinecraft.Children.Clear() '添加最新版本 Dim CardInfo As New MyCard With {.Title = "最新版本", .Margin = New Thickness(0, 15, 0, 15), .SwapType = 2} - Dim TopestVersions As New List(Of JObject) + Dim PinnedVersions As New List(Of JObject) Dim Release As JObject = Dict("正式版")(0).DeepClone() Release("lore") = "最新正式版，发布于 " & Release("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Release) + PinnedVersions.Add(Release) If Dict("正式版")(0)("releaseTime").Value(Of Date) < Dict("预览版")(0)("releaseTime").Value(Of Date) Then Dim Snapshot As JObject = Dict("预览版")(0).DeepClone() Snapshot("lore") = "最新预览版，发布于 " & Snapshot("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Snapshot) + PinnedVersions.Add(Snapshot) End If - Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = TopestVersions} + Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = PinnedVersions} MyCard.StackInstall(PanInfo, 7) CardInfo.Children.Add(PanInfo) PanMinecraft.Children.Insert(0, CardInfo) @@ -635,20 +516,20 @@ For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict If Not Pair.Value.Any() Then Continue For '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 7} + Dim NewCard As New MyCard With {.Title = Pair.Key, .Margin = New Thickness(0, 0, 0, 15), .SwapType = 7} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} NewCard.Children.Add(NewStack) NewCard.SwapControl = NewStack - NewCard.IsSwaped = True + NewCard.IsSwapped = True PanMinecraft.Children.Add(NewCard) Next '自动选择版本 - If McVersionWaitingForSelect Is Nothing Then Exit Try - Log("[Download] 自动选择 MC 版本：" & McVersionWaitingForSelect) + If VersionWaitingSelect Is Nothing Then Exit Try + Log("[Download] 自动选择 MC 版本：" & VersionWaitingSelect) For Each Version As JObject In Versions - If Version("id").ToString <> McVersionWaitingForSelect Then Continue For + If Version("id").ToString <> VersionWaitingSelect Then Continue For Dim Item = McDownloadListItem(Version, Sub() - End Sub, False) + End Sub, False).Init() MinecraftSelected(Item, Nothing) Next Catch ex As Exception @@ -658,7 +539,7 @@ ''' ''' 当 MC 版本列表加载完时，立即自动选择的版本。用于外部调用。 ''' - Public Shared McVersionWaitingForSelect As String = Nothing + Public Shared VersionWaitingSelect As String = Nothing #End Region @@ -669,25 +550,30 @@ ''' Private Function LoadOptiFineGetError() As String If SelectedNeoForge IsNot Nothing Then Return "与 NeoForge 不兼容" - If LoadOptiFine Is Nothing OrElse LoadOptiFine.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadOptiFine.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadOptiFine.State, Object).Error.Message '检查 Forge 1.13 - 1.14.3：全部不兼容 If SelectedForge IsNot Nothing AndAlso - VersionSortInteger(SelectedMinecraftId, "1.13") >= 0 AndAlso VersionSortInteger("1.14.3", SelectedMinecraftId) >= 0 Then + CompareVersion(VanillaName, "1.13") >= 0 AndAlso CompareVersion("1.14.3", VanillaName) >= 0 Then Return "与 Forge 不兼容" End If + '检查 Fabric 1.20.5+：全部不兼容 + If SelectedFabric IsNot Nothing AndAlso + CompareVersion(VanillaName, "1.20.4") > 0 Then + Return "与 Fabric 不兼容" + End If + '检查 Loader + If GetLoaderError(LoadOptiFine) IsNot Nothing Then Return GetLoaderError(LoadOptiFine) '检查 Forge 版本 Dim HasAny As Boolean = False Dim HasRequiredVersion As Boolean = False For Each OptiFineVersion As DlOptiFineListEntry In DlOptiFineListLoader.Output.Value - If Not OptiFineVersion.NameDisplay.StartsWith(SelectedMinecraftId & " ") Then Continue For '不是同一个大版本 + If Not OptiFineVersion.DisplayName.StartsWithF(VanillaName & " ") Then Continue For '不是同一个大版本 HasAny = True If SelectedForge Is Nothing Then Return Nothing '未选择 Forge If IsOptiFineSuitForForge(OptiFineVersion, SelectedForge) Then Return Nothing '该版本可用 If OptiFineVersion.RequiredForgeVersion IsNot Nothing Then HasRequiredVersion = True Next If Not HasAny Then - Return "不可用" + Return "无" ElseIf HasRequiredVersion Then Return "仅兼容特定版本的 Forge" Else @@ -701,7 +587,7 @@ If OptiFine.RequiredForgeVersion Is Nothing Then Return False '不兼容 Forge If String.IsNullOrWhiteSpace(OptiFine.RequiredForgeVersion) Then Return True '#4183 If OptiFine.RequiredForgeVersion.Contains(".") Then 'XX.X.XXX - Return VersionSortInteger(Forge.Version.ToString, OptiFine.RequiredForgeVersion) = 0 + Return CompareVersion(Forge.Version.ToString, OptiFine.RequiredForgeVersion) = 0 Else 'XXXX Return Forge.Version.Revision = OptiFine.RequiredForgeVersion End If @@ -723,15 +609,15 @@ Dim Versions As New List(Of DlOptiFineListEntry) For Each Version As DlOptiFineListEntry In DlOptiFineListLoader.Output.Value If SelectedForge IsNot Nothing AndAlso Not IsOptiFineSuitForForge(Version, SelectedForge) Then Continue For - If Version.NameDisplay.StartsWith(SelectedMinecraftId & " ") Then Versions.Add(Version) + If Version.DisplayName.StartsWithF(VanillaName & " ") Then Versions.Add(Version) Next If Not Versions.Any() Then Return '排序 - Versions = Versions.Sort( + Versions = Versions.SortByComparison( Function(Left As DlOptiFineListEntry, Right As DlOptiFineListEntry) As Boolean If Not Left.IsPreview AndAlso Right.IsPreview Then Return True If Left.IsPreview AndAlso Not Right.IsPreview Then Return False - Return VersionSortBoolean(Left.NameDisplay, Right.NameDisplay) + Return CompareVersionGE(Left.DisplayName, Right.DisplayName) End Function) '可视化 PanOptiFine.Children.Clear() @@ -750,18 +636,18 @@ OptiFabric_Loaded() Forge_Loaded() NeoForge_Loaded() - CardOptiFine.IsSwaped = True - SelectReload() + CardOptiFine.IsSwapped = True + ReloadSelected() End Sub Private Sub OptiFine_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFineClear.MouseLeftButtonUp SelectedOptiFine = Nothing SelectedOptiFabric = Nothing AutoSelectedOptiFabric = False - CardOptiFine.IsSwaped = True + CardOptiFine.IsSwapped = True e.Handled = True Forge_Loaded() NeoForge_Loaded() - SelectReload() + ReloadSelected() End Sub #End Region @@ -772,13 +658,10 @@ ''' 获取 LiteLoader 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadLiteLoaderGetError() As String - If Not SelectedMinecraftId.Contains("1.") OrElse Val(SelectedMinecraftId.Split(".")(1)) > 12 Then Return "不可用" - If LoadLiteLoader Is Nothing OrElse LoadLiteLoader.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadLiteLoader.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadLiteLoader.State, Object).Error.Message - For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value - If Version.Inherit = SelectedMinecraftId Then Return Nothing - Next - Return "不可用" + '检查 Loader + If GetLoaderError(LoadLiteLoader) IsNot Nothing Then Return GetLoaderError(LoadLiteLoader) + '检查版本 + Return If(DlLiteLoaderListLoader.Output.Value.Any(Function(v) v.Inherit = VanillaName), Nothing, "无") End Function '限制展开 @@ -795,7 +678,7 @@ '获取版本列表 Dim Versions As New List(Of DlLiteLoaderListEntry) For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value - If Version.Inherit = SelectedMinecraftId Then Versions.Add(Version) + If Version.Inherit = VanillaName Then Versions.Add(Version) Next If Not Versions.Any() Then Return '可视化 @@ -811,14 +694,14 @@ '选择与清除 Private Sub LiteLoader_Selected(sender As MyListItem, e As EventArgs) SelectedLiteLoader = sender.Tag - CardLiteLoader.IsSwaped = True - SelectReload() + CardLiteLoader.IsSwapped = True + ReloadSelected() End Sub Private Sub LiteLoader_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnLiteLoaderClear.MouseLeftButtonUp SelectedLiteLoader = Nothing - CardLiteLoader.IsSwaped = True + CardLiteLoader.IsSwapped = True e.Handled = True - SelectReload() + ReloadSelected() End Sub #End Region @@ -829,36 +712,24 @@ ''' 获取 Forge 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadForgeGetError() As String - If Not SelectedMinecraftId.StartsWith("1.") Then Return "不可用" - If Not LoadForge.State.IsLoader Then Return "加载中……" + If CompareVersionGE("1.5.1", VanillaName) AndAlso CompareVersionGE(VanillaName, "1.1") Then Return "无" + '检查 Loader + If GetLoaderError(LoadForge) IsNot Nothing Then Return GetLoaderError(LoadForge) Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = LoadForge.State - If SelectedMinecraftId <> Loader.Input Then Return "加载中……" - If Loader.State = LoadState.Loading Then Return "加载中……" - If Loader.State = LoadState.Failed Then - Dim ErrorMessage As String = Loader.Error.Message - If ErrorMessage.Contains("不可用") Then - Return "不可用" - Else - Return "获取版本列表失败：" & ErrorMessage - End If - End If - If Loader.State <> LoadState.Finished Then Return "获取版本列表失败：未知错误，状态为 " & GetStringFromEnum(Loader.State) - Dim NotSuitForOptiFine As Boolean = False + If VanillaName <> Loader.Input Then Return "获取中……" + '检查版本 For Each Version In Loader.Output If Version.Category = "universal" OrElse Version.Category = "client" Then Continue For '跳过无法自动安装的版本 If SelectedNeoForge IsNot Nothing Then Return "与 NeoForge 不兼容" If SelectedFabric IsNot Nothing Then Return "与 Fabric 不兼容" If SelectedOptiFine IsNot Nothing AndAlso - VersionSortInteger(SelectedMinecraftId, "1.13") >= 0 AndAlso VersionSortInteger("1.14.3", SelectedMinecraftId) >= 0 Then + CompareVersionGE(VanillaName, "1.13") AndAlso CompareVersionGE("1.14.3", VanillaName) Then Return "与 OptiFine 不兼容" '1.13 ~ 1.14.3 OptiFine 检查 End If - If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, Version) Then - NotSuitForOptiFine = True '与 OptiFine 不兼容 - Continue For - End If + If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, Version) Then Continue For Return Nothing Next - Return If(NotSuitForOptiFine, "与 OptiFine 不兼容", "该版本不支持自动安装") + Return "与 OptiFine 不兼容" End Function '限制展开 @@ -873,7 +744,7 @@ Try If Not LoadForge.State.IsLoader Then Return Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = LoadForge.State - If SelectedMinecraftId <> Loader.Input Then Return + If VanillaName <> Loader.Input Then Return If Loader.State <> LoadState.Finished Then Return '获取要显示的版本 Dim Versions = Loader.Output.ToList '复制数组，以免 Output 在实例化后变空 @@ -884,7 +755,7 @@ If v.Category = "universal" OrElse v.Category = "client" Then Return False '跳过无法自动安装的版本 If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, v) Then Return False Return True - End Function).OrderByDescending(Function(v) v.Version).ToList() + End Function).OrderByDescending(Function(v) v).ToList() ForgeDownloadListItemPreload(PanForge, Versions, AddressOf Forge_Selected, False) For Each Version In Versions PanForge.Children.Add(ForgeDownloadListItem(Version, AddressOf Forge_Selected, False)) @@ -897,17 +768,17 @@ '选择与清除 Private Sub Forge_Selected(sender As MyListItem, e As EventArgs) SelectedForge = sender.Tag - CardForge.IsSwaped = True + CardForge.IsSwapped = True If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, SelectedForge) Then SelectedOptiFine = Nothing OptiFine_Loaded() - SelectReload() + ReloadSelected() End Sub Private Sub Forge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnForgeClear.MouseLeftButtonUp SelectedForge = Nothing - CardForge.IsSwaped = True + CardForge.IsSwapped = True e.Handled = True OptiFine_Loaded() - SelectReload() + ReloadSelected() End Sub #End Region @@ -918,17 +789,13 @@ ''' 获取 NeoForge 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadNeoForgeGetError() As String - If Not SelectedMinecraftId.StartsWith("1.") Then Return "不可用" If SelectedOptiFine IsNot Nothing Then Return "与 OptiFine 不兼容" If SelectedForge IsNot Nothing Then Return "与 Forge 不兼容" If SelectedFabric IsNot Nothing Then Return "与 Fabric 不兼容" - If LoadNeoForge Is Nothing OrElse LoadNeoForge.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadNeoForge.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadNeoForge.State, Object).Error.Message - If DlNeoForgeListLoader.Output.Value.Any(Function(v) v.Inherit = SelectedMinecraftId) Then - Return Nothing - Else - Return "不可用" - End If + '检查 Loader + If GetLoaderError(LoadNeoForge) IsNot Nothing Then Return GetLoaderError(LoadNeoForge) + '检查版本 + Return If(DlNeoForgeListLoader.Output.Value.Any(Function(v) v.Inherit = VanillaName), Nothing, "无") End Function '限制展开 @@ -943,7 +810,7 @@ Try '获取版本列表 If DlNeoForgeListLoader.State <> LoadState.Finished Then Return - Dim Versions = DlNeoForgeListLoader.Output.Value.Where(Function(v) v.Inherit = SelectedMinecraftId).ToList + Dim Versions = DlNeoForgeListLoader.Output.Value.Where(Function(v) v.Inherit = VanillaName).ToList If Not Versions.Any() Then Return '可视化 PanNeoForge.Children.Clear() @@ -959,16 +826,16 @@ '选择与清除 Private Sub NeoForge_Selected(sender As MyListItem, e As EventArgs) SelectedNeoForge = sender.Tag - CardNeoForge.IsSwaped = True + CardNeoForge.IsSwapped = True OptiFine_Loaded() - SelectReload() + ReloadSelected() End Sub Private Sub NeoForge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnNeoForgeClear.MouseLeftButtonUp SelectedNeoForge = Nothing - CardNeoForge.IsSwaped = True + CardNeoForge.IsSwapped = True e.Handled = True OptiFine_Loaded() - SelectReload() + ReloadSelected() End Sub #End Region @@ -979,16 +846,19 @@ ''' 获取 Fabric 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadFabricGetError() As String - If LoadFabric Is Nothing OrElse LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadFabric.State, Object).Error.Message + '检查 OptiFine 1.20.5+：没有 OptiFabric 故全部不兼容 + If SelectedOptiFine IsNot Nothing AndAlso CompareVersionGE(VanillaName, "1.20.5") Then Return "与 OptiFine 不兼容" + '检查 Loader + If GetLoaderError(LoadFabric) IsNot Nothing Then Return GetLoaderError(LoadFabric) + '检查版本 For Each Version As JObject In DlFabricListLoader.Output.Value("game") - If Version("version").ToString = SelectedMinecraftId.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3") Then + If Version("version").ToString = VanillaName.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3") Then If SelectedForge IsNot Nothing Then Return "与 Forge 不兼容" If SelectedNeoForge IsNot Nothing Then Return "与 NeoForge 不兼容" Return Nothing End If Next - Return "不可用" + Return "无" End Function '限制展开 @@ -1020,8 +890,8 @@ SelectedFabric = sender.Tag("version").ToString FabricApi_Loaded() OptiFabric_Loaded() - CardFabric.IsSwaped = True - SelectReload() + CardFabric.IsSwapped = True + ReloadSelected() End Sub Private Sub Fabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricClear.MouseLeftButtonUp SelectedFabric = Nothing @@ -1029,9 +899,9 @@ AutoSelectedFabricApi = False SelectedOptiFabric = Nothing AutoSelectedOptiFabric = False - CardFabric.IsSwaped = True + CardFabric.IsSwapped = True e.Handled = True - SelectReload() + ReloadSelected() End Sub #End Region @@ -1039,21 +909,23 @@ #Region "Fabric API 列表" ''' - ''' 从显示名判断该 API 是否与某版本适配。 + ''' 判断某 Fabric API 是否适配当前选择的原版版本。 ''' - Public Shared Function IsSuitableFabricApi(DisplayName As String, MinecraftVersion As String) As Boolean + Public Function IsFabricApiCompatible(FabricApi As CompFile) As Boolean + Dim FabricApiName = FabricApi.DisplayName Try - If DisplayName Is Nothing OrElse MinecraftVersion Is Nothing Then Return False - DisplayName = DisplayName.ToLower : MinecraftVersion = MinecraftVersion.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3").ToLower - If DisplayName.StartsWith("[" & MinecraftVersion & "]") Then Return True - If Not DisplayName.Contains("/") OrElse Not DisplayName.Contains("]") Then Return False + If FabricApiName Is Nothing OrElse VanillaName Is Nothing Then Return False + FabricApiName = FabricApiName.Lower + Dim TargetName = VanillaName.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3").Lower + If FabricApiName.StartsWithF("[" & TargetName & "]") Then Return True + If Not FabricApiName.Contains("/") OrElse Not FabricApiName.Contains("]") Then Return False '直接的判断（例如 1.18.1/22w03a） - For Each Part As String In DisplayName.BeforeFirst("]").TrimStart("[").Split("/") - If Part = MinecraftVersion Then Return True + For Each Part As String In FabricApiName.BeforeFirst("]").TrimStart("[").Split("/") + If Part = TargetName Then Return True Next '将版本名分割语素（例如 1.16.4/5） - Dim Lefts = RegexSearch(DisplayName.BeforeFirst("]"), "[a-z/]+|[0-9/]+") - Dim Rights = RegexSearch(MinecraftVersion.BeforeFirst("]"), "[a-z/]+|[0-9/]+") + Dim Lefts = RegexSearch(FabricApiName.BeforeFirst("]"), "[a-z/]+|[0-9/]+") + Dim Rights = RegexSearch(TargetName.BeforeFirst("]"), "[a-z/]+|[0-9/]+") '对每段进行判断 Dim i As Integer = 0 While True @@ -1072,7 +944,7 @@ End While Return True Catch ex As Exception - Log(ex, "判断 Fabric API 版本适配性出错（" & DisplayName & ", " & MinecraftVersion & "）") + Log(ex, "判断 Fabric API 版本适配性出错（" & FabricApiName & ", " & VanillaName & "）") Return False End Try End Function @@ -1081,18 +953,15 @@ ''' 获取 FabricApi 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadFabricApiGetError() As String - If LoadFabricApi Is Nothing OrElse LoadFabricApi.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadFabricApi.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadFabricApi.State, Object).Error.Message - If DlFabricApiLoader.Output Is Nothing Then - If SelectedFabric Is Nothing Then Return "需要安装 Fabric" - Return "加载中……" + '检查 Loader + If GetLoaderError(LoadFabricApi) IsNot Nothing Then Return GetLoaderError(LoadFabricApi) + If DlFabricApiLoader.Output Is Nothing Then Return If(SelectedFabric Is Nothing, "需要安装 Fabric", "获取中……") + '检查版本 + If DlFabricApiLoader.Output.Any(Function(f) IsFabricApiCompatible(f)) Then + Return If(SelectedFabric Is Nothing, "需要安装 Fabric", Nothing) + Else + Return "无" End If - For Each Version In DlFabricApiLoader.Output - If Not IsSuitableFabricApi(Version.DisplayName, SelectedMinecraftId) Then Continue For - If SelectedFabric Is Nothing Then Return "需要安装 Fabric" - Return Nothing - Next - Return "不可用" End Function '限制展开 @@ -1107,14 +976,14 @@ Private Sub FabricApi_Loaded() Handles LoadFabricApi.StateChanged Try If DlFabricApiLoader.State <> LoadState.Finished Then Return - If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing Then Return + If VanillaName Is Nothing OrElse SelectedFabric Is Nothing Then Return '获取版本列表 Dim Versions As New List(Of CompFile) For Each Version In DlFabricApiLoader.Output - If IsSuitableFabricApi(Version.DisplayName, SelectedMinecraftId) Then - If Not Version.DisplayName.StartsWith("[") Then + If IsFabricApiCompatible(Version) Then + If Not Version.DisplayName.StartsWithF("[") Then Log("[Download] 已特判修改 Fabric API 显示名：" & Version.DisplayName, LogLevel.Debug) - Version.DisplayName = "[" & SelectedMinecraftId & "] " & Version.DisplayName + Version.DisplayName = "[" & VanillaName & "] " & Version.DisplayName End If Versions.Add(Version) End If @@ -1124,14 +993,15 @@ '可视化 PanFabricApi.Children.Clear() For Each Version In Versions - If Not IsSuitableFabricApi(Version.DisplayName, SelectedMinecraftId) Then Continue For + If Not IsFabricApiCompatible(Version) Then Continue For PanFabricApi.Children.Add(FabricApiDownloadListItem(Version, AddressOf FabricApi_Selected)) Next '自动选择 Fabric API If Not AutoSelectedFabricApi Then AutoSelectedFabricApi = True - Log($"[Download] 已自动选择 Fabric API：{CType(PanFabricApi.Children(0), MyListItem).Title}") - FabricApi_Selected(PanFabricApi.Children(0), Nothing) + Dim Item As MyListItem = MyVirtualizingElement.TryInit(PanFabricApi.Children(0)) + Log($"[Download] 已自动选择 Fabric API：{Item.Title}") + FabricApi_Selected(Item, Nothing) End If Catch ex As Exception Log(ex, "可视化 Fabric API 安装版本列表出错", LogLevel.Feedback) @@ -1141,14 +1011,14 @@ '选择与清除 Private Sub FabricApi_Selected(sender As MyListItem, e As EventArgs) SelectedFabricApi = sender.Tag - CardFabricApi.IsSwaped = True - SelectReload() + CardFabricApi.IsSwapped = True + ReloadSelected() End Sub Private Sub FabricApi_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricApiClear.MouseLeftButtonUp SelectedFabricApi = Nothing - CardFabricApi.IsSwaped = True + CardFabricApi.IsSwapped = True e.Handled = True - SelectReload() + ReloadSelected() End Sub #End Region @@ -1156,14 +1026,14 @@ #Region "OptiFabric 列表" ''' - ''' 从显示名判断该 Mod 是否与某版本适配。 + ''' 判断某 OptiFabric 是否适配当前选择的原版版本。 ''' - Private Function IsSuitableOptiFabric(ModFile As CompFile, MinecraftVersion As String) As Boolean + Private Function IsOptiFabricCompatible(ModFile As CompFile) As Boolean Try - If MinecraftVersion Is Nothing Then Return False - Return ModFile.GameVersions.Contains(MinecraftVersion) + If VanillaName Is Nothing Then Return False + Return ModFile.GameVersions.Contains(VanillaName) Catch ex As Exception - Log(ex, "判断 OptiFabric 版本适配性出错（" & MinecraftVersion & "）") + Log(ex, "判断 OptiFabric 版本适配性出错（" & VanillaName & "）") Return False End Try End Function @@ -1173,23 +1043,24 @@ ''' 获取 OptiFabric 的加载异常信息。若正常则返回 Nothing。 ''' Private Function LoadOptiFabricGetError() As String - If SelectedMinecraftId.StartsWith("1.14") OrElse SelectedMinecraftId.StartsWith("1.15") Then Return "不兼容老版本 Fabric，请手动下载 OptiFabric Origins" - If LoadOptiFabric Is Nothing OrElse LoadOptiFabric.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" - If LoadOptiFabric.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败：" & CType(LoadOptiFabric.State, Object).Error.Message + If VanillaDrop >= 140 AndAlso VanillaDrop <= 150 Then Return "不兼容老版本 Fabric，请手动下载 OptiFabric Origins" + '检查 Loader + If GetLoaderError(LoadOptiFabric) IsNot Nothing Then Return GetLoaderError(LoadOptiFabric) + '检查版本 If DlOptiFabricLoader.Output Is Nothing Then If SelectedFabric Is Nothing AndAlso SelectedOptiFine Is Nothing Then Return "需要安装 OptiFine 与 Fabric" If SelectedFabric Is Nothing Then Return "需要安装 Fabric" If SelectedOptiFine Is Nothing Then Return "需要安装 OptiFine" - Return "加载中……" + Return "获取中……" End If For Each Version In DlOptiFabricLoader.Output - If Not IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Continue For '2135# + If Not IsOptiFabricCompatible(Version) Then Continue For '2135# If SelectedFabric Is Nothing AndAlso SelectedOptiFine Is Nothing Then Return "需要安装 OptiFine 与 Fabric" If SelectedFabric Is Nothing Then Return "需要安装 Fabric" If SelectedOptiFine Is Nothing Then Return "需要安装 OptiFine" Return Nothing '通过检查 Next - Return "不可用" + Return "无" End Function '限制展开 @@ -1203,11 +1074,11 @@ Private Sub OptiFabric_Loaded() Handles LoadOptiFabric.StateChanged Try If DlOptiFabricLoader.State <> LoadState.Finished Then Return - If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing OrElse SelectedOptiFine Is Nothing Then Return + If VanillaName Is Nothing OrElse SelectedFabric Is Nothing OrElse SelectedOptiFine Is Nothing Then Return '获取版本列表 Dim Versions As New List(Of CompFile) For Each Version In DlOptiFabricLoader.Output - If IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Versions.Add(Version) + If IsOptiFabricCompatible(Version) Then Versions.Add(Version) Next If Not Versions.Any() Then Return '排序 @@ -1215,16 +1086,15 @@ '可视化 PanOptiFabric.Children.Clear() For Each Version In Versions - If Not IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Continue For + If Not IsOptiFabricCompatible(Version) Then Continue For PanOptiFabric.Children.Add(OptiFabricDownloadListItem(Version, AddressOf OptiFabric_Selected)) Next '自动选择 OptiFabric - If Not AutoSelectedOptiFabric AndAlso - Not (SelectedMinecraftId.StartsWith("1.14") OrElse SelectedMinecraftId.StartsWith("1.15")) Then '1.14~15 不自动选择 - AutoSelectedOptiFabric = True - Log($"[Download] 已自动选择 OptiFabric：{CType(PanOptiFabric.Children(0), MyListItem).Title}") - OptiFabric_Selected(PanOptiFabric.Children(0), Nothing) - End If + If AutoSelectedOptiFabric OrElse VanillaDrop >= 140 AndAlso VanillaDrop <= 150 Then Return '1.14~15 不自动选择 + AutoSelectedOptiFabric = True + Dim Item As MyListItem = MyVirtualizingElement.TryInit(PanOptiFabric.Children(0)) + Log($"[Download] 已自动选择 OptiFabric：{Item.Title}") + OptiFabric_Selected(Item, Nothing) Catch ex As Exception Log(ex, "可视化 OptiFabric 安装版本列表出错", LogLevel.Feedback) End Try @@ -1233,14 +1103,14 @@ '选择与清除 Private Sub OptiFabric_Selected(sender As MyListItem, e As EventArgs) SelectedOptiFabric = sender.Tag - CardOptiFabric.IsSwaped = True - SelectReload() + CardOptiFabric.IsSwapped = True + ReloadSelected() End Sub Private Sub OptiFabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFabricClear.MouseLeftButtonUp SelectedOptiFabric = Nothing - CardOptiFabric.IsSwaped = True + CardOptiFabric.IsSwapped = True e.Handled = True - SelectReload() + ReloadSelected() End Sub #End Region @@ -1253,7 +1123,7 @@ Private Sub BtnStart_Click() Handles BtnStart.Click '确认版本隔离 If (SelectedForge IsNot Nothing OrElse SelectedNeoForge IsNot Nothing OrElse SelectedFabric IsNot Nothing) AndAlso - (Setup.Get("LaunchArgumentIndieV2") = 0 OrElse Setup.Get("LaunchArgumentIndieV2") = 2) Then + (Settings.Get("LaunchArgumentIndieV2") = 0 OrElse Settings.Get("LaunchArgumentIndieV2") = 2) Then If MyMsgBox("你尚未开启版本隔离，多个 MC 版本会共用同一个 Mod 文件夹。" & vbCrLf & "因此，游戏可能会因为读取到与当前版本不符的 Mod 而崩溃。" & vbCrLf & "推荐先在 设置 → 启动选项 → 默认版本隔离 中开启版本隔离！", "版本隔离提示", "取消下载", "继续") = 1 Then @@ -1261,12 +1131,12 @@ End If End If '提交安装申请 - Dim VersionName As String = TextSelectName.Text + Dim InstanceName As String = TextSelectName.Text Dim Request As New McInstallRequest With { - .TargetVersionName = VersionName, - .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\", - .MinecraftJson = SelectedMinecraftJsonUrl, - .MinecraftName = SelectedMinecraftId, + .NewInstanceName = InstanceName, + .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\", + .MinecraftJson = VanillaData("url").ToString, + .MinecraftName = VanillaName, .OptiFineEntry = SelectedOptiFine, .ForgeEntry = SelectedForge, .NeoForgeEntry = SelectedNeoForge, @@ -1282,4 +1152,20 @@ #End Region + Private Function GetLoaderError(Loader As MyLoading) As String + If Loader Is Nothing Then Return "获取中……" + If Not Loader.State.IsLoader Then Return "获取中……" + Select Case Loader.State.LoadingState + Case MyLoading.MyLoadingState.Run + Return "获取中……" + Case MyLoading.MyLoadingState.Error + Dim Message As String = CType(Loader.State, LoaderBase).Error.Message + Return If(Message = "无", "无", "获取失败：" & Message) + Case MyLoading.MyLoadingState.Unloaded + Return "未知错误，状态为 Unloaded" + Case Else + Return Nothing + End Select + End Function + End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml index ae788bc..6d85387 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml @@ -1,114 +1,59 @@  + xmlns:local="clr-namespace:PCL" AnimatedControl="PanItem"> - - + - + - - - - + + + + + + + + + + + + + + + + - - + - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb index b63590b..7c02f25 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb @@ -11,7 +11,7 @@ ''' ''' 勾选事件改变页面。 ''' - Private Sub PageCheck(sender As MyListItem, e As RouteEventArgs) Handles ItemInstall.Check, ItemClient.Check, ItemOptiFine.Check, ItemForge.Check, ItemNeoForge.Check, ItemLiteLoader.Check, ItemMod.Check, ItemFabric.Check, ItemPack.Check, ItemResourcePack.Check, ItemShader.Check, ItemDataPack.Check + Private Sub PageCheck(sender As FrameworkElement, e As RouteEventArgs) Handles ItemInstall.Check, ItemMod.Check, ItemPack.Check, ItemResourcePack.Check, ItemShader.Check, ItemDataPack.Check '尚未初始化控件属性时，sender.Tag 为 Nothing，会导致切换到页面 0 '若使用 IsLoaded，则会导致模拟点击不被执行（模拟点击切换页面时，控件的 IsLoaded 为 False） If sender.Tag IsNot Nothing Then PageChange(Val(sender.Tag)) @@ -23,24 +23,6 @@ Case FormMain.PageSubType.DownloadInstall If FrmDownloadInstall Is Nothing Then FrmDownloadInstall = New PageDownloadInstall Return FrmDownloadInstall - Case FormMain.PageSubType.DownloadClient - If FrmDownloadClient Is Nothing Then FrmDownloadClient = New PageDownloadClient - Return FrmDownloadClient - Case FormMain.PageSubType.DownloadOptiFine - If FrmDownloadOptiFine Is Nothing Then FrmDownloadOptiFine = New PageDownloadOptiFine - Return FrmDownloadOptiFine - Case FormMain.PageSubType.DownloadForge - If FrmDownloadForge Is Nothing Then FrmDownloadForge = New PageDownloadForge - Return FrmDownloadForge - Case FormMain.PageSubType.DownloadNeoForge - If FrmDownloadNeoForge Is Nothing Then FrmDownloadNeoForge = New PageDownloadNeoForge - Return FrmDownloadNeoForge - Case FormMain.PageSubType.DownloadLiteLoader - If FrmDownloadLiteLoader Is Nothing Then FrmDownloadLiteLoader = New PageDownloadLiteLoader - Return FrmDownloadLiteLoader - Case FormMain.PageSubType.DownloadFabric - If FrmDownloadFabric Is Nothing Then FrmDownloadFabric = New PageDownloadFabric - Return FrmDownloadFabric Case FormMain.PageSubType.DownloadMod If FrmDownloadMod Is Nothing Then FrmDownloadMod = New PageDownloadMod Return FrmDownloadMod @@ -163,24 +145,6 @@ FrmDownloadDataPack.PageLoaderRestart() End If ItemDataPack.Checked = True - Case FormMain.PageSubType.DownloadClient - DlClientListLoader.Start(IsForceRestart:=True) - ItemClient.Checked = True - Case FormMain.PageSubType.DownloadOptiFine - DlOptiFineListLoader.Start(IsForceRestart:=True) - ItemOptiFine.Checked = True - Case FormMain.PageSubType.DownloadForge - DlForgeListLoader.Start(IsForceRestart:=True) - ItemForge.Checked = True - Case FormMain.PageSubType.DownloadNeoForge - DlNeoForgeListLoader.Start(IsForceRestart:=True) - ItemNeoForge.Checked = True - Case FormMain.PageSubType.DownloadLiteLoader - DlLiteLoaderListLoader.Start(IsForceRestart:=True) - ItemLiteLoader.Checked = True - Case FormMain.PageSubType.DownloadFabric - DlFabricListLoader.Start(IsForceRestart:=True) - ItemFabric.Checked = True End Select Hint("正在刷新……", Log:=False) End Sub @@ -191,55 +155,4 @@ FrmDownloadInstall.ExitSelectPage() End Sub - '展开手动安装 - Private Sub ItemHand_Click(sender As Object, e As RouteEventArgs) Handles ItemHand.Changed - If ItemHand.Checked = False Then Return - e.Handled = True - AniControlEnabled += 1 - If Not Setup.Get("HintHandInstall") Then - Setup.Set("HintHandInstall", True) - If MyMsgBox("手动安装包功能提供了 OptiFine、Forge 等组件的 .jar 安装文件下载，但无法自动安装。" & vbCrLf & - "在自动安装页面先选择 MC 版本，然后就可以选择 OptiFine、Forge 等组件，让 PCL 自动进行安装了。", "自动安装提示", "返回自动安装", "继续下载手动安装包") = 1 Then - FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.Download}, FormMain.PageSubType.DownloadInstall) - AniControlEnabled -= 1 - Return - End If - End If - ItemHand.Visibility = Visibility.Collapsed - LabGame.Visibility = Visibility.Collapsed - LabHand.Visibility = Visibility.Visible - ItemClient.Visibility = Visibility.Visible - ItemOptiFine.Visibility = Visibility.Visible - ItemFabric.Visibility = Visibility.Visible - ItemForge.Visibility = Visibility.Visible - ItemNeoForge.Visibility = Visibility.Visible - ItemLiteLoader.Visibility = Visibility.Visible - RunInThread( - Sub() - Thread.Sleep(20) - RunInUiWait(Sub() ItemClient.SetChecked(True, True, True)) - AniControlEnabled -= 1 - End Sub) - End Sub - '折叠手动安装 - Private Sub LabHand_Click(sender As Object, e As MouseButtonEventArgs) Handles LabHand.MouseLeftButtonUp - e.Handled = True - AniControlEnabled += 1 - ItemHand.Visibility = Visibility.Visible - LabGame.Visibility = Visibility.Visible - LabHand.Visibility = Visibility.Collapsed - ItemClient.Visibility = Visibility.Collapsed - ItemOptiFine.Visibility = Visibility.Collapsed - ItemNeoForge.Visibility = Visibility.Collapsed - ItemFabric.Visibility = Visibility.Collapsed - ItemForge.Visibility = Visibility.Collapsed - ItemLiteLoader.Visibility = Visibility.Collapsed - RunInThread( - Sub() - Thread.Sleep(20) - RunInUiWait(Sub() ItemInstall.SetChecked(True, True, True)) - AniControlEnabled -= 1 - End Sub) - End Sub - End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml deleted file mode 100644 index 69c4db0..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb deleted file mode 100644 index ac18c47..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb +++ /dev/null @@ -1,52 +0,0 @@ -Public Class PageDownloadLiteLoader - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlLiteLoaderListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of DlLiteLoaderListEntry)) - For VersionCode As Integer = 30 To 0 Step -1 - Dict.Add("1." & VersionCode, New List(Of DlLiteLoaderListEntry)) - Next - Dict.Add("未知版本", New List(Of DlLiteLoaderListEntry)) - For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value - Dim MainVersion As String = "1." & Version.Inherit.Split(".")(1) - If Dict.ContainsKey(MainVersion) Then - Dict(MainVersion).Add(Version) - Else - Dict("未知版本").Add(Version) - End If - Next - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlLiteLoaderListEntry)) In Dict - If Not Pair.Value.Any() Then Continue For - '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 10} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwaped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 LiteLoader 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Public Sub DownloadStart(sender As MyListItem, e As Object) - McDownloadLiteLoader(sender.Tag) - End Sub - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.liteloader.com") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml deleted file mode 100644 index 886c343..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml +++ /dev/null @@ -1,27 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb deleted file mode 100644 index 064dda5..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb +++ /dev/null @@ -1,34 +0,0 @@ -Public Class PageDownloadNeoForge - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlNeoForgeListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict = DlNeoForgeListLoader.Output.Value.GroupBy(Function(d) d.Inherit).OrderByDescending(Function(g) g.Key). - ToDictionary(Function(g) g.Key, Function(g) g.ToList()) - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlNeoForgeListEntry)) In Dict - If Not Pair.Value.Any() Then Continue For - '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 13} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwaped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 NeoForge 版本列表出错", LogLevel.Feedback) - End Try - End Sub - -End Class \ No newline at end of file diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml deleted file mode 100644 index 1a08b51..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb deleted file mode 100644 index f843529..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb +++ /dev/null @@ -1,53 +0,0 @@ -Public Class PageDownloadOptiFine - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlOptiFineListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of DlOptiFineListEntry)) - Dict.Add("快照版本", New List(Of DlOptiFineListEntry)) - For VersionCode As Integer = 50 To 0 Step -1 - Dict.Add("1." & VersionCode, New List(Of DlOptiFineListEntry)) - Next - For Each Version As DlOptiFineListEntry In DlOptiFineListLoader.Output.Value - If Version.Inherit.StartsWith("1.") Then - Dim MainVersion As String = "1." & Version.NameDisplay.Split(".")(1).Split(" ")(0) - If Dict.ContainsKey(MainVersion) Then - Dict(MainVersion).Add(Version) - Else - Dict("快照版本").Add(Version) - End If - Else - Dict("快照版本").Add(Version) - End If - Next - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlOptiFineListEntry)) In Dict - If Not Pair.Value.Any() Then Continue For - '增加卡片 - Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 3} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwaped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 OptiFine 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.optifine.net/") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageVersion/MyLocalModItem.xaml b/Plain Craft Launcher 2/Pages/PageInstance/MyLocalModItem.xaml similarity index 100% rename from Plain Craft Launcher 2/Pages/PageVersion/MyLocalModItem.xaml rename to Plain Craft Launcher 2/Pages/PageInstance/MyLocalModItem.xaml diff --git a/Plain Craft Launcher 2/Pages/PageVersion/MyLocalModItem.xaml.vb b/Plain Craft Launcher 2/Pages/PageInstance/MyLocalModItem.xaml.vb similarity index 74% rename from Plain Craft Launcher 2/Pages/PageVersion/MyLocalModItem.xaml.vb rename to Plain Craft Launcher 2/Pages/PageInstance/MyLocalModItem.xaml.vb index 4ab3662..203d100 100644 --- a/Plain Craft Launcher 2/Pages/PageVersion/MyLocalModItem.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageInstance/MyLocalModItem.xaml.vb @@ -5,16 +5,6 @@ Public Class MyLocalModItem #Region "基础属性" Public Uuid As Integer = GetUuid() - 'Logo - Public Property Logo As String - Get - Return PathLogo.Source - End Get - Set(value As String) - PathLogo.Source = value - End Set - End Property - '标题 Private _Title As String Public Property Title As String @@ -28,9 +18,6 @@ Public Class MyLocalModItem LabTitle.TextDecorations = Nothing Case McMod.McModState.Disabled LabTitle.TextDecorations = TextDecorations.Strikethrough - Case McMod.McModState.Unavailable - LabTitle.TextDecorations = TextDecorations.Strikethrough - value &= " [错误]" End Select If LabTitle.Text = value Then Return LabTitle.Text = value @@ -63,17 +50,17 @@ Public Class MyLocalModItem 'Tag Public WriteOnly Property Tags As List(Of String) - Set(value As List(Of String)) + Set(Tags As List(Of String)) PanTags.Children.Clear() - PanTags.Visibility = If(value.Any(), Visibility.Visible, Visibility.Collapsed) - For Each TagText In value - Dim NewTag = GetObjectFromXML( - " - - ") - PanTags.Children.Add(NewTag) + PanTags.Visibility = If(Tags.Any(), Visibility.Visible, Visibility.Collapsed) + For Each TagText In Tags + Dim BorderTag As New Border With { + .Background = New MyColor("#0A000000"), .Padding = New Thickness(3, 1, 3, 1), .CornerRadius = New CornerRadius(3), + .Margin = New Thickness(0, 0, 3, 0), .SnapsToDevicePixels = True, .UseLayoutRounding = False} + Dim LabTag As New TextBlock With { + .Text = TagText, .Foreground = New MyColor("#B0B0B0"), .FontSize = 11} + BorderTag.Child = LabTag + PanTags.Children.Add(BorderTag) Next End Set End Property @@ -123,7 +110,7 @@ Public Class MyLocalModItem End Get Set(value As Boolean) _Swiping = value - FrmVersionMod.CardSelect.IsHitTestVisible = Not value + FrmInstanceMod.CardSelect.IsHitTestVisible = Not value End Set End Property Private Shared SwipToState As Boolean '被滑动到的目标应将 Checked 改为此值 @@ -313,11 +300,11 @@ Public Class MyLocalModItem #End Region Private Function GetUpdateCompareDescription() As String - Dim CurrentName = Entry.CompFile.FileName.Replace(".jar", "") - Dim NewestName = Entry.UpdateFile.FileName.Replace(".jar", "") + Dim CurrentName = If(Entry.CompFile.Version, Entry.CompFile.DisplayName).Replace(".jar", "") + Dim NewestName = If(Entry.UpdateFile.Version, Entry.UpdateFile.DisplayName).Replace(".jar", "") '简化名称对比 - Dim CurrentSegs = CurrentName.Split("-"c).ToList() - Dim NewestSegs = NewestName.Split("-"c).ToList() + Dim CurrentSegs = CurrentName.Split("-_+ ".ToCharArray).ToList() + Dim NewestSegs = NewestName.Split("-_+ ".ToCharArray).ToList() Dim Shortened As Boolean = False For Each Seg In CurrentSegs.ToList() If Not NewestSegs.Contains(Seg) Then Continue For @@ -326,101 +313,109 @@ Public Class MyLocalModItem Shortened = True Next If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then - CurrentName = Join(CurrentSegs, "-") - NewestName = Join(NewestSegs, "-") + CurrentName = CurrentSegs.Join("-") + NewestName = NewestSegs.Join("-") Entry._Version = CurrentName '使用网络信息作为显示的版本号 End If Return $"当前版本：{CurrentName}（{GetTimeSpanString(Entry.CompFile.ReleaseDate - Date.Now, False)}）{vbCrLf}最新版本：{NewestName}（{GetTimeSpanString(Entry.UpdateFile.ReleaseDate - Date.Now, False)}）" End Function - Public Sub Refresh() Handles Me.Loaded - RunInUi( - Sub() - '更新 - If Entry.CanUpdate Then - BtnUpdate.Visibility = Visibility.Visible - BtnUpdate.ToolTip = $"{GetUpdateCompareDescription()}{vbCrLf}点击以更新，右键查看更新日志。" + + '懒加载 + Public Sub New() + InitializeComponent() + LazyLoadBehavior.OnFirstEnterScrollViewerViewport(Me, AddressOf FirstEnterScrollViewerViewport) + End Sub + Private HasEnteredViewport As Boolean = False + Private Sub FirstEnterScrollViewerViewport() + HasEnteredViewport = True + Refresh() + End Sub + Public Sub Refresh() + If Not HasEnteredViewport Then Return '避免在未显示时因为 Comp 更新而加载内容 + '更新 + If Entry.CanUpdate Then + BtnUpdate.Visibility = Visibility.Visible + BtnUpdate.ToolTip = $"{GetUpdateCompareDescription()}{vbCrLf}点击以更新，右键查看更新日志。" + Else + BtnUpdate.Visibility = Visibility.Collapsed + End If + '标题与描述 + Dim DescFileName As String + If Entry.State = McMod.McModState.Fine OrElse Entry.State = McMod.McModState.Disabled Then + DescFileName = IO.Path.GetFileNameWithoutExtension(Entry.Path) + Else + DescFileName = GetFileNameFromPath(Entry.Path) + End If + Dim NewDescription As String + If Settings.Get("ToolModLocalNameStyle") = 1 Then + '标题显示文件名，详情显示译名 + '标题 + Title = DescFileName + SubTitle = "" + '描述 + If Entry.Comp Is Nothing Then + NewDescription = Entry.DisplayName Else - BtnUpdate.Visibility = Visibility.Collapsed + Dim Titles = Entry.Comp.GetControlTitle(False) + NewDescription = Titles.Title & Titles.SubTitle End If - '标题与描述 - Dim DescFileName As String - Select Case Entry.State - Case McMod.McModState.Fine - DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path) - Case McMod.McModState.Disabled - DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", "")) - Case Else 'McMod.McModState.Unavailable - DescFileName = GetFileNameFromPath(Entry.Path) - End Select - Dim NewDescription As String - If Setup.Get("ToolModLocalNameStyle") = 1 Then - '标题显示文件名，详情显示译名 - '标题 - Title = DescFileName - SubTitle = "" - '描述 - If Entry.Comp Is Nothing Then - NewDescription = Entry.Name - Else - Dim Titles = Entry.Comp.GetControlTitle(False) - NewDescription = Titles.Key & Titles.Value - End If - NewDescription = NewDescription.Replace(" | ", " / ") - If Entry.Version IsNot Nothing Then NewDescription &= $" ({Entry.Version})" + NewDescription = NewDescription.Replace(" | ", " / ") + If Entry.Version IsNot Nothing Then NewDescription &= $" ({Entry.Version})" + Else + '标题显示译名，详情显示文件名 + '标题 + If Entry.Comp Is Nothing Then + Title = Entry.DisplayName + SubTitle = If(Entry.Version Is Nothing, "", " | " & Entry.Version) Else - '标题显示译名，详情显示文件名 - '标题 - If Entry.Comp Is Nothing Then - Title = Entry.Name - SubTitle = If(Entry.Version Is Nothing, "", " | " & Entry.Version) - Else - Dim Titles = Entry.Comp.GetControlTitle(False) - Title = Titles.Key - SubTitle = Titles.Value & If(Entry.Version Is Nothing, "", " | " & Entry.Version) - End If - '描述 - NewDescription = DescFileName + Dim Titles = Entry.Comp.GetControlTitle(False) + Title = Titles.Title + SubTitle = Titles.SubTitle & If(Entry.Version Is Nothing, "", " | " & Entry.Version) End If - If Entry.Comp IsNot Nothing Then - NewDescription += ": " & Entry.Comp.Description.Replace(vbCr, "").Replace(vbLf, "") - ElseIf Entry.Description IsNot Nothing Then - NewDescription += ": " & Entry.Description.Replace(vbCr, "").Replace(vbLf, "") - ElseIf Not Entry.IsFileAvailable Then - NewDescription += ": " & "存在错误，无法获取信息" + '描述 + NewDescription = DescFileName + End If + If Entry.Comp IsNot Nothing Then + NewDescription += ": " & Entry.Comp.Description.Replace(vbCr, "").Replace(vbLf, "") + ElseIf Entry.Description IsNot Nothing Then + NewDescription += ": " & Entry.Description.Replace(vbCr, "").Replace(vbLf, "") + End If + Description = NewDescription + If Checked Then + LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5")) + Else + LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4")) + End If + '主 Logo + If Entry.Comp IsNot Nothing Then + Entry.Comp.ApplyLogoToMyImage(PathLogo) + Else + PathLogo.Source = PathImage & "Icons/NoIcon.png" + End If + '图标右下角的 Logo + If Entry.State = McMod.McModState.Fine Then + If ImgState IsNot Nothing Then + Children.Remove(ImgState) + ImgState = Nothing End If - Description = NewDescription - If Checked Then - LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5")) - Else - LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4")) + Else + If ImgState Is Nothing Then + ImgState = New Image With { + .Width = 20, .Height = 20, .Margin = New Thickness(0, 0, -5, -3), .IsHitTestVisible = False, + .HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Bottom + } + RenderOptions.SetBitmapScalingMode(ImgState, BitmapScalingMode.HighQuality) + SetColumn(ImgState, 1) : SetRow(ImgState, 1) : SetRowSpan(ImgState, 2) + Children.Add(ImgState) + ' End If - '主 Logo - Logo = If(Entry.Comp Is Nothing, PathImage & "Icons/NoIcon.png", Entry.Comp.GetControlLogo()) - '图标右下角的 Logo - If Entry.State = McMod.McModState.Fine Then - If ImgState IsNot Nothing Then - Children.Remove(ImgState) - ImgState = Nothing - End If - Else - If ImgState Is Nothing Then - ImgState = New Image With { - .Width = 20, .Height = 20, .Margin = New Thickness(0, 0, -5, -3), .IsHitTestVisible = False, - .HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Bottom - } - RenderOptions.SetBitmapScalingMode(ImgState, BitmapScalingMode.HighQuality) - SetColumn(ImgState, 1) : SetRow(ImgState, 1) : SetRowSpan(ImgState, 2) - Children.Add(ImgState) - ' - End If - ImgState.Source = New MyBitmap(PathImage & $"Icons/{Entry.State}.png") - End If - '标签 - If Entry.Comp IsNot Nothing Then Tags = Entry.Comp.Tags - End Sub) + ImgState.Source = New MyBitmap(PathImage & $"Icons/{Entry.State}.png") + End If + '标签 + If Entry.Comp IsNot Nothing Then Tags = Entry.Comp.Tags End Sub Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp, Me.Changed @@ -491,9 +486,9 @@ Public Class MyLocalModItem '触发更新 Private Sub BtnUpdate_Click(sender As Object, e As EventArgs) Handles BtnUpdate.Click - Select Case MyMsgBox($"是否要更新 {Entry.Name}？{vbCrLf}{vbCrLf}{GetUpdateCompareDescription()}", "Mod 更新确认", "更新", "查看更新日志", "取消") + Select Case MyMsgBox($"是否要更新 {Entry.DisplayName}？{vbCrLf}{vbCrLf}{GetUpdateCompareDescription()}", "Mod 更新确认", "更新", "查看更新日志", "取消") Case 1 '更新 - FrmVersionMod.UpdateMods({Entry}) + FrmInstanceMod.UpdateMods({Entry}) Case 2 '查看更新日志 ShowUpdateLog() Case 3 '取消 diff --git a/Plain Craft Launcher 2/Pages/PageVersion/PageVersionExport.xaml b/Plain Craft Launcher 2/Pages/PageInstance/PageInstanceExport.xaml similarity index 89% rename from Plain Craft Launcher 2/Pages/PageVersion/PageVersionExport.xaml rename to Plain Craft Launcher 2/Pages/PageInstance/PageInstanceExport.xaml index 0ad86db..e29a1f2 100644 --- a/Plain Craft Launcher 2/Pages/PageVersion/PageVersionExport.xaml +++ b/Plain Craft Launcher 2/Pages/PageInstance/PageInstanceExport.xaml @@ -3,8 +3,8 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:System="clr-namespace:System;assembly=mscorlib" - mc:Ignorable="d" x:Class="PageVersionExport" - PanScroll="{Binding ElementName=PanBack}"> + mc:Ignorable="d" x:Class="PageInstanceExport" + PanScroll="PanBack">