Merge branch 'main' into main

2024-08-31 18:05:50 +08:00
parent 4d28be2610 007b51b314
commit dff5b4730e
22 changed files with 388 additions and 351 deletions
@@ -18,7 +18,7 @@ Public Module ModBase
 #If BETA Then
    Public Const VersionCode As Integer = 332 'Release
 #Else
-    Public Const VersionCode As Integer = 333 'Snapshot
+    Public Const VersionCode As Integer = 334 'Snapshot
 #End If
    '自动生成的版本信息
    Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -698,7 +698,7 @@ Public Module ModBase
            If Not FileName.Contains(":\") Then FileName = $"{Path}PCL\{FileName}.ini"
            WriteFile(FileName, FileContent.ToString)
        Catch ex As Exception
-            Log(ex, $"写入文件失败（{FileName} -> {Key}:{Value}）")
+            Log(ex, $"写入文件失败（{FileName} → {Key}:{Value}）", LogLevel.Hint)
        End Try
    End Sub

@@ -772,10 +772,10 @@ Public Module ModBase
        End Try
    End Sub
    ''' <summary>
-    ''' 读取文件，如果失败则返回空字符串。
+    ''' 读取文件，如果失败则返回空数组。
    ''' </summary>
    ''' <param name="FilePath">文件完整或相对路径。</param>
-    Public Function ReadFile(FilePath As String, Optional Encoding As Encoding = Nothing) As String
+    Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte()
        Try
            '还原文件路径
            If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
@@ -785,17 +785,25 @@ Public Module ModBase
                    ReDim FileBytes(ReadStream.Length - 1)
                    ReadStream.Read(FileBytes, 0, ReadStream.Length)
                End Using
-                ReadFile = If(Encoding Is Nothing, DecodeBytes(FileBytes), Encoding.GetString(FileBytes))
+                Return FileBytes
            Else
-                Log("[System] 欲读取的文件不存在，已返回空字符串：" & FilePath)
-                Return ""
+                Log("[System] 欲读取的文件不存在，已返回空内容：" & FilePath)
+                Return {}
            End If
        Catch ex As Exception
            Log(ex, "读取文件出错：" & FilePath)
-            Return ""
+            Return {}
        End Try
    End Function
    ''' <summary>
+    ''' 读取文件，如果失败则返回空字符串。
+    ''' </summary>
+    ''' <param name="FilePath">文件完整或相对路径。</param>
+    Public Function ReadFile(FilePath As String, Optional Encoding As Encoding = Nothing) As String
+        Dim FileBytes = ReadFileBytes(FilePath)
+        ReadFile = If(Encoding Is Nothing, DecodeBytes(FileBytes), Encoding.GetString(FileBytes))
+    End Function
+    ''' <summary>
    ''' 读取流中的所有文本。
    ''' </summary>
    Public Function ReadFile(Stream As Stream, Optional Encoding As Encoding = Nothing) As String
@@ -820,50 +828,39 @@ Public Module ModBase
    ''' <param name="FilePath">文件完整或相对路径。</param>
    ''' <param name="Text">文件内容。</param>
    ''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
-    Public Function WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) As Boolean
-        Try
-            '还原文件路径
-            If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
-            '确保目录存在
-            Directory.CreateDirectory(GetPathFromFullPath(FilePath))
-            '写入文件
-            If File.Exists(FilePath) Then
-                '如果文件存在，刷新目前文件
-                Using writer As New StreamWriter(FilePath, Append, If(Encoding, GetEncoding(FilePath)))
-                    writer.Write(Text)
-                    writer.Flush()
-                    writer.Close()
-                End Using
-            Else
-                '如果文件不存在，则新建并写入
-                File.WriteAllText(FilePath, Text, If(Encoding, New UTF8Encoding(False)))
-            End If
-            Return True
-        Catch ex As Exception
-            Log(ex, "写入文件时出错：" & FilePath)
-            Return False
-        End Try
-    End Function
+    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
+        '确保目录存在
+        Directory.CreateDirectory(GetPathFromFullPath(FilePath))
+        '写入文件
+        If File.Exists(FilePath) Then
+            '如果文件存在，刷新目前文件
+            Using writer As New StreamWriter(FilePath, Append, If(Encoding, GetEncoding(ReadFileBytes(FilePath))))
+                writer.Write(Text)
+                writer.Flush()
+                writer.Close()
+            End Using
+        Else
+            '如果文件不存在，则新建并写入
+            File.WriteAllText(FilePath, Text, If(Encoding, New UTF8Encoding(False)))
+        End If
+    End Sub
    ''' <summary>
    ''' 写入文件。
