2.10.6

2025-08-13 01:08:21 +08:00
parent 1d0947181f
commit adf52d56b7
27 changed files with 705 additions and 682 deletions
@@ -1,6 +1,6 @@
 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
@@ -13,13 +13,13 @@ Public Module ModBase
 #Region "声明"

    '下列版本信息由更新器自动修改
-    Public Const VersionBaseName As String = "2.10.5" '不含分支前缀的显示用版本名
-    Public Const VersionStandardCode As String = "2.10.5." & VersionBranchCode '标准格式的四段式版本号
+    Public Const VersionBaseName As String = "2.10.6" '不含分支前缀的显示用版本名
+    Public Const VersionStandardCode As String = "2.10.6." & VersionBranchCode '标准格式的四段式版本号
    Public Const CommitHash As String = "" 'Commit Hash，由 GitHub Workflow 自动替换
 #If BETA Then
-    Public Const VersionCode As Integer = 361 'Release
+    Public Const VersionCode As Integer = 367 'Release
 #Else
-    Public Const VersionCode As Integer = 364 'Snapshot
+    Public Const VersionCode As Integer = 366 'Snapshot
 #End If
    '自动生成的版本信息
    Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -791,8 +791,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 = ShortenPath(If(FromPath.Contains(":\"), FromPath, Path & FromPath))
+            ToPath = ShortenPath(If(ToPath.Contains(":\"), ToPath, Path & ToPath))
            '如果复制同一个文件则跳过
            If FromPath = ToPath Then Return
            '确保目录存在
@@ -861,7 +861,7 @@ Public Module ModBase
    ''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
    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 = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath))
        '确保目录存在
        Directory.CreateDirectory(GetPathFromFullPath(FilePath))
        '写入文件
@@ -886,7 +886,7 @@ Public Module ModBase
    ''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
    Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
        '处理相对路径
-        If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
+        FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath))
        '确保目录存在
        Directory.CreateDirectory(GetPathFromFullPath(FilePath))
        '写入文件
@@ -1294,11 +1294,11 @@ Re:
    ''' </summary>
    Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing,
                           Optional ProgressIncrementHandler As Action(Of Double) = Nothing)
-        Directory.CreateDirectory(DestDirectory)
+        Directory.CreateDirectory(ShortenPath(DestDirectory))
        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 decompressedFile As New FileStream(ShortenPath(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", "")), FileMode.OpenOrCreate, FileAccess.Write)
            Dim data As Integer = stream.ReadByte()
            While data <> -1
                decompressedFile.WriteByte(data)
@@ -1309,10 +1309,10 @@ Re:
        Else
            '以 zip 方式解压
            Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030")))
-                Dim TotalCount As Integer = Archive.Entries.Count
+                Dim TotalCount As Long = 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 ProgressIncrementHandler IsNot Nothing AndAlso TotalCount > 0 Then ProgressIncrementHandler(1 / TotalCount)
+                    Dim DestinationPath As String = ShortenPath(IO.Path.Combine(DestDirectory, Entry.FullName))
                    If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then
                        Continue For '不创建空文件夹
                    Else
@@ -1387,10 +1387,10 @@ 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
    ''' <summary>
@@ -1449,22 +1449,8 @@ 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
-
        '构造输出信息
+        Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
        If CommonReason Is Nothing Then
            Return DescList.Join(vbCrLf)
        Else
@@ -1492,22 +1478,8 @@ RetryDir:
        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 CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
        If CommonReason IsNot Nothing Then
            Return CommonReason & "详细错误：" & DescList.First
        Else
@@ -1515,6 +1487,24 @@ RetryDir:
            Return Join(DescList, " ← ")
        End If
    End Function
+    Private Function AnalyzeCommonReason(InnerEx 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 {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
+                "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then
+            Return "你的网络环境不佳，导致难以连接到服务器。请稍后重试，或使用 VPN 以改善网络环境。"
+        Else
+            Return Nothing
+        End If
+    End Function

    ''' <summary>
    ''' 返回一个枚举对应的字符串。
@@ -1556,7 +1546,7 @@ RetryDir:
            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

@@ -2641,10 +2631,6 @@ Retry:
    ''' 相对增减控件的左边距。
    ''' </summary>
    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
@@ -2656,8 +2642,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
@@ -2665,17 +2649,12 @@ Retry:
    ''' 设置控件的左边距。（仅针对置左控件）
    ''' </summary>
    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
    ''' <summary>
    ''' 相对增减控件的上边距。
    ''' </summary>
    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
@@ -2687,11 +2666,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
@@ -2705,7 +2681,6 @@ Retry:
    ''' 设置控件的顶边距。（仅针对置上控件）
    ''' </summary>
    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

@@ -2989,6 +2964,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
    ''' <summary>
    ''' 输出错误信息。
@@ -3055,6 +3037,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

    '反馈
@@ -3091,9 +3080,23 @@ Retry:
            "文件位置：" & 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 Setup.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
+                Log("[System] 匿名数据上报失败", LogLevel.Debug)
+            End Try
+        End Sub, "Telemetry", ThreadPriority.Lowest)
    End Sub

    '获取当前的堆栈信息
@@ -22,9 +22,6 @@ Public Module ModNet
            Return If(Encoding, Encoding.UTF8).GetString(SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, UseBrowserUserAgent:=UseBrowserUserAgent))
        Catch ex As ThreadInterruptedException
            Throw
-        Catch ex As ResponsedWebException
-            If MakeLog Then Log(ex, "网络请求失败，返回内容为：" & vbCrLf & ex.Response, LogLevel.Developer)
-            Throw
        Catch ex As Exception
            If MakeLog Then Log(ex, "网络请求失败", LogLevel.Developer)
            Throw
@@ -244,7 +241,10 @@ RequestFinished:
            If Response.IsSuccessStatusCode Then
                Return ResponseBytes
            Else
-                Throw New ResponsedWebException($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}", If(Encoding, Encoding.UTF8).GetString(ResponseBytes))
+                Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes)
+                Throw New ResponsedWebException(
+                    $"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}" &
+                    If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), ResponseMessage)
            End If
        Catch ex As ThreadInterruptedException
            Throw
@@ -807,7 +807,7 @@ StartSingleThreadDownload:
                    '是否禁用多线程，以及规定碎片大小
                    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
+                       TargetUrl.Contains("optifine.net") OrElse TargetUrl.Contains("modrinth") OrElse TargetUrl.Contains("momot.rs") Then Return Nothing
                    '寻找最大碎片
                    'FUTURE: 下载引擎重做，计算下载源平均链接时间和线程下载速度，按最高时间节省来开启多线程
                    Dim FilePieceMax As NetThread = Threads
@@ -990,7 +990,8 @@ NotSupportRange:
                                    Th.DownloadDone += RealDataCount
                                    ResultStream.Write(ResponseBytes, 0, RealDataCount)
                                    '检查速度是否过慢
-                                    If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount Then '数据包间隔大于 1.5s，且速度小于 1.5K/s
+                                    If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 1.5s，且速度小于 1.5K/s
+                                        Th.Source.SingleThread Is Nothing Then '并非单线程下载
                                        Throw New TimeoutException("由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。")
                                    End If
                                    Th.LastReceiveTime = GetTimeTick()
@@ -1027,7 +1028,8 @@ SourceBreak:
                End SyncLock
                '合并
                If Not IsNoSplit Then ResultStream?.Dispose()
-                If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso State < NetState.Merge Then Merge(Th)
+                If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso
+                    State < NetState.Merge AndAlso Th.State <> NetState.Error Then Merge(Th)
            End Try
        End Sub
        Private Sub SourceFail(Th As NetThread, ex As Exception, IsMergeFailure As Boolean)
@@ -1069,7 +1071,7 @@ SourceBreak:
                        '当前源失败，但还有下载源：正常地继续执行
                    ElseIf Not Retried AndAlso Sources.Count > 1 Then
                        '合并失败或首次下载失败，未重试：将所有下载源重新标记为不允许断点续传的下载源，逐个重新尝试下载
-                        Log($"[Download] {LocalName}：文件下载失败，正在自动重试……", If(ModeDebug, LogLevel.Hint, LogLevel.Debug)) '在调试模式下给出红色提示
+                        Hint($"{LocalName}：文件下载失败，正在自动重试……", If(ModeDebug, HintType.Critical, HintType.Info)) '在调试模式下给出红色提示
                        Retried = True
                        SyncLock LockSource
                            SourcesOnce.Clear()
@@ -1525,10 +1527,14 @@ Retry:
                '获取实际失败的文件
                For Each File In Files
                    If File.State <> NetState.Error Then Continue For
+                    Dim Detail As String = Join(File.Sources.Select(Function(s) $"{If(s.Ex?.Message, "无错误信息。"）}（{s.Url}）"), vbCrLf)
                    [Error] = New Exception("文件下载失败：" & File.LocalPath & vbCrLf &
-                                            "各下载源的错误如下：" & vbCrLf &
-                                            Join(File.Sources.Select(Function(s) $"{If(s.Ex?.Message, "无错误信息。"）}（{s.Url}）"), vbCrLf),
+                                            "各下载源的错误如下：" & vbCrLf & Detail,
                                            [Error])
+                    '上报
+                    Telemetry("文件下载失败",
+                              "FileName", File.LocalName,
+                              "Exception", Detail)
                    Exit For
                Next
                '在设置 Error 对象后再更改为失败，避免 WaitForExit 无法捕获错误
@@ -2,7 +2,9 @@

    '构造函数
    Private TempFolder As String
-    Public Sub New(UUID As Integer)
+    Private TargetVersion As McVersion
+    Public Sub New(Optional TargetVersion As McVersion = Nothing)
+        Me.TargetVersion = TargetVersion
        '构建文件结构
        TempFolder = RequestTaskTempFolder()
        Directory.CreateDirectory(TempFolder & "Temp\")
@@ -508,7 +510,7 @@ 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.材质过大或显卡配置不足)
@@ -856,12 +858,13 @@ NextStack:
    ''' <summary>
    ''' 弹出崩溃弹窗，并指导导出崩溃报告。
    ''' </summary>
-    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
@@ -918,6 +921,11 @@ NextStack:
                End Try
                OpenExplorer(FileAddress)
        End Select
+        '上报
+        If IsManualAnalyze Then Return
+        Telemetry("Minecraft 崩溃",
+                  "Version", If(TargetVersion Is Nothing, "null", TargetVersion.Version.ToString),
+                  "Detail", FilterUserName(Detail, "*"))
    End Sub
    ''' <summary>
    ''' 获取崩溃分析的结果描述。
@@ -1102,7 +1110,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
@@ -594,7 +594,7 @@
            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

@@ -1106,26 +1106,27 @@
    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, 10)) '至少 10s，要不然有时候远端服务器来不及完成
-        Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
-        '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, 10))
-        '           Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
-        '           Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
-        '       Case 1
-        '           Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10))
-        '           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, 10))
-        '           Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
-        '           Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
-        '   End Select
-        'End If
+        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, 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, 10)) '至少 10s，要不然有时候远端服务器来不及完成
+                    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, 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, 10))
+            Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
+        End If
        Dim Exs As String = ""
        For Each Source In Urls
            Try
