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 无法捕获错误