+    ''' 如果 CanThrow 设置为 False，返回是否写入成功。
    ''' </summary>
    ''' <param name="FilePath">文件完整或相对路径。</param>
    ''' <param name="Content">文件内容。</param>
    ''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
-    Public Function WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) As Boolean
-        Try
-            '还原文件路径
-            If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
-            '确保目录存在
-            Directory.CreateDirectory(GetPathFromFullPath(FilePath))
-            '写入文件
-            File.WriteAllBytes(FilePath, Content)
-            Return True
-        Catch ex As Exception
-            Log(ex, "写入文件时出错：" & FilePath)
-            Return False
-        End Try
-    End Function
+    Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
+        '还原文件路径
+        If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
+        '确保目录存在
+        Directory.CreateDirectory(GetPathFromFullPath(FilePath))
+        '写入文件
+        File.WriteAllBytes(FilePath, Content)
+    End Sub
    ''' <summary>
    ''' 将流写入文件。
    ''' </summary>
@@ -893,21 +890,11 @@ Public Module ModBase

    '文件编码
    ''' <summary>
-    ''' 获取文件编码。
-    ''' </summary>
-    ''' <param name="FilePath">文件完整或相对路径。</param>
-    Public Function GetEncoding(FilePath As String) As Encoding
-        '还原文件路径
-        If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
-        '获取编码
-        GetEncoding = GetEncoding(File.ReadAllBytes(FilePath))
-    End Function
-    ''' <summary>
-    ''' 获取 Bytes 的编码。
+    ''' 根据字节数组分析其编码。
    ''' </summary>
    Public Function GetEncoding(Bytes As Byte()) As Encoding
        Dim Length As Integer = Bytes.Count
-        If Length <= 2 Then Return New UTF8Encoding(False) '不带 BOM 的 UTF8
+        If Length < 3 Then Return New UTF8Encoding(False) '不带 BOM 的 UTF8
        '根据 BOM 判断编码
        If Bytes(0) >= &HEF Then
            '有 BOM 类型
@@ -1651,10 +1638,15 @@ RetryDir:
    End Function

    ''' <summary>
-    ''' 输入 And 字符不会报错的 Val。
+    ''' 不会报错的 Val。
+    ''' 如果输入有误，返回 0。
    ''' </summary>
    Public Function Val(Str As Object) As Double
-        Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str))
+        Try
+            Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str))
+        Catch
+            Return 0
+        End Try
    End Function

    '转义
@@ -268,12 +268,7 @@ RequestFinished:
        '下载
        Using Client As New WebClient
            Try
-                If UseBrowserUserAgent Then
-                    Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
-                Else
-                    Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode
-                End If
-                Client.Headers(HttpRequestHeader.Referer) = "http://" & VersionCode & ".pcl2.server/"
+                SecretHeadersSign(Url, Client, UseBrowserUserAgent)
                Client.DownloadFile(Url, LocalFile)
            Catch ex As Exception
                File.Delete(LocalFile)
@@ -315,7 +310,7 @@ Retry:
        Catch ex As ThreadInterruptedException
            Throw
        Catch ex As Exception
-            If ex.InnerException IsNot Nothing AndAlso ex.InnerException.Message.Contains("(40") AndAlso DontRetryOnRefused Then RetryCount = 999
+            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 & "）")
@@ -432,7 +427,11 @@ RequestFinished:
                    End Using
                Catch
                End Try
-                ex = New WebException($"网络请求失败（{ex.Status}，{ex.Message}，{Url}）{If(String.IsNullOrEmpty(Res), "", vbCrLf & Res)}", ex)
+                If Res = "" Then
+                    ex = New WebException($"网络请求失败（{ex.Status}，{ex.Message}，{Url}）", ex)
+                Else
+                    ex = New ResponsedWebException($"服务器返回错误（{ex.Status}，{ex.Message}，{Url}）{vbCrLf}{Res}", Res, ex)
+                End If
            End If
            If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer)
            Throw ex
@@ -445,6 +444,17 @@ RequestFinished:
            If Resp IsNot Nothing Then Resp.Dispose()
        End Try
    End Function