@@ -1232,7 +1233,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 自动切换
@@ -66,7 +66,7 @@ Public Module ModLaunch
    ''' </summary>
    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

@@ -101,6 +101,8 @@ Public Module ModLaunch
            If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical)
            Throw
        End Try
+        Dim IsSavingBatch As Boolean = CurrentLaunchOptions?.SaveBatch IsNot Nothing
+
        '正式加载
        Try
            '构造主加载器
@@ -145,9 +147,15 @@ Public Module ModLaunch
            Select Case LaunchLoader.State
                Case LoadState.Finished
                    Hint(McVersionCurrent.Name & " 启动成功！", HintType.Finish)
+                    '上报
+                    If Not IsSavingBatch Then
+                        Telemetry("Minecraft 启动成功",
+                              "Version", McVersionCurrent.Version.ToString,
+                              "LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)))
+                    End If
                Case LoadState.Aborted
                    If AbortHint Is Nothing Then
-                        Hint(If(CurrentLaunchOptions?.SaveBatch Is Nothing, "已取消启动！", "已取消导出启动脚本！"), HintType.Info)
+                        Hint(If(IsSavingBatch, "已取消导出启动脚本！", "已取消启动！"), HintType.Info)
                    Else
                        Hint(AbortHint, HintType.Finish)
                    End If
@@ -162,7 +170,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
                '检查下一级错误
@@ -172,8 +180,15 @@ NextInner:
                '没有特殊处理过的错误信息
                McLaunchLog("错误：" & GetExceptionDetail(ex))
                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", McVersionCurrent.Version.ToString,
+                              "LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)),
+                              "Exception", FilterUserName(FilterAccessToken(GetExceptionDetail(ex), "*"), "*"))
+                End If
                Throw
            End If
        End Try
@@ -891,9 +906,9 @@ Retry:
                ContentType:="application/x-www-form-urlencoded",
                Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}},
                ThreadCount:=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
+        Catch ex As ResponsedWebException
+            If ex.Response.ContainsF("must sign in again", True) OrElse ex.Response.ContainsF("password expired", True) OrElse
+               (ex.Response.Contains("refresh_token") AndAlso ex.Response.Contains("is not valid")) Then '#269
                Return {"Relogin", ""}
            Else
                Throw
@@ -942,20 +957,20 @@ Retry:
        Try
            Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post,
                Content:=Request, ContentType:="application/json")
-        Catch ex As Net.WebException
+        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
+            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")
@@ -1364,13 +1379,13 @@ Retry:
            McLaunchLog("新版 Game 参数获取成功")
        End If
        '编码参数（#4700、#5892、#5909）
+        If McLaunchJavaSelected.VersionCode >= 18 Then 'Dfile.encoding 需要放在 Dstdout.encoding 后面（#6934）
+            If Not Arguments.Contains("-Dfile.encoding=") Then Arguments = "-Dfile.encoding=COMPAT " & Arguments
+        End If
        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
        End If
-        If McLaunchJavaSelected.VersionCode >= 18 Then
-            If Not Arguments.Contains("-Dfile.encoding=") Then Arguments = "-Dfile.encoding=COMPAT " & Arguments
-        End If
        'MJSB
        Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
        '全屏
@@ -1692,7 +1707,7 @@ NextVersion:
        GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken)
        GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken)
        GameArguments.Add("${user_type}", "msa") '#1221
-        GameArguments.Add("${primary_jar}", Version.Path & Version.Name & ".jar")
+        GameArguments.Add("${primary_jar}", Version.Path & Version.Name & ".jar") '#6942

        '窗口尺寸参数
        Dim GameSize As Size
@@ -989,7 +989,7 @@ ExitDataLoad:
            If ToString = "" Then
                Return "原版 " & McName
            Else
-                Return McName & ToString & If(ModeDebug, " (" & SortCode & "#)", "")
+                Return McName & ToString
            End If
        End Function

@@ -2415,7 +2415,7 @@ 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("\" & Token, "\" & New String(FilterChar, Token.Count))
            Next
        End If
        Return Raw
@@ -349,14 +349,14 @@
            State = MinecraftState.Crashed
            '崩溃分析
            WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析")
-            Hint("检测到 Minecraft 出现错误，错误分析已开始……")
+            Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Critical)
            FeedbackInfo()
            RunInNewThread(
            Sub()
                Try
                    Thread.Sleep(2000)
                    WatcherLog("崩溃分析开始")
-                    Dim Analyzer As New CrashAnalyzer(PID)
+                    Dim Analyzer As New CrashAnalyzer(Version)
                    Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
                    Analyzer.Prepare()
                    Analyzer.Analyze(Version)
@@ -116,11 +116,8 @@
                    End Try

                Case "修改设置"
-                    If Setup.IsEncoded(Data(0)) Then
-                        Throw New Exception($"无法修改受加密保护的设置：{Data(0)}")
-                    End If
                    Setup.Set(Data(0), Data(1))
-                    Hint("已修改设置！", HintType.Finish)
+                    Hint($"已写入设置：{Data(0)} → {Data(1)}", HintType.Finish)

                Case Else
                    MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败")
@@ -12,6 +12,8 @@ Friend Module ModSecret
    Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")
    'CurseForge API Key
    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 线程优先级
@@ -137,7 +137,7 @@ Public Class DragHelper
        Dim fileCount As UInteger = DragQueryFile(wParam, UInteger.MaxValue, Nothing, 0)
        ReDim dropFilePaths(CInt(fileCount) - 1)

-        For i As UInteger = 0 To 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()