2.12.8.0

2026-05-15 22:06:22 +08:00
parent 277c020186
commit 53fe8204cf
110 changed files with 30470 additions and 4729 deletions
@@ -1,47 +1,37 @@
 Imports System.Reflection
 Imports System.Windows.Threading
+Imports Microsoft.Win32

 Public Class Application

    '开始
    Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup
        Try
+            '提升主线程优先级
+            Thread.CurrentThread.Priority = ThreadPriority.Highest
            '执行开发版测试
            If BuildType = BuildTypes.Debug Then
                Try
                    ModDevelop.Start()
                Catch ex As Exception
-                    Log(ex, "开发者模式测试出错", NotifyLevel.MsgBox)
+                    Logger.Error(ex, "开发者模式测试出错", LogBehavior.Alert)
                End Try
            End If
-            '提升主线程优先级
-            Thread.CurrentThread.Priority = ThreadPriority.Highest
-            '确保 .NET Framework 版本
+            '检查 .NET Framework 版本
            Try
-                Dim VersionTest As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
-            Catch ex As UriFormatException '修复 #3555
-                Environment.SetEnvironmentVariable("windir", Environment.GetEnvironmentVariable("SystemRoot"), EnvironmentVariableTarget.User)
-                Dim VersionTest As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
-            End Try
-            '检测当前文件夹权限
-            Try
-                DirectoryUtils.Create(PathExeFolder & "PCL\")
+                Using ndpKey As RegistryKey = RegistryKey.OpenBaseKey(RegistryHive.LocalMachine, RegistryView.Registry32).OpenSubKey("SOFTWARE\Microsoft\NET Framework Setup\NDP\v4\Full\")
+                    If ndpKey?.GetValue("Release") IsNot Nothing AndAlso CInt(ndpKey.GetValue("Release")) < 528040 Then OldEnvironmentAssert()
+                End Using
            Catch ex As Exception
-                MsgBox($"PCL 无法创建 PCL 文件夹（{PathExeFolder & "PCL"}），请尝试：" & vbCrLf &
-                  "1. 将 PCL 移动到其他文件夹" & If(PathExeFolder.StartsWithF("C:", True), "，例如 C 盘和桌面以外的其他位置。", "。") & vbCrLf &
-                  "2. 删除当前目录中的 PCL 文件夹，然后再试。" & vbCrLf &
-                  "3. 右键 PCL 选择属性，打开 兼容性 中的 以管理员身份运行此程序。",
-                MsgBoxStyle.Critical, "运行环境错误")
-                Environment.[Exit](ProcessReturnValues.Cancel)
+                Logger.Warn(ex, "检查 .NET Framework 版本失败")
+            End Try
+            '修复 WPF 字体加载（#3467）
+            Try
+                Dim _unused As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
+            Catch ex As UriFormatException
+                Environment.SetEnvironmentVariable("windir", Environment.GetEnvironmentVariable("SystemRoot"), EnvironmentVariableTarget.User)
+                Dim _unused As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
            End Try
-            If Not CheckPermission(PathExeFolder & "PCL") Then
-                MsgBox("PCL 没有对当前文件夹的写入权限，请尝试：" & vbCrLf &
-                  "1. 将 PCL 移动到其他文件夹" & If(PathExeFolder.StartsWithF("C:", True), "，例如 C 盘和桌面以外的其他位置。", "。") & vbCrLf &
-                  "2. 删除当前目录中的 PCL 文件夹，然后再试。" & vbCrLf &
-                  "3. 右键 PCL 选择属性，打开 兼容性 中的 以管理员身份运行此程序。",
-                MsgBoxStyle.Critical, "运行环境错误")
-                Environment.[Exit](ProcessReturnValues.Cancel)
-            End If
            '检查参数调用
            If e.Args.Length > 0 Then
                If e.Args(0) = "--update" Then
@@ -73,18 +63,30 @@ Public Class Application
                End If
            End If
            '初始化文件结构
-            DirectoryUtils.Create(PathExeFolder & "PCL\Pictures\")
-            DirectoryUtils.Create(PathExeFolder & "PCL\Musics\")
+            Try
+                DirectoryUtils.Create(PathExeFolder & "PCL\Pictures\")
+                DirectoryUtils.Create(PathExeFolder & "PCL\Musics\")
+                CheckPermissionWithException(PathExeFolder & "PCL\")
+            Catch ex As Exception
+                MsgBox($"PCL 没有对当前文件夹的权限（{PathExeFolder}PCL\），请尝试：" & vbCrLf &
+                  "1. 将 PCL 移动到其他文件夹" & If(PathExeFolder.StartsWithF("C:", True), "，例如 C 盘和桌面以外的其他位置。", "。") & vbCrLf &
+                  "2. 删除当前目录中的 PCL 文件夹，然后再试。" & vbCrLf &
+                  "3. 右键 PCL 选择属性，打开 兼容性 中的 以管理员身份运行此程序。",
+                MsgBoxStyle.Critical, "运行环境错误")
+                Environment.[Exit](ProcessReturnValues.Cancel)
+            End Try
+RetryCacheCheck:
            Try
                DirectoryUtils.Create(PathTemp)
-                If Not CheckPermission(PathTemp) Then Throw New Exception("PCL 没有对 " & PathTemp & " 的访问权限")
+                CheckPermissionWithException(PathTemp)
            Catch ex As Exception
                If PathTemp = Path.GetTempPath() & "PCL\" Then
-                    MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用")
+                    MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDisplay(True), "缓存文件夹不可用")
                Else
-                    MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用")
+                    MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDisplay(True), "缓存文件夹不可用")
                    Settings.Set("SystemSystemCache", "")
                    PathTemp = Path.GetTempPath() & "PCL\"
+                    GoTo RetryCacheCheck
                End If
            End Try
            DirectoryUtils.Create(PathTemp & "Cache\")
@@ -123,22 +125,21 @@ WaitRetry:
            ServicePointManager.EnableDnsRoundRobin = True
            ServicePointManager.ReusePort = True
            '设置初始窗口
-            If Settings.Get("UiLauncherLogo") Then
+            If Settings.Get(Of Boolean)("UiLauncherLogo") Then
                FrmStart = New SplashScreen("Images\icon.ico")
                FrmStart.Show(False, True)
            End If
            '日志初始化
-            LogStart()
-            '添加日志
-            Log($"[Start] 程序版本：{VersionDisplay} ({VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})")
+            MeloongCore.Main.Init(New PclLogger With {.logFolder = PathUtils.CurrentFolder & "PCL", .MinLevel = If(ModeDebug, LogLevel.Trace, LogLevel.Info)})
+            Logger.Info($"程序版本：{VersionDisplay} ({VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})")
            If BuildType = BuildTypes.Snapshot Then
-                Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，已解锁反馈主题", "，未解锁反馈主题")}")
+                Logger.Info($"识别码：{Identify}{If(ThemeCheckOne(9), "，已解锁反馈主题", "，未解锁反馈主题")}")
            Else
-                Log($"[Start] 识别码：{Identify}")
+                Logger.Info($"识别码：{Identify}")
            End If
-            Log($"[Start] 程序路径：{PathExe}")
-            Log($"[Start] 系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})")
-            Log($"[Start] 管理员权限：{IsAdmin()}")
+            Logger.Info($"程序路径：{PathExe}")
+            Logger.Info($"系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})")
+            Logger.Info($"管理员权限：{SystemUtils.HasAdminRole()}")
            '检测异常环境
            If PathExeFolder.Contains(Path.GetTempPath()) OrElse PathExeFolder.Contains("AppData\Local\Temp\") Then
                MyMsgBox("请将 PCL 从压缩包中解压后再使用！" & vbCrLf & "如果不会解压，可以在网上寻找教程。", "需要解压！", "我知道了", IsWarn:=True, ForceWait:=True)
@@ -148,7 +149,7 @@ WaitRetry:
                MyMsgBox("PCL 和新版 Minecraft 均不再支持 32 位系统，部分功能将无法使用。" & vbCrLf & "非常建议重装为 64 位系统后再进行游戏！", "环境警告", "我知道了", IsWarn:=True)
            End If
            '计时
-            Log("[Start] 第一阶段加载用时：" & GetTimeMs() - ApplicationStartTick & " ms")
+            Logger.Info($"第一阶段加载用时：{GetTimeMs() - ApplicationStartTick} ms")
            ApplicationStartTick = GetTimeMs()
            AniControlEnabled += 1
        Catch ex As Exception
@@ -157,7 +158,7 @@ WaitRetry:
                FilePath = PathExe
            Catch
            End Try
-            MsgBox(ex.GetDetail(True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误")
+            MsgBox(ex.GetDisplay(True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误")
            FormMain.EndProgramForce(ProcessReturnValues.Exception)
        End Try
    End Sub
@@ -181,43 +182,48 @@ WaitRetry:
        End If
        '正常处理
        e.Handled = True
-        If IsProgramEnded Then Return
+        If IsProgramEnding Then Return
        FeedbackInfo()
-        Dim Detail As String = e.Exception.GetDetail(True)
+        Dim Detail As String = e.Exception.GetDisplay(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")
-            Log(e.Exception, "你的 .NET Framework 版本过低或损坏，请下载并重新安装 .NET Framework 4.6.2！" & vbCrLf & "若无法安装，可在卸载高版本的 .NET Framework 后再试。", NotifyLevel.Critical, "运行环境错误")
+            OldEnvironmentAssert(e.Exception)
        Else
-            Log(e.Exception, "程序出现未知错误", NotifyLevel.Critical, "锟斤拷烫烫烫")
+            Logger.Error(e.Exception, "程序出现未知错误", LogBehavior.AlertThenCrash)
+        End If
+    End Sub
+    Private Shared Sub OldEnvironmentAssert(Optional ex As Exception = Nothing)
+        OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net48-offline-installer")
+        If ex Is Nothing Then
+            Logger.Error($"你的 .NET Framework 版本过低或损坏，请下载并重新安装 .NET Framework 4.8！{vbCrLf}若安装失败，可以先卸载高版本的 .NET Framework 然后再试。", LogBehavior.AlertThenCrash)
+        Else
+            Logger.Error(ex, $"你的 .NET Framework 版本过低或损坏，请下载并重新安装 .NET Framework 4.8！{vbCrLf}若安装失败，可以先卸载高版本的 .NET Framework 然后再试。", LogBehavior.AlertThenCrash)
        End If
    End Sub

    '动态 DLL 加载
    Private Sub New() '这里必须尽早调用，且不能使用任何库，否则加载 MeloongCore 就会导致崩溃
-        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", "PCLCS", "MeloongCore.Wpf", "MeloongCore"}
-        Static Locks As New Dictionary(Of String, Object)(StringComparer.Ordinal)
-        Static LoadedAssembly As New Dictionary(Of String, Assembly)(StringComparer.Ordinal) '缓存
+        Static Prefixes As String() = {"NAudio", "Newtonsoft.Json", "Ookii.Dialogs.Wpf", "Imazen.WebP", "CacheCow.Common", "CacheCow.Client.FileStore", "CacheCow.Client", "System.Net.Http.Formatting", "PCLCS", "MeloongCore.Wpf", "MeloongCore"}
+        Static LoadedAssemblies As New ConcurrentDictionary(Of String, Lazy(Of Assembly))(StringComparer.Ordinal) '缓存
        AddHandler AppDomain.CurrentDomain.AssemblyResolve,
        Function(sender As Object, Args As ResolveEventArgs) As Assembly
            Dim Prefix As String = Prefixes.FirstOrDefault(Function(p) Args.Name.StartsWith(p, StringComparison.Ordinal))
            If Prefix Is Nothing Then Return Nothing
-            If Not Locks.ContainsKey(Prefix) Then Locks(Prefix) = New Object()
-            SyncLock Locks(Prefix)
-                If Not LoadedAssembly.ContainsKey(Prefix) Then
-                    LoadedAssembly(Prefix) = Assembly.Load(My.Resources.ResourceManager.GetObject(Prefix))
-                    If Prefix = "Imazen.WebP" Then ExtractLibwebp() 'WebP 特判
-                End If
-                Return LoadedAssembly(Prefix)
-            End SyncLock
+            Dim LazyAssembly = LoadedAssemblies.GetOrAdd(Prefix, Function(p) New Lazy(Of Assembly)(
+            Function()
+                Dim LoadedAssembly = Assembly.Load(DirectCast(My.Resources.ResourceManager.GetObject(p), Byte()))
+                If p = "Imazen.WebP" Then ExtractLibwebp() 'WebP 特判
+                Return LoadedAssembly
+            End Function, LazyThreadSafetyMode.ExecutionAndPublication))
+            Return LazyAssembly.Value
        End Function
    End Sub
    Private Shared Sub ExtractLibwebp() '这个方法会调用 ModBase，进而调用 MeloongCore，所以不能放在 New 里
        SetDllDirectory(PathPure.TrimEnd("\"c))
        Try
-            FileUtils.Write(PathPure & "libwebp.dll", GetResources("libwebp64"))
+            ExtractResources(PathPure & "libwebp.dll", "libwebp64")
        Catch ex As Exception
-            Log(ex, "写入 libwebp.dll 失败") '防止同时加载多个图片时，同时写入文件导致文件占用，进而导致崩溃
+            Logger.Warn(ex, "写入 libwebp.dll 失败") '防止同时加载多个图片时，同时写入文件导致文件占用，进而导致崩溃
        End Try
    End Sub
    Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean
@@ -226,10 +232,10 @@ WaitRetry:

    '控件模板事件
    Private Sub MyIconButton_Click(sender As Object, e As EventArgs)
-        Select Case Settings.Get("LoginType")
+        Select Case Settings.Get(Of McLoginType)("LoginType")
            Case McLoginType.Ms
                '微软
-                Dim MsJson As JObject = GetJson(Settings.Get("LoginMsJson"))
+                Dim MsJson As JObject = GetJson(Settings.Get(Of String)("LoginMsJson"))
                MsJson.Remove(sender.Tag)
                Settings.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None))
                If FrmLoginMs.ComboAccounts.SelectedItem Is sender.Parent Then FrmLoginMs.ComboAccounts.SelectedIndex = 0
@@ -237,19 +243,19 @@ WaitRetry:
            Case McLoginType.Legacy
                '离线
                Dim Names As New List(Of String)
-                Names.AddRange(Settings.Get("LoginLegacyName").ToString.Split("¨"))
+                Names.AddRange(Settings.Get(Of String)("LoginLegacyName").ToString.Split("¨"))
                Names.Remove(sender.Tag)
                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(Settings.Get("LoginType"))
+                Dim Token As String = Settings.Get(Of McLoginType)("LoginType").ToString()
                Dim Dict As New Dictionary(Of String, String)
                Dim Names As New List(Of String)
                Dim Passs As New List(Of String)
-                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("¨"))
+                If Not Settings.Get(Of String)("Login" & Token & "Email") = "" Then Names.AddRange(Settings.Get(Of String)("Login" & Token & "Email").Split("¨"))
+                If Not Settings.Get(Of String)("Login" & Token & "Pass") = "" Then Passs.AddRange(Settings.Get(Of String)("Login" & Token & "Pass").Split("¨"))
                For i = 0 To Names.Count - 1
                    Dict.Add(Names(i), Passs(i))
                Next