+    Public Class ResponsedWebException
+        Inherits WebException
+        ''' <summary>
+        ''' 远程服务器给予的回复。
+        ''' </summary>
+        Public Overloads Property Response As String
+        Public Sub New(Message As String, Response As String, InnerException As Exception)
+            MyBase.New(Message, InnerException)
+            Me.Response = Response
+        End Sub
+    End Class

    ''' <summary>
    ''' 最大线程数。
@@ -1077,7 +1077,7 @@ Retry:
        If String.IsNullOrEmpty(Task.Input.SearchText) Then
            '如果没有搜索文本，按下载量将结果排序
            For Each Result As CompProject In RealResults
-                Scores.Add(Result, Result.DownloadCount * If(Result.FromCurseForge, 1, 30))
+                Scores.Add(Result, Result.DownloadCount * If(Result.FromCurseForge, 1, 10))
            Next
        Else
            '如果有搜索文本，按关联度将结果排序
@@ -1085,7 +1085,7 @@ Retry:
            Dim Entry 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) * If(Result.FromCurseForge, 1, 30)) / 9)
+                           Math.Log10(Math.Max(Result.DownloadCount, 1) * If(Result.FromCurseForge, 1, 10)) / 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)}})
@@ -844,8 +844,11 @@ NextStack:
    Public Sub Output(IsHandAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing)
        '弹窗提示
        FrmMain.ShowWindowToTop()
-        Dim ShowLog As Action =
+        Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
+            "确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"),
+            Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing,
            Sub()
+                '弹窗选择：查看日志
                If File.Exists(DirectFile.Value.Key) Then
                    ShellOnly("notepad", DirectFile.Value.Key)
                Else
@@ -853,11 +856,9 @@ NextStack:
                    WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf))
                    ShellOnly(FilePath)
                End If
-            End Sub
-        Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
-                             "确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"),
-                             Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing, ShowLog))
+            End Sub))
            Case 3
+                '弹窗选择：导出错误报告
                Dim FileAddress As String = Nothing
                Try
                    '获取文件路径
@@ -881,7 +882,7 @@ NextStack:
                                FileName = "游戏崩溃前的输出.txt"
                        End Select
                        If File.Exists(OutputFile) Then
-                            Dim FileEncoding As Encoding = GetEncoding(OutputFile)
+                            Dim FileEncoding As Encoding = GetEncoding(ReadFileBytes(OutputFile))
                            WriteFile(TempFolder & "Report\" & FileName,
                                      SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
                                      Encoding:=FileEncoding)
@@ -216,8 +216,8 @@

            '添加特定的 Java
            Dim JavaPreList As New Dictionary(Of String, Boolean)
-            If PathMcFolder.Split("\").Count > 3 Then
-                JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录的话）
+            If PathMcFolder.Split("\").Count > 3 AndAlso Not PathMcFolder.Contains("AppData\Roaming") Then
+                JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录或 %APPDATA% 的话）
            End If
            JavaSearchFolder(PathMcFolder, JavaPreList, False, True) 'Minecraft 文件夹
            JavaPreList = JavaPreList.Where(Function(j) Not j.Key.Contains(".minecraft\runtime")).
@@ -670,6 +670,7 @@ LoginFinish:
            Url:=Data.Input.BaseUrl & "/validate",
            Method:="POST",
            Data:=RequestData.ToString(0),
+            Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh_CN"}},
            ContentType:="application/json; charset=utf-8") '没有返回值的
        '将登录结果输出
        Data.Output.AccessToken = AccessToken
@@ -693,6 +694,7 @@ LoginFinish:
                   ""name"":""" & Setup.Get("Cache" & Data.Input.Token & "Name") & """},", "") & "
               ""accessToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Access") & """,
               ""clientToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Client") & """}",
+               Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh_CN"}},
               ContentType:="application/json; charset=utf-8"))
        '将登录结果输出
        If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效！")
@@ -723,6 +725,7 @@ LoginFinish:
                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"))
            '检查登录结果
            If LoginJson("availableProfiles").Count = 0 Then
@@ -782,6 +785,16 @@ LoginFinish:
        Catch ex As Exception
            Dim AllMessage As String = GetExceptionSummary(ex)
            Log(ex, "登录失败原始错误信息", LogLevel.Normal)
+            '读取服务器返回的错误
+            If TypeOf ex Is ResponsedWebException Then
+                Dim ErrorMessage As String = Nothing
+                Try
+                    ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage")
+                Catch
+                End Try
+                If Not String.IsNullOrWhiteSpace(ErrorMessage) Then Throw New Exception("$登录失败：" & ErrorMessage)
+            End If
+            '通用关键字检测
            If AllMessage.Contains("403") Then
                Select Case Data.Input.Type
                    Case McLoginType.Auth
@@ -1331,20 +1344,28 @@ LoginFinish:
        Dim WrapperPath As String = BaseDir & "\JavaWrapper.jar"
        Log("[Java] 选定的 Java Wrapper 路径：" & WrapperPath)
        SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突
-            Dim IsWrapperWritten As Boolean = WriteFile(WrapperPath, GetResources("JavaWrapper"))
-            If Not IsWrapperWritten AndAlso File.Exists(WrapperPath) Then
-                '以下为 #4243 的修复，因为未知原因 Java Wrapper 可能变为只读文件
-                Log("[Java] Java Wrapper 文件释放失败，但文件已存在，将在删除后尝试重新生成", LogLevel.Debug)
-                Try
-                    File.Delete(WrapperPath)
-                    IsWrapperWritten = WriteFile(WrapperPath, GetResources("JavaWrapper"))
-                Catch ex As Exception
-                    Log(ex, "Java Wrapper 文件重新释放失败，将尝试更换文件名重新生成")
-                    WrapperPath = BaseDir & "\JavaWrapper2.jar"
-                    IsWrapperWritten = WriteFile(WrapperPath, GetResources("JavaWrapper"))
-                End Try
-            End If
-            If Not IsWrapperWritten Then Throw New FileNotFoundException("释放 Java Wrapper 失败，请查看 PCL 日志查找详细信息")
+            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 = BaseDir & "\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
@@ -707,7 +707,7 @@ Finished:
                    End If
                    '读取文件
                    Dim data As New List(Of Byte)
-                    For Each b As Byte In File.ReadAllBytes(Path)
+                    For Each b As Byte In ReadFileBytes(Path)
                        If b = 9 OrElse b = 10 OrElse b = 13 OrElse b = 32 Then Continue For
                        data.Add(b)
                    Next
@@ -1130,13 +1130,13 @@ Finished:
        Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
        Log($"[Mod] 联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
        If Not Mods.Any() Then Exit Sub
-        For Each Entry In Mods 'TODO: Bookshelf 的 Logo 会在两个网站间横跳
+        For Each Entry In Mods
            Entry.CompLoaded = SucceedThreadCount = 2
            Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
        Next
        WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
-        '刷新下边栏（#4377）
-        RunInUi(Sub() FrmVersionMod?.RefreshBottomBar())
+        '刷新边栏
+        RunInUi(Sub() FrmVersionMod?.RefreshBars())
    End Sub
    Private Function GetTargetModLoaders() As List(Of CompModLoaderType)
        Dim ModLoaders As New List(Of CompModLoaderType)
@@ -100,8 +100,10 @@ Friend Module ModSecret
    ''' <summary>
    ''' 设置 Headers 的 UA、Referer。
    ''' </summary>
-    Friend Sub SecretHeadersSign(Url As String, ByRef Client As CookieWebClient, Optional UseBrowserUserAgent As Boolean = False)
-        If UseBrowserUserAgent Then
+    Friend Sub SecretHeadersSign(Url As String, ByRef Client As WebClient, Optional UseBrowserUserAgent As Boolean = False)
+        If Url.Contains("modrinth.com") Then '根据 #4334，不添加 PCL 的 UA 反而能正常访问
+            Client.Headers("User-Agent") = "Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
+        ElseIf UseBrowserUserAgent Then
            Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
        Else
            Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode
@@ -113,7 +115,9 @@ Friend Module ModSecret
    ''' 设置 Headers 的 UA、Referer。
    ''' </summary>
    Friend Sub SecretHeadersSign(Url As String, ByRef Request As HttpWebRequest, Optional UseBrowserUserAgent As Boolean = False)
-        If UseBrowserUserAgent Then
+        If Url.Contains("modrinth.com") Then '根据 #4334，不添加 PCL 的 UA 反而能正常访问
+            Request.UserAgent = "Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
+        ElseIf UseBrowserUserAgent Then
            Request.UserAgent = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
        Else
            Request.UserAgent = "PCL2/" & VersionStandardCode