InfStarMC/PCL-ISE
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Merge branch 'main' into fix#6230

Browse Source
This commit is contained in:
wyc-26
2025-08-15 16:22:47 +08:00
committed by GitHub
parent ea9bb8f5ed 8e095ddaed
commit 20f9a71f68
131 changed files with 5586 additions and 3367 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Base/ModAnimation.vb
+21 -1
View File
@@ -624,6 +624,26 @@ Public Module ModAnimation
Return Ease.GetValue(t)
End Function
End Class
''' <summary>
''' 以特定速度开始的平滑结束。
''' </summary>
Public Class AniEaseOutFluentWithInitial
Inherits AniEase
Private ReadOnly alpha As Double '(初速度 / 平均速度) – 1
''' <param name="InitialPixelPerSecond">初速度，px/s</param>
''' <param name="TotalSecond">总时长，s</param>
''' <param name="TotalDistance">总路程，px</param>
Public Sub New(InitialPixelPerSecond As Double, TotalSecond As Double, TotalDistance As Double)
Dim v0_norm As Double = InitialPixelPerSecond * TotalSecond / TotalDistance '归一化初速度
alpha = v0_norm - 1.0
If alpha < 0 Then alpha = 0 '初速度小于平均速度时，退化为线性
End Sub
Public Overrides Function GetValue(percent As Double) As Double
Dim p As Double = MathClamp(percent, 0, 1)
If alpha = 0 Then Return p '退化到线性
Return (alpha + 1) * p / (1 + alpha * p)
End Function
End Class
'Back / 回弹
''' <summary>
@@ -807,7 +827,7 @@ Sleeper:
Thread.Sleep(1)
Loop
Catch ex As Exception
Log(ex, "动画帧执行失败", LogLevel.Assert)
Log(ex, "动画帧执行失败", LogLevel.Critical)
End Try
End Sub, "Animation", ThreadPriority.AboveNormal)
End Sub
Plain Craft Launcher 2/Modules/Base/ModBase.vb
+124 -107
View File
@@ -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.0" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.0." & 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 = 357 'Release
Public Const VersionCode As Integer = 367 'Release
#Else
Public Const VersionCode As Integer = 356 'Snapshot
Public Const VersionCode As Integer = 366 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -785,13 +785,16 @@ Public Module ModBase
End Function
'读取、写入、复制文件
''' <summary>
''' 复制文件。会自动创建文件夹、会覆盖已有的文件。
''' </summary>
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 Exit Sub
If FromPath = ToPath Then Return
'确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(ToPath))
'复制文件
@@ -803,7 +806,6 @@ Public Module ModBase
''' <summary>
''' 读取文件，如果失败则返回空数组。
''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte()
Try
'还原文件路径
@@ -859,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))
'写入文件
@@ -884,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))
'写入文件
@@ -1292,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)
@@ -1307,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
@@ -1363,7 +1365,7 @@ RetryDir:
Try
Directory.Delete(Path, True)
Catch ex As Exception
If Not RetriedDir Then
If Not RetriedDir AndAlso Not RunInUi() Then
RetriedDir = True
Log(ex, $"删除文件夹失败，将在 0.3s 后重试（{Path}）")
Thread.Sleep(300)
@@ -1385,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>
@@ -1447,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
@@ -1490,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
@@ -1513,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>
''' 返回一个枚举对应的字符串。
@@ -1549,12 +1541,12 @@ RetryDir:
''' <summary>
''' 获取 JSON 对象。
''' </summary>
Public Function GetJson(Data As String)
Public Function GetJson(Data As String) As JToken
Try
Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
Catch ex As Exception
Dim Length As Integer = If(Data, "").Length
Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data))
Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data), ex)
End Try
End Function
@@ -1981,8 +1973,8 @@ RetryDir:
#Region "系统"
''' <summary>
''' 线程安全的，可以直接使用 For Each 的 List。
''' 在使用 For Each 循环时，列表的结果可能并非最新，但不会抛出异常。
''' 线程安全的 List。
''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
''' </summary>
Public Class SafeList(Of T)
Inherits SynchronizedCollection(Of T)
@@ -2014,8 +2006,8 @@ RetryDir:
End Class
''' <summary>
''' 线程安全的，可以直接使用 For Each 的字典。
''' 在使用 For Each 循环时，字典的结果可能并非最新，但不会抛出异常。
''' 线程安全的字典。
''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
''' </summary>
Public Class SafeDictionary(Of TKey, TValue)
Implements IDictionary(Of TKey, TValue)
@@ -2129,6 +2121,19 @@ RetryDir:
End Function
End Class
''' <summary>
''' 将二维数组转换为字典。
''' </summary>
<Extension> Public Function ToDictionary(Of T)(arr As T(,)) As Dictionary(Of T, T)
Dim result As New Dictionary(Of T, T)
If arr.Length = 0 Then Return result
If arr.GetLength(1) <> 2 Then Throw New ArgumentException("数组必须为两列，第一列为 Key，第二列为 Value。")
For i As Integer = 0 To arr.GetLength(0) - 1
result(arr(i, 0)) = arr(i, 1)
Next
Return result
End Function
''' <summary>
''' 可用于临时存放文件的，不含任何特殊字符的文件夹路径，以“\”结尾。
''' </summary>
@@ -2177,10 +2182,10 @@ RetryDir:
End Function
''' <summary>
''' 判断当前系统语言是否为 zh-CN。
''' 判断当前系统语言是否为中文。
''' </summary>
Public Function IsSystemLanguageChinese() As Boolean
Return CultureInfo.CurrentCulture.Name = "zh-CN" OrElse CultureInfo.CurrentUICulture.Name = "zh-CN"
Return CultureInfo.CurrentCulture.Name.StartsWithF("zh-") OrElse CultureInfo.CurrentUICulture.Name.StartsWithF("zh-")
End Function
Private Uuid As Integer = 1
@@ -2223,6 +2228,9 @@ NextElement:
Next i
Return ResultArray
End Function
<Extension> Public Function Any(Arr As UIElementCollection) As Boolean
Return Arr?.Count > 0
End Function
''' <summary>
''' 获取格式类似于“11:08:52.037”的当前时间的字符串。
@@ -2460,7 +2468,7 @@ NextElement:
''' </summary>
Public Sub RunInThread(Action As Action)
If RunInUi() Then
RunInNewThread(Action, "Runtime Invoke " & GetUuid() & "#")
RunInNewThread(Action, "Invoke " & GetUuid())
Else
Action()
End If
@@ -2623,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
@@ -2638,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
@@ -2647,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
@@ -2669,12 +2666,9 @@ 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 Exit Sub '安全性检查
'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Return '安全性检查
'Select Case control.VerticalAlignment
' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center
' control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
@@ -2687,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
@@ -2758,11 +2751,11 @@ Retry:
Using Reader As New XamlXmlReader(Stream)
While Reader.Read()
For Each BlackListType In {GetType(WebBrowser), GetType(Frame), GetType(MediaElement), GetType(ObjectDataProvider), GetType(XamlReader), GetType(Window), GetType(XmlDataProvider)}
If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 类型。")
If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 值。")
If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 类型。")
If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 值。")
Next
For Each BlackListMember In {"Code", "FactoryMethod", "Static"}
If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListMember} 成员。")
If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListMember} 成员。")
Next
End While
End Using
@@ -2847,9 +2840,10 @@ Retry:
''' </summary>
Feedback = 5
''' <summary>
''' 弹窗，结束程序。
''' 弹出 Windows 原生弹窗，要求反馈。在无法保证 WPF 窗口能正常运行时使用此级别。
''' 在第二次触发后会直接结束程序。
''' </summary>
Assert = 6
Critical = 6
End Enum
Private LogList As New StringBuilder
Private LogWritter As StreamWriter
@@ -2892,7 +2886,7 @@ Retry:
Private ReadOnly LogFlushLock As New Object '防止外部调用 LogFlush 时同时输出多次日志
Public Sub LogFlush()
On Error Resume Next
If LogWritter Is Nothing Then Exit Sub
If LogWritter Is Nothing Then Return
Dim Log As String = Nothing
SyncLock LogFlushLock
If LogList.Length > 0 Then
@@ -2908,6 +2902,7 @@ Retry:
End Sub
Private ReadOnly LogListLock As New Object '防止日志乱码，只在调试模式下启用
Private IsCriticalErrorTriggered As Boolean = False
''' <summary>
''' 输出 Log。
''' </summary>
@@ -2918,7 +2913,7 @@ Retry:
'处理错误会导致再次调用 Log() 导致无限循环
'输出日志
Dim AppendText As String = "[" & GetTimeNow() & "] " & Text & vbCrLf '减轻同步锁占用
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Text}{vbCrLf}" '减轻同步锁占用
If ModeDebug Then
SyncLock LogListLock
LogList.Append(AppendText)
@@ -2929,7 +2924,7 @@ Retry:
#If DEBUG Then
Console.Write(AppendText)
#End If
If IsProgramEnded OrElse Level = LogLevel.Normal Then Exit Sub
If IsProgramEnded OrElse Level = LogLevel.Normal Then Return
'去除前缀
Text = Text.RegexReplace("\[[^\]]+?\] ", "")
@@ -2956,22 +2951,26 @@ Retry:
Else
MyMsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
End If
Case LogLevel.Assert
Dim Time As Long = GetTimeTick()
Case LogLevel.Critical
If IsCriticalErrorTriggered Then
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Return
End If
IsCriticalErrorTriggered = True
If CanFeedback(False) Then
If MsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
Else
MsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
End If
If GetTimeTick() - Time < 1500 Then
'弹窗无法保留
Log("[System] PCL 已崩溃：" & vbCrLf & Text)
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Else
FormMain.EndProgramForce(ProcessReturnValues.Fail)
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>
''' 输出错误信息。
@@ -2979,13 +2978,13 @@ Retry:
''' <param name="Desc">错误描述。会在处理时在末尾加入冒号。</param>
Public Sub Log(Ex As Exception, Desc As String, Optional Level As LogLevel = LogLevel.Debug, Optional Title As String = "出现错误")
On Error Resume Next
If TypeOf Ex Is ThreadInterruptedException Then Exit Sub
If TypeOf Ex Is ThreadInterruptedException Then Return
'获取错误信息
Dim ExFull As String = Desc & "：" & GetExceptionDetail(Ex)
'输出日志
Dim AppendText As String = "[" & GetTimeNow() & "] " & Desc & "：" & GetExceptionDetail(Ex, True) & vbCrLf '减轻同步锁占用
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}：{GetExceptionDetail(Ex, True)}{vbCrLf}" '减轻同步锁占用
If ModeDebug Then
SyncLock LogListLock
LogList.Append(AppendText)
@@ -2996,7 +2995,7 @@ Retry:
#If DEBUG Then
Console.Write(AppendText)
#End If
If IsProgramEnded Then Exit Sub
If IsProgramEnded Then Return
'输出提示
Select Case Level
@@ -3025,22 +3024,26 @@ Retry:
Else
MyMsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
End If
Case LogLevel.Assert
Dim Time As Long = GetTimeTick()
Case LogLevel.Critical
If IsCriticalErrorTriggered Then
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Return
End If
IsCriticalErrorTriggered = True
If CanFeedback(False) Then
If MsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
Else
MsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
End If
If GetTimeTick() - Time < 1500 Then
'弹窗无法保留
Log("[System] PCL 已崩溃：" & vbCrLf & ExFull)
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Else
FormMain.EndProgramForce(ProcessReturnValues.Fail)
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
'反馈
@@ -3050,7 +3053,7 @@ Retry:
If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug，请点击 打开文件夹 按钮，并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关，请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then
OpenExplorer(Path & "PCL\Log1.txt")
End If
OpenWebsite("https://github.com/Hex-Dragon/PCL2/issues/")
OpenWebsite("https://github.com/Meloong-Git/PCL/issues/")
End Sub
Public Function CanFeedback(ShowHint As Boolean) As Boolean
If False.Equals(PageSetupSystem.IsLauncherNewest) Then
@@ -3077,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
'获取当前的堆栈信息
Plain Craft Launcher 2/Modules/Base/ModLoader.vb
+48 -52
View File
@@ -85,7 +85,7 @@
Return _State
End Get
Set(value As LoadState)
If _State = value Then Exit Property
If _State = value Then Return
Dim OldState = _State
If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
_State = value
@@ -112,7 +112,7 @@
Return _LoadingState
End Get
Set(value As MyLoading.MyLoadingState)
If _LoadingState = value Then Exit Property
If _LoadingState = value Then Return
Dim OldState = _LoadingState
_LoadingState = value
RaiseEvent LoadingStateChanged(value, OldState)
@@ -154,7 +154,7 @@
End Select
End Get
Set(value As Double)
If _Progress = value Then Exit Property
If _Progress = value Then Return
Dim OldValue = _Progress
_Progress = value
RaiseEvent ProgressChanged(value, OldValue)
@@ -184,7 +184,7 @@
Thread.Sleep(10)
Loop
If State = LoadState.Finished Then
Exit Sub
Return
ElseIf State = LoadState.Aborted Then
Throw New ThreadInterruptedException("加载器执行已中断。")
ElseIf IsNothing([Error]) Then
@@ -207,7 +207,7 @@
If Timeout < 0 Then Throw New TimeoutException(TimeoutMessage)
Loop
If State = LoadState.Finished Then
Exit Sub
Return
ElseIf State = LoadState.Aborted Then
Throw New ThreadInterruptedException("加载器执行已中断。")
ElseIf IsNothing([Error]) Then
@@ -308,48 +308,49 @@
Progress = -1
End SyncLock
Else
Exit Sub
Return
End If
LastRunningThread = New Thread(
Sub()
Try
IsForceRestarting = IsForceRestart
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
LoadDelegate(Me)
If IsAborted Then
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer)
Else
RaisePreviewFinish()
State = LoadState.Finished
LastFinishedTime = GetTimeTick() '未中断，本次输出有效
End If
Catch ex As CancelledException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
If Not IsAborted Then State = LoadState.Aborted
Catch ex As ThreadInterruptedException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
'如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted
If Not IsAborted Then State = LoadState.Aborted
Catch ex As Exception
If IsAborted Then Exit Sub
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer)
[Error] = ex
State = LoadState.Failed
End Try
End Sub) With {.Name = Name, .Priority = ThreadPriority}
Sub()
Try
IsForceRestarting = IsForceRestart
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
LoadDelegate(Me)
If IsAborted Then
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer)
Return
End If
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成")
RaisePreviewFinish()
State = LoadState.Finished
LastFinishedTime = GetTimeTick() '未中断，本次输出有效
Catch ex As CancelledException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
If Not IsAborted Then State = LoadState.Aborted
Catch ex As ThreadInterruptedException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
'如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted
If Not IsAborted Then State = LoadState.Aborted
Catch ex As Exception
If IsAborted Then Return
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer)
[Error] = ex
State = LoadState.Failed
End Try
End Sub) With {.Name = "L/" & Name, .Priority = ThreadPriority}
LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted
End Sub
Public Overrides Sub Abort()
If State <> LoadState.Loading Then Exit Sub
If State <> LoadState.Loading Then Return
SyncLock LockState
State = LoadState.Aborted
End SyncLock
TriggerThreadAbort()
End Sub
Private Sub TriggerThreadAbort()
If LastRunningThread Is Nothing Then Exit Sub
If LastRunningThread Is Nothing Then Return
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断")
If LastRunningThread.IsAlive Then LastRunningThread.Interrupt()
LastRunningThread = Nothing
@@ -419,7 +420,7 @@
'改变状态
SyncLock LockState
If State = LoadState.Loading Then
Exit Sub
Return
Else
State = LoadState.Loading
End If
@@ -439,7 +440,7 @@
If State = LoadState.Loading OrElse State = LoadState.Waiting Then
State = LoadState.Aborted
Else
Exit Sub
Return
End If
End SyncLock
RunInThread(
@@ -470,7 +471,7 @@
Case Else
'完蛋，出错了
SyncLock LockState
If State >= LoadState.Finished Then Exit Sub
If State >= LoadState.Finished Then Return
[Error] = New Exception(Loader.Name & "失败", Loader.Error)
State = Loader.State
End SyncLock
@@ -478,14 +479,14 @@
Loader.Abort()
Next
FrmMain.BtnExtraDownload.ShowRefresh()
Exit Sub
Return
End Select
End Sub
''' <summary>
''' 触发一次更新，以启动新加载器或完成。
''' </summary>
Private Sub Update()
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Exit Sub
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Return
Dim IsFinished As Boolean = True
Dim Blocked As Boolean = False
Dim Input As Object = Me.Input
@@ -584,16 +585,11 @@ Restart:
Try
Dim NewState As Shell.TaskbarItemProgressState
Dim NewProgress As Double = LoaderTaskbarProgressGet()
'检查任务是否完成，若完成则移除
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar.ToList()
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成，则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
'若单个任务已中止，或全部任务已完成，则刷新并移除
For Each Task In LoaderTaskbar
If LoaderTaskbar.All(Function(l) l.State <> LoadState.Loading) OrElse
(Task.State = LoadState.Waiting OrElse Task.State = LoadState.Aborted) Then
FrmSpeedLeft?.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
@@ -625,8 +621,8 @@ Restart:
End Sub
Public Function LoaderTaskbarProgressGet() As Double
Try
If Not LoaderTaskbar.Where(Function(l) l.Show).Any Then Return 1
Return MathClamp(LoaderTaskbar.Where(Function(l) l.Show).Select(Function(l) l.Progress).Average(), 0, 1)
If Not LoaderTaskbar.Any Then Return 1
Return MathClamp(LoaderTaskbar.Select(Function(l) l.Progress).Average(), 0, 1)
Catch ex As Exception
Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
Return 0.5
Plain Craft Launcher 2/Modules/Base/ModNet.vb
+523 -718
View File
File diff suppressed because it is too large Load Diff
Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb
+92 -63
View File
@@ -78,8 +78,8 @@
If SplitedLine.Count >= 2 Then
Entry.ChineseName = SplitedLine(1)
If Entry.ChineseName.Contains("*") Then '处理 *
Entry.ChineseName = Entry.ChineseName.Replace("*", " (" &
String.Join(" ", If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Split("-").Select(Function(w) w.Substring(0, 1).ToUpper & w.Substring(1, w.Length - 1))) & ")")
Entry.ChineseName = Entry.ChineseName.Replace("*",
$" ({If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Replace("-", " ").Capitalize})")
End If
End If
_CompDatabase.Add(Entry)
@@ -491,6 +491,9 @@
Case "path-tracing" : Tags.Add("路径追踪")
Case "pbr" : Tags.Add("PBR")
Case "reflections" : Tags.Add("反射")
Case "iris" : Tags.Add("Iris")
Case "optifine" : Tags.Add("OptiFine")
Case "vanilla" : Tags.Add("原版可用")
End Select
Next
@@ -947,38 +950,39 @@ NoSubtitle:
''' 根据搜索请求获取一系列的工程列表。需要基于加载器运行。
''' </summary>
Public Sub CompProjectsGet(Task As LoaderTask(Of CompProjectRequest, Integer))
Dim Storage = Task.Input.Storage '避免多线程问题
Dim Request As CompProjectRequest = Task.Input
Dim Storage = Request.Storage '避免多线程问题
If Task.Input.Storage.Results.Count >= Task.Input.TargetResultCount Then
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果，多于所需的 {Task.Input.TargetResultCount} 个结果，结束处理")
Exit Sub
ElseIf Not Task.Input.CanContinue Then
If Not Task.Input.Storage.Results.Any() Then
If Request.Storage.Results.Count >= Request.TargetResultCount Then
Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理")
Return
ElseIf Not Request.CanContinue Then
If Not Request.Storage.Results.Any() Then
Throw New Exception("没有符合条件的结果")
Else
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果，少于所需的 {Task.Input.TargetResultCount} 个结果，但无法继续获取，结束处理")
Exit Sub
Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理")
Return
End If
End If
#Region "拒绝 1.13- Quilt（这个版本根本没有 Quilt）"
If Task.Input.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Task.Input.GameVersion, "1.15"), "1.14") = -1 Then
Throw New Exception("Quilt 不支持 Minecraft " & Task.Input.GameVersion)
If Request.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Request.GameVersion, "1.15"), "1.14") = -1 Then
Throw New Exception("Quilt 不支持 Minecraft " & Request.GameVersion)
End If
#End Region
#Region "处理搜索文本，赋值回 Task.Input.SearchText"
Dim RawFilter As String = If(Task.Input.SearchText, "").Trim
Task.Input.SearchText = RawFilter
Dim RawFilter As String = If(Request.SearchText, "").Trim
Request.SearchText = RawFilter
RawFilter = RawFilter.ToLower
Log("[Comp] 工程列表搜索原始文本：" & RawFilter)
'中文请求关键字处理
Dim IsChineseSearch As Boolean = RegexCheck(RawFilter, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawFilter)
If IsChineseSearch AndAlso (Task.Input.Type = CompType.Mod OrElse Task.Input.Type = CompType.DataPack) Then
If IsChineseSearch AndAlso (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
'构造搜索请求
Dim SearchEntries As New List(Of SearchEntry(Of CompDatabaseEntry))
For Each Entry In CompDatabase
@@ -991,7 +995,7 @@ NoSubtitle:
})
Next
'获取搜索结果
Dim SearchResults = Search(SearchEntries, Task.Input.SearchText, 3)
Dim SearchResults = Search(SearchEntries, Request.SearchText, 3)
If Not SearchResults.Any() Then Throw New Exception("无搜索结果，请尝试搜索英文名称")
Dim SearchResult As String = ""
For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的，也最多只要 5 个
@@ -1009,14 +1013,14 @@ NoSubtitle:
If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For
RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " "
Next
Task.Input.SearchText = RealFilter
Request.SearchText = RealFilter
Log("[Comp] 中文搜索最终关键词：" & RealFilter, LogLevel.Developer)
End If
'驼峰英文请求关键字处理
Dim SpacedKeywords = Task.Input.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ")
Dim ConnectedKeywords = Task.Input.SearchText.Replace(" ", "")
Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Task.Input.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower
Dim SpacedKeywords = Request.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ")
Dim ConnectedKeywords = Request.SearchText.Replace(" ", "")
Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Request.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower
'最终处理关键字：分割、去重
Dim RightKeywords As New List(Of String)
@@ -1030,15 +1034,15 @@ NoSubtitle:
RightKeywords.Add(Keyword)
Next
If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then
Task.Input.SearchText = RawFilter '全都被过滤掉了
Request.SearchText = RawFilter '全都被过滤掉了
Else
Task.Input.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
Request.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
End If
'例外项：OptiForge、OptiFabric（拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod）
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Task.Input.SearchText = "optiforge"
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Task.Input.SearchText = "optifabric"
Log("[Comp] 工程列表搜索最终文本：" & Task.Input.SearchText, LogLevel.Debug)
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Request.SearchText = "optiforge"
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Request.SearchText = "optifabric"
Log("[Comp] 工程列表搜索最终文本：" & Request.SearchText, LogLevel.Debug)
Task.Progress = 0.1
#End Region
@@ -1054,10 +1058,17 @@ Retry:
Dim ModrinthThread As Thread = Nothing
Dim ResultsLock As New Object
'在 1.14-，部分老 Mod 没有设置支持的加载器，因此添加 Forge 筛选就会出现遗漏
'所以，在发起请求时不筛选加载器，然后在返回的结果中自行筛除不是 Forge 的 Mod
Dim IsOldForgeRequest = Request.ModLoader = CompModLoaderType.Forge AndAlso Request.GameVersion?.Contains(".") AndAlso Val(Request.GameVersion.Split(".")(1)) < 14
If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Any
Dim CurseForgeUrl As String = Request.GetCurseForgeAddress()
Dim ModrinthUrl As String = Request.GetModrinthAddress()
If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Forge '设置回去
Try
'启动 CurseForge 线程
Dim CurseForgeUrl As String = Task.Input.GetCurseForgeAddress()
Dim CurseForgeFailed As Boolean = False
If CurseForgeUrl IsNot Nothing Then
CurseForgeThread = RunInNewThread(
@@ -1065,12 +1076,12 @@ Retry:
Try
'获取工程列表
Log("[Comp] 开始从 CurseForge 获取工程列表：" & CurseForgeUrl)
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl, IsJson:=True)
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("data")
Dim Project As New CompProject(JsonEntry)
If Task.Input.Type = CompType.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包
If Request.Type = CompType.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包
ProjectList.Add(Project)
Next
'更新结果
@@ -1090,14 +1101,13 @@ Retry:
End If
'启动 Modrinth 线程
Dim ModrinthUrl As String = Task.Input.GetModrinthAddress()
Dim ModrinthFailed As Boolean = False
If ModrinthUrl IsNot Nothing Then
ModrinthThread = RunInNewThread(
Sub()
Try
Log("[Comp] 开始从 Modrinth 获取工程列表：" & ModrinthUrl)
Dim RequestResult As JObject = DlModRequest(ModrinthUrl, IsJson:=True)
Dim RequestResult As JObject = DlModRequest(ModrinthUrl)
Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("hits")
@@ -1123,9 +1133,14 @@ Retry:
'等待线程结束
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Join()
If Task.IsAborted Then Exit Sub '会自动触发 Finally
If Task.IsAborted Then Return '会自动触发 Finally
If ModrinthThread IsNot Nothing Then ModrinthThread.Join()
If Task.IsAborted Then Exit Sub
If Task.IsAborted Then Return
'筛除不是 Forge 的 Mod
If IsOldForgeRequest Then
RawResults = RawResults.Where(Function(p) Not p.ModLoaders.Any() OrElse p.ModLoaders.Contains(CompModLoaderType.Forge)).ToList
End If
'确保存在结果
Storage.ErrorMessage = Nothing
@@ -1133,11 +1148,11 @@ Retry:
If [Error] IsNot Nothing Then
Throw [Error]
Else
If IsChineseSearch AndAlso Not (Task.Input.Type = CompType.Mod OrElse Task.Input.Type = CompType.DataPack) Then
If IsChineseSearch AndAlso Not (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
Throw New Exception("没有搜索结果，请尝试使用英文搜索")
ElseIf Task.Input.Source = CompSourceType.CurseForge AndAlso Task.Input.Tag.StartsWithF("/") Then
ElseIf Request.Source = CompSourceType.CurseForge AndAlso Request.Tag.StartsWithF("/") Then
Throw New Exception("CurseForge 不兼容所选的类型")
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWithF("/") Then
ElseIf Request.Source = CompSourceType.Modrinth AndAlso Request.Tag.EndsWithF("/") Then
Throw New Exception("Modrinth 不兼容所选的类型")
Else
Throw New Exception("没有搜索结果")
@@ -1146,15 +1161,15 @@ Retry:
ElseIf [Error] IsNot Nothing Then
'有结果但是有错误
If CurseForgeFailed Then
Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。"
Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。"
Else
Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。"
Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。"
End If
End If
Finally
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Interrupt()
If ModrinthThread IsNot Nothing Then ModrinthThread.Interrupt()
CurseForgeThread?.Interrupt()
ModrinthThread?.Interrupt()
End Try
#End Region
@@ -1177,9 +1192,9 @@ Retry:
#Region "检查结果数量，如果不足且可继续，会继续加载下一页"
If RealResults.Count + Storage.Results.Count < Task.Input.TargetResultCount Then
Log($"[Comp] 总结果数需求最少 {Task.Input.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
If Task.Input.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试，这时候重试可能导致无限循环
If RealResults.Count + Storage.Results.Count < Request.TargetResultCount Then
Log($"[Comp] 总结果数需求最少 {Request.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
If Request.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试，这时候重试可能导致无限循环
Log("[Comp] 将继续尝试加载下一页")
GoTo Retry
Else
@@ -1194,7 +1209,7 @@ Retry:
Dim Scores As New Dictionary(Of CompProject, Double) '排序分
Dim GetDownloadCountMult =
Function(Project As CompProject) As Double
Select Case Task.Input.Type
Select Case Request.Type
Case CompType.Mod, CompType.ModPack
Return If(Project.FromCurseForge, 1, 7)
Case CompType.DataPack
@@ -1205,7 +1220,7 @@ Retry:
Return 1
End Select
End Function
If String.IsNullOrEmpty(Task.Input.SearchText) Then
If String.IsNullOrEmpty(Request.SearchText) Then
'如果没有搜索文本，按下载量将结果排序
For Each Result As CompProject In RealResults
Scores.Add(Result, Result.DownloadCount * GetDownloadCountMult(Result))
@@ -1381,7 +1396,7 @@ Retry:
'DownloadAddress
Dim Url = Data("downloadUrl").ToString
If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
Url = Url.Replace(FileName, Net.WebUtility.UrlEncode(FileName)) '对文件名进行编码
Url = Url.Replace(FileName, WebUtility.UrlEncode(FileName)) '对文件名进行编码
DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源，这个写法是为了让镜像源排在后面
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
@@ -1475,9 +1490,10 @@ Retry:
''' </summary>
Public Shared Function HandleCurseForgeDownloadUrls(Url As String) As List(Of String)
Return {
Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."),
Url.Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"),
Url.Replace("://media.", "://edge."),
Url
}.Distinct.ToList
End Function
@@ -1574,27 +1590,40 @@ Retry:
If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存
TargetProject = CompProjectCache(ProjectId)
ElseIf FromCurseForge Then 'CurseForge
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data"))
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId)("data"))
Else 'Modrinth
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True))
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId))
End If
'获取工程对象的文件列表
If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回，这时候前置可能没获取（#5173）
Log("[Comp] 开始获取文件列表：" & ProjectId)
Dim ResultJsonArray As JArray
Dim ResultJsonArray As JArray = Nothing
If FromCurseForge Then
'CurseForge
'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522）
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=10000", IsJson:=True)("data")
'之前只请求一部分文件的方法备份如下：
'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
' ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data")
'Else '否则使用全部文件
' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data")
'End If
For RetryCount As Integer = 0 To 2
Dim ResultJson As JObject = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=" &
(10000 + RetryCount)) '每次重试多请求一个文件，以避免触发 CDN 缓存
'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522）
'之前只请求一部分文件的方法备份如下：
'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
' ResultJsonArray = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json")("data")
'Else '否则使用全部文件
' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999")("data")
'End If
If ResultJson("pagination")("resultCount").ToObject(Of Integer) = ResultJson("pagination")("totalCount").ToObject(Of Integer) Then
ResultJsonArray = ResultJson("data")
Exit For
ElseIf RetryCount < 2 Then
Log($"[Comp] CurseForge 返回的文件列表存在缺失，即将进行第 {RetryCount + 1} 次重试", LogLevel.Debug) '#6224
Log($"[Comp] 返回的原始内容如下：{vbCrLf}{ResultJson}")
Else
Log($"[Comp] CurseForge 返回的文件列表存在缺失，返回的原始内容如下：{vbCrLf}{ResultJson}")
Throw New Exception("CurseForge 返回的文件列表存在缺失")
End If
Next
Else
'Modrinth
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True)
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version")
End If
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
Where(Function(a) a.Available).ToList.
@@ -1608,10 +1637,10 @@ Retry:
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置：{Join(UndoneDeps, "，")}")
Dim Projects As JArray
If TargetProject.FromCurseForge Then
Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods",
"POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data")
Projects = DlModRequest("https://api.curseforge.com/v1/mods",
HttpMethod.Post, "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json")("data")
Else
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]", IsJson:=True)
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]")
End If
For Each Project In Projects
Dim Unused As New CompProject(Project) '在 New 的时候会添加缓存以便之后读取
@@ -1638,7 +1667,7 @@ Retry:
'如果为整合包就不会有 Dependencies 信息，所以不用管
Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList()
Deps.Sort()
If Not Deps.Any() Then Exit Sub
If Not Deps.Any() Then Return
Deps = Deps.Where(
Function(dep)
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置信息", LogLevel.Debug)
Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb
+102 -88
View File
@@ -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\")
@@ -71,11 +73,7 @@
'将可能可用的日志文件导出
For Each FilePath In RightLogs
Try
If FilePath.Contains("crash-") Then
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
Else
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath, Encoding.UTF8).Split(vbCrLf.ToCharArray)))
End If
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
Catch ex As Exception
Log(ex, "读取可能的崩溃日志文件失败（" & FilePath & "）")
End Try
@@ -117,11 +115,7 @@ Extracted:
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
Dim Ext As String = TargetFile.Extension.ToLower
If Ext = ".log" OrElse Ext = ".txt" Then
If TargetFile.Name.StartsWithF("crash-") Then
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
Else
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName, Encoding.UTF8).Split(vbCrLf.ToCharArray)))
End If
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
Else
File.Delete(TargetFile.FullName)
End If
@@ -137,20 +131,21 @@ Extracted:
Private Enum AnalyzeFileType
HsErr
MinecraftLog
ExtraLog
ExtraLogFile
ExtraReportFile
CrashReport
End Enum
Private DirectFile As KeyValuePair(Of String, String())? = Nothing '在弹窗中选择直接打开的文件
''' <summary>
''' 从 AnalyzeRawFiles 中提取实际有用的文本片段存储到 AnalyzeFiles，并整理可用于生成报告的文件。
''' 返回找到的用于分析的项目数。
''' 返回是否有足够信息可用于分析。
''' </summary>
Public Function Prepare() As Integer
Public Function Prepare() As Boolean
Log("[Crash] 步骤 2：准备日志文本")
'对日志文件进行分类
DirectFile = Nothing
Dim TotalFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String())))
Dim AllFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String())))
For Each LogFile In AnalyzeRawFiles
Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower
Dim TargetType As AnalyzeFileType
@@ -170,27 +165,35 @@ Extracted:
TargetType = AnalyzeFileType.MinecraftLog
If DirectFile Is Nothing Then DirectFile = LogFile
Else
TargetType = AnalyzeFileType.ExtraLog
TargetType = AnalyzeFileType.ExtraLogFile
End If
ElseIf MatchName.EndsWithF(".log", True) OrElse MatchName.EndsWithF(".txt", True) Then
TargetType = AnalyzeFileType.ExtraLog
ElseIf MatchName.EndsWithF(".log", True) Then
TargetType = AnalyzeFileType.ExtraLogFile
ElseIf MatchName.EndsWithF(".txt", True) Then
TargetType = AnalyzeFileType.ExtraReportFile
Else
Log("[Crash] " & MatchName & " 分类为 Ignore")
Continue For
End If
If Not LogFile.Value.Any() Then
Log("[Crash] " & MatchName & " 由于内容为空跳过")
Else
TotalFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
If LogFile.Value.Any Then
AllFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
Log("[Crash] " & MatchName & " 分类为 " & GetStringFromEnum(TargetType))
Else
Log("[Crash] " & MatchName & " 由于内容为空跳过")
End If
Next
'若只有额外日志，则将它们视作 Minecraft 日志
If AllFiles.Any() AndAlso AllFiles.All(Function(p) p.Key = AnalyzeFileType.ExtraLogFile) Then
Log("[Crash] 由于仅发现了额外日志，将它们视作 Minecraft 日志进行分析")
AllFiles = AllFiles.Select(Function(p) New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(AnalyzeFileType.MinecraftLog, p.Value)).ToList
End If
'将分类后的文件分别写入
For Each SelectType In {AnalyzeFileType.MinecraftLog, AnalyzeFileType.HsErr, AnalyzeFileType.ExtraLog, AnalyzeFileType.CrashReport}
For Each SelectType In {AnalyzeFileType.MinecraftLog, AnalyzeFileType.HsErr, AnalyzeFileType.ExtraLogFile, AnalyzeFileType.CrashReport}
'获取该种类的所有文件 {文件路径 -> 文件内容行}
Dim SelectedFiles As New List(Of KeyValuePair(Of String, String()))
For Each File In TotalFiles
For Each File In AllFiles
If SelectType = File.Key Then SelectedFiles.Add(File.Value)
Next
If Not SelectedFiles.Any() Then Continue For
@@ -232,54 +235,59 @@ Extracted:
Next
'选择一份最佳的来自启动器的游戏日志
For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt", "PCL 启动器日志.txt"}
If FileNameDict.ContainsKey(FileName) Then
Dim CurrentLog = FileNameDict(FileName)
'截取 “以下为游戏输出的最后一段内容” 后的内容
Dim HasLauncherMark As Boolean = False
For Each Line In CurrentLog.Value
If HasLauncherMark Then
LogMc += Line & vbLf
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
HasLauncherMark = True
Log("[Crash] 找到 PCL 输出的游戏实时日志头")
End If
Next
'导入后 500 行
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
Exit For
End If
If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName)
'截取 “以下为游戏输出的最后一段内容” 后的内容
Dim HasLauncherMark As Boolean = False
For Each Line In CurrentLog.Value
If HasLauncherMark Then
LogMc += Line & vbLf
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
HasLauncherMark = True
Log("[Crash] 找到 PCL 输出的游戏实时日志头")
End If
Next
'导入后 500 行
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
Exit For
Next
'选择一份最佳的 Minecraft Log
For Each FileName As String In {"latest.log", "latest log.txt", "debug.log", "debug log.txt"}
If FileNameDict.ContainsKey(FileName) Then
Dim CurrentLog = FileNameDict(FileName)
LogMc += GetHeadTailLines(CurrentLog.Value, 250, 500)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
Exit For
End If
If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName)
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
Exit For
Next
'查找 Debug Log
For Each FileName As String In {"debug.log", "debug log.txt"}
If FileNameDict.ContainsKey(FileName) Then
Dim CurrentLog = FileNameDict(FileName)
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft Debug 日志")
Exit For
End If
If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName)
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft Debug 日志")
Exit For
Next
'检查错误
'兜底
If LogMc = "" Then
LogMc = Nothing
Throw New Exception("无法找到匹配的 Minecraft Log")
If LogMcDebug <> "" Then '如果没有找到 Minecraft 日志，则使用 Debug 日志作为兜底
LogMc = LogMcDebug
ElseIf FileNameDict.Any() Then '如果都没有找到，则使用第一个文件
Dim CurrentLog = FileNameDict.First.Value
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为兜底日志")
Else
LogMc = Nothing
Throw New Exception("无法找到匹配的 Minecraft Log")
End If
End If
If LogMcDebug = "" Then LogMcDebug = Nothing
Case AnalyzeFileType.ExtraLog
Case AnalyzeFileType.ExtraLogFile, AnalyzeFileType.ExtraReportFile
'全部丢过去
For Each SelectedFile In SelectedFiles
OutputFiles.Add(SelectedFile.Key)
Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为额外日志")
Log("[Crash] 输出报告：" & SelectedFile.Key & "，不用作分析")
Next
End Select
Catch ex As Exception
@@ -287,15 +295,13 @@ Extracted:
End Try
Next
'获取种类数
Dim ResultCount As Integer = If(LogMc Is Nothing, 0, 1) + If(LogHs Is Nothing, 0, 1) + If(LogCrash Is Nothing, 0, 1)
If ResultCount = 0 Then
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
Else
'结束
Prepare = LogMc IsNot Nothing OrElse LogHs IsNot Nothing OrElse LogCrash IsNot Nothing
If Prepare Then
Log(("[Crash] 步骤 2：准备日志文本完成，找到" & If(LogMc Is Nothing, "", "游戏日志、") & If(LogMcDebug Is Nothing, "", "游戏 Debug 日志、") & If(LogHs Is Nothing, "", "虚拟机日志、") & If(LogCrash Is Nothing, "", "崩溃日志、")).TrimEnd("、") & "用作分析")
Else
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
End If
Return ResultCount
End Function
''' <summary>
''' 输出字符串的前后某些行，并统一行尾为 vbLf (正则 \n)、删除空行和重复行。
@@ -386,7 +392,7 @@ Extracted:
''' </summary>
Public Sub Analyze(Optional Version As McVersion = Nothing)
Log("[Crash] 步骤 3：分析崩溃原因")
LogAll = (If(LogMc, "") & If(LogMcDebug, "") & If(LogHs, "") & If(LogCrash, ""))
LogAll = If(LogMc, If(LogMcDebug, "")) & If(LogHs, "") & If(LogCrash, "")
'1. 精准日志匹配，中/高优先级
AnalyzeCrit1()
@@ -472,7 +478,7 @@ Done:
'空白分析
If LogMc Is Nothing AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing Then
AppendReason(CrashReason.没有可用的分析文件)
Exit Sub
Return
End If
'崩溃报告分析，高优先级
@@ -504,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.材质过大或显卡配置不足)
@@ -614,9 +620,9 @@ Done:
Dim IsMixin As Boolean = MixinAnalyze(LogMc)
'常规信息
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, RegexSeek(LogMc, "(?<=the game will display an error screen and halt.[\n\r]+[^\n]+?Exception: )[\s\S]+?(?=\n\tat)")?.Trim(vbCrLf))
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
If Not IsMixin AndAlso LogMc.Contains("due to errors, provided by ") Then '在 #3104 的情况下，这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败
AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
End If
@@ -704,11 +710,12 @@ NextStack:
If Word.Length <= 2 OrElse Word.StartsWithF("func_") Then Continue For
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top", "mcp",
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi", "impl", "data", "pool", "task",
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world",
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world", "lwjgl",
"gitlab", "common", "server", "config", "mixins", "compat", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events",
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
"fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge",
"injection", "listeners", "scheduler", "minecraft", "transformer", "transformers", "neoforged", "universal", "multipart", "minecraftforge", "blockentity", "spongepowered", "electronwill"
"injection", "listeners", "scheduler", "minecraft", "universal", "multipart", "neoforged", "microsoft",
"transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill"
}.Contains(Word.ToLower) Then Continue For
PossibleWords.Add(Word.Trim)
Next
@@ -851,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
@@ -873,7 +881,7 @@ NextStack:
Try
'获取文件路径
RunInUiWait(Sub() FileAddress = SelectSaveFile("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", "Minecraft 错误报告(*.zip)|*.zip"))
If String.IsNullOrEmpty(FileAddress) Then Exit Sub
If String.IsNullOrEmpty(FileAddress) Then Return
Directory.CreateDirectory(GetPathFromFullPath(FileAddress))
If File.Exists(FileAddress) Then File.Delete(FileAddress)
'输出诊断信息
@@ -896,9 +904,10 @@ NextStack:
End Select
If File.Exists(OutputFile) Then
If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile))
WriteFile(TempFolder & "Report\" & FileName,
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
Encoding:=FileEncoding)
Dim FileContent As String = ReadFile(OutputFile, FileEncoding)
FileContent = FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*"))
FileContent = FilterUserName(FileContent, "*")
WriteFile(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding)
Log($"[Crash] 导出文件：{FileName}，编码：{FileEncoding.HeaderName}")
End If
Next
@@ -908,10 +917,15 @@ NextStack:
Hint("错误报告已导出！", HintType.Finish)
Catch ex As Exception
Log(ex, "导出错误报告失败", LogLevel.Feedback)
Exit Sub
Return
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>
''' 获取崩溃分析的结果描述。
@@ -937,7 +951,7 @@ NextStack:
Case CrashReason.内存不足
Results.Add("Minecraft 内存不足，导致其无法继续运行。\n这很可能是因为电脑内存不足、游戏分配的内存不足，或是配置要求过高。\n\n你可以尝试在 更多 → 百宝箱 中选择 内存优化，然后再启动游戏。\n如果还是不行，请在启动设置中增加为游戏分配的内存，并删除配置要求较高的材质、Mod、光影。\n如果依然不奏效，请在开始游戏前尽量关闭其他软件，或者……换台电脑？\h")
Case CrashReason.使用OpenJ9
Results.Add("游戏因为使用 Open J9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java，然后再启动游戏。")
Results.Add("游戏因为使用 OpenJ9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java，然后再启动游戏。")
Case CrashReason.使用JDK
Results.Add("游戏似乎因为使用 JDK，或 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8（Java 8），然后再启动游戏。\n如果你没有安装 JRE 8，你可以从网络中下载、安装一个。")
Case CrashReason.Java版本过高
@@ -1012,14 +1026,14 @@ NextStack:
End If
Case CrashReason.特定实体导致崩溃
If Additional.Count = 1 Then
Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况：\n - 若正常运行，则是该实体导致出错，你或许需要使用一些方式删除此实体。\n - 若仍然出错，问题就可能来自其他原因……\h")
Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况。\h")
Else
Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，观察游戏的运行情况：\n - 若正常运行，则是某些实体导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h")
Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，然后观察游戏的运行情况。\h")
End If
Case CrashReason.OptiFine与Forge不兼容
Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容，导致了游戏崩溃。\n\n请前往 OptiFine 官网（https://optifine.net/downloads）查看 OptiFine 所兼容的 Forge 版本，并严格按照对应版本重新安装游戏。")
Case CrashReason.ShadersMod与OptiFine同时安装
Results.Add("无需同时安装 Optifine 和 Shaders Mod，OptiFine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后，游戏即可正常运行。")
Results.Add("无需同时安装 OptiFine 和 Shaders Mod，OptiFine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后，游戏即可正常运行。")
Case CrashReason.低版本Forge与高版本Java不兼容
Results.Add("由于低版本 Forge 与当前 Java 不兼容，导致了游戏崩溃。\n\n请尝试以下解决方案：\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 1.8.0.320 的 Java")
Case CrashReason.版本Json中存在多个Forge
@@ -1096,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
Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb
+54 -83
View File
@@ -198,7 +198,7 @@
Private IsNewClientVersionHinted As Boolean = False
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim StartTime As Long = GetTimeTick()
Dim Json As JObject = NetGetCodeByRequestRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", IsJson:=True)
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json"))
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）")
@@ -235,7 +235,7 @@
''' </summary>
Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", IsJson:=True)
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json"))
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）")
@@ -244,7 +244,7 @@
'检查是否有要求的版本（#5195）
If Not String.IsNullOrEmpty(Loader.Input) Then
Dim Id = Loader.Input
If Not DlClientListLoader.Output.Value("versions").Any(Function(v) v("id") = Id) Then
If DlClientListLoader.Output.Value IsNot Nothing AndAlso Not DlClientListLoader.Output.Value("versions").Any(Function(v) v("id") = Id) Then
Throw New Exception("BMCLAPI 源未包含目标版本 " & Id)
End If
End If
@@ -377,7 +377,7 @@
''' </summary>
Public DlOptiFineListOfficialLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Official", AddressOf DlOptiFineListOfficialMain)
Private Sub DlOptiFineListOfficialMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
Dim Result As String = NetGetCodeByClient("https://optifine.net/downloads", Encoding.Default)
Dim Result As String = NetRequestByClientRetry("https://optifine.net/downloads", Encoding:=Encoding.Default)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
Try
'获取所有版本信息
@@ -413,7 +413,7 @@
''' </summary>
Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain)
Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/optifine/versionList", IsJson:=True)
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList"))
Try
Dim Versions As New List(Of DlOptiFineListEntry)
For Each Token As JObject In Json
@@ -483,7 +483,7 @@
''' </summary>
Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain)
Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html", UseBrowserUserAgent:=True)
Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", UseBrowserUserAgent:=True)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)")
@@ -497,7 +497,7 @@
''' </summary>
Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain)
Private Sub DlForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Dim Result As String = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding.Default)
Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding:=Encoding.Default)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?")
@@ -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
@@ -629,7 +629,7 @@
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Result As String
Try
Result = NetGetCodeByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
Result = NetRequestByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4，#4057
".html", UseBrowserUserAgent:=True)
Catch ex As Exception
@@ -700,9 +700,8 @@
''' Forge 版本列表，BMCLAPI。
''' </summary>
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
Loader.Input.Replace("-", "_"), '兼容 Forge 1.7.10-pre4，#4057
IsJson:=True)
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
Loader.Input.Replace("-", "_"))) '兼容 Forge 1.7.10-pre4，#4057
Dim Versions As New List(Of DlForgeVersionEntry)
Try
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
@@ -840,8 +839,8 @@
Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain)
Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON
Dim ResultLatest As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLegacy As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge")
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）")
'解析
Try
@@ -858,8 +857,8 @@
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain)
Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON
Dim ResultLatest As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLegacy As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge")
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）")
'解析
Try
@@ -964,7 +963,7 @@
''' </summary>
Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain)
Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://dl.liteloader.com/versions/versions.json", IsJson:=True)
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json"))
Try
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -992,7 +991,7 @@
''' </summary>
Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain)
Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", IsJson:=True)
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json"))
Try
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -1063,7 +1062,7 @@
''' </summary>
Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain)
Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://meta.fabricmc.net/v2/versions", IsJson:=True)
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions"))
Try
Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result}
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1078,7 +1077,7 @@
''' </summary>
Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain)
Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", IsJson:=True)
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions"))
Try
Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result}
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1105,72 +1104,37 @@
#Region "DlMod | Mod 镜像源请求"
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。
''' 调用 NetGetCodeByRequest，会进行重试。
''' </summary>
Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As Object
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
'Dim McimUrl As String = DlSourceModGet(Url)
'If McimUrl <> Url Then
' Select Case Setup.Get("ToolDownloadMod")
' Case 0
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Case 1
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Case Else
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' End Select
'End If
Dim Exs As String = ""
For Each Source In Urls
Try
Return NetGetCodeByRequestOnce(Source.Key, Encode:=Encoding.UTF8, Timeout:=Source.Value * 1000, IsJson:=IsJson, UseBrowserUserAgent:=True)
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
Next
Throw New Exception(Exs)
End Function
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理。
''' 对可能涉及 Mod 镜像源的请求进行处理，返回 JToken。
''' 调用 NetRequest，会进行重试。
''' </summary>
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String) As String
Public Function DlModRequest(Url As String, Optional Method As HttpMethod = Nothing,
Optional Content As String = Nothing, Optional ContentType As String = Nothing) As JToken
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
'Dim McimUrl As String = DlSourceModGet(Url)
'If McimUrl <> Url Then
' Select Case Setup.Get("ToolDownloadMod")
' Case 0
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Case 1
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Case Else
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' End Select
'End If
Dim McimUrl As String = DlSourceModGet(Url)
If McimUrl <> Url Then
Select Case 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
Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000)
Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8))
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
@@ -1273,7 +1237,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 自动切换
@@ -1295,7 +1266,7 @@
'检查加载器成功
MainLoader.Output = SubLoader.Key.Output
DlSourceLoaderAbort(LoaderList)
Exit Sub
Return
ElseIf BeforeLoadersAllFailed Then
'此前的加载器全部失败，直接启动后续加载器
If WaitCycle < SubLoader.Value * 100 Then WaitCycle = SubLoader.Value * 100
@@ -1337,7 +1308,7 @@
'检查父加载器中断
If MainLoader.IsAborted Then
DlSourceLoaderAbort(LoaderList)
Exit Sub
Return
End If
Loop
End Sub
Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb
+16 -8
View File
@@ -98,7 +98,7 @@
''' 检查并获取 Java 详细信息。在 Java 存在异常时抛出错误。
''' </summary>
Public Sub Check()
If IsChecked Then Exit Sub
If IsChecked Then Return
Dim Output As String = Nothing
Try
'确定文件存在
@@ -108,12 +108,16 @@
If Not File.Exists(PathFolder & "java.exe") Then
Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe")
End If
If File.Exists(PathFolder & "pdf-bookmark") Then
Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
End If
IsJre = Not File.Exists(PathFolder & "javac.exe")
'运行 -version
Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
If ModeDebug Then Log("[Java] Java 检查输出：" & PathFolder & "java.exe" & vbCrLf & Output)
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java，请在删除 Java 文件夹中的 /lib/ext 文件夹后再试")
If Output.Contains("a fatal error") Then Throw New ApplicationException("无法运行该 Java，该 Java 或系统存在问题")
'获取详细信息
Dim VersionString = If(RegexSeek(Output, "(?<=version "")[^""]+"), If(RegexSeek(Output, "(?<=openjdk )[0-9]+"), "")).Replace("_", ".").Split("-").First
If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493，VersionString = "21.0.2.0.2"
@@ -456,10 +460,12 @@ NoUserJava:
''' 将 Java 按照适用性排序。
''' </summary>
Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean
Dim PathInfo As New DirectoryInfo(ShortenPath(Path))
Dim PathMcInfo As New DirectoryInfo(ShortenPath(PathMcFolder))
'1. 尽量在当前文件夹或当前 Minecraft 文件夹
Dim ProgramPathParent As String, MinecraftPathParent As String = ""
ProgramPathParent = If(New DirectoryInfo(Path).Parent, New DirectoryInfo(Path)).FullName
If PathMcFolder <> "" Then MinecraftPathParent = If(New DirectoryInfo(PathMcFolder).Parent, New DirectoryInfo(PathMcFolder)).FullName
ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName
If PathMcFolder <> "" Then MinecraftPathParent = If(PathMcInfo.Parent, PathMcInfo).FullName
If Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Not Right.PathFolder.StartsWithF(ProgramPathParent) Then Return True
If Not Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Right.PathFolder.StartsWithF(ProgramPathParent) Then Return False
If PathMcFolder <> "" Then
@@ -526,6 +532,8 @@ NoUserJava:
If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器（#3705）
JavaSearchFolder(Disk.Name, JavaPreList, False)
Next
'查找 .jdks 文件夹中的 Java
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False)
'查找 APPDATA 文件夹中的 Java
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False)
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False)
@@ -668,14 +676,14 @@ Wait:
Private Sub JavaSearchFolder(OriginalPath As DirectoryInfo, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
Try
'确认目录存在
If Not OriginalPath.Exists Then Exit Sub
If Not OriginalPath.Exists Then Return
Dim Path As String = OriginalPath.FullName.Replace("\\", "\")
If Not Path.EndsWithF("\") Then Path += "\"
'若该目录有 Java，则加入结果
If File.Exists(Path & "javaw.exe") Then Results(Path) = Source
'查找其下的所有文件夹
'不应使用网易的 Java：https://github.com/Hex-Dragon/PCL2/issues/1279#issuecomment-2761489121
Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon",
'不应使用网易的 Java：https://github.com/Meloong-Git/PCL/issues/1279#issuecomment-2761489121
Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon", "bin",
"soft", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net",
"游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合",
"应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot",
@@ -742,7 +750,7 @@ Wait:
Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹，防止残留只下了一半但 -version 能跑的 Java
Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile)))
Log("[Java] 开始获取 Java 下载信息")
Dim IndexFileStr As String = NetGetCodeByLoader(DlVersionListOrder(
Dim IndexFileStr As String = NetRequestByLoader(DlVersionListOrder(
{"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"},
{"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"}
), IsJson:=True)
@@ -754,7 +762,7 @@ Wait:
Dim Address As String = TargetEntry.Value("manifest")("url")
Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}（{TargetEntry.Key}）：{Address}")
'获取文件列表
Dim ListFileStr As String = NetGetCodeByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), IsJson:=True)
Dim ListFileStr As String = NetRequestByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), IsJson:=True)
LastJavaBaseDir = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Key & "\"
Dim Results As New List(Of NetFile)
For Each File As JProperty In CType(GetJson(ListFileStr), JObject)("files")
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+130 -101
View File
@@ -65,8 +65,8 @@ Public Module ModLaunch
''' 记录启动日志。
''' </summary>
Public Sub McLaunchLog(Text As String)
Text = SecretFilter(Text, "*")
RunInUi(Sub() FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text)
Text = FilterUserName(FilterAccessToken(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
@@ -578,11 +593,7 @@ SkipLogin:
Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
Dim Input As McLoginServer = Data.Input
Dim NeedRefresh As Boolean = False, WasRefreshed As Boolean = False
Dim LogUsername As String = Input.UserName
If LogUsername.Contains("@") AndAlso Setup.Get("UiLauncherEmail") Then
LogUsername = AccountFilter(LogUsername)
End If
McLaunchLog("登录方式：" & Input.Description & "（" & LogUsername & "）")
McLaunchLog("登录方式：" & Input.Description)
Data.Progress = 0.05
'尝试登录
If (Not Data.Input.ForceReselectProfile) AndAlso
@@ -602,7 +613,7 @@ SkipLogin:
McLaunchLog("验证登录失败：" & AllMessage)
If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then
McLaunchLog("已触发超时登录失败")
Throw New Exception("$登录失败：连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好，或尝试使用 VPN！")
Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。")
End If
End Try
Data.Progress = 0.25
@@ -688,11 +699,10 @@ LoginFinish:
'发送登录请求
Dim RequestData As New JObject(
New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True))
NetRequestRetry(
Url:=Data.Input.BaseUrl & "/validate",
Method:="POST",
Data:=RequestData.ToString(0),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
NetRequestByClientRetry(
Data.Input.BaseUrl & "/validate", HttpMethod.Post,
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8") '没有返回值的
'将登录结果输出
Data.Output.AccessToken = AccessToken
@@ -705,10 +715,9 @@ LoginFinish:
End Sub
Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean)
McLaunchLog("刷新登录开始（Refresh, " & Data.Input.Token & "）")
Dim LoginJson As JObject = GetJson(NetRequestRetry(
Url:=Data.Input.BaseUrl & "/refresh",
Method:="POST",
Data:=New JObject(
Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
Data.Input.BaseUrl & "/refresh", HttpMethod.Post,
Content:=New JObject(
New JProperty("selectedProfile", New JObject(
New JProperty("name", Setup.Get($"Cache{Data.Input.Token}Name")),
New JProperty("id", Setup.Get($"Cache{Data.Input.Token}Uuid"))
@@ -716,7 +725,7 @@ LoginFinish:
New JProperty("accessToken", Setup.Get($"Cache{Data.Input.Token}Access")),
New JProperty("requestUser", True)
).ToString(Newtonsoft.Json.Formatting.None),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
Headers:={{"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") & " 无效！")
@@ -743,11 +752,10 @@ LoginFinish:
New JProperty("username", Data.Input.UserName),
New JProperty("password", Data.Input.Password),
New JProperty("requestUser", True))
Dim LoginJson As JObject = GetJson(NetRequestRetry(
Url:=Data.Input.BaseUrl & "/authenticate",
Method:="POST",
Data:=RequestData.ToString(0),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
Data.Input.BaseUrl & "/authenticate", HttpMethod.Post,
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8"))
'检查登录结果
If LoginJson("availableProfiles").Count = 0 Then
@@ -845,7 +853,7 @@ LoginFinish:
" - 只注册了账号，但没有加入对应服务器。")
End Select
ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then
Throw New Exception("$登录失败：连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好，或尝试使用 VPN！")
Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。")
ElseIf ex.Message.StartsWithF("$") Then
Throw
Else
@@ -862,8 +870,9 @@ LoginFinish:
'初始请求
Retry:
McLaunchLog("开始微软登录步骤 1/6（原始登录）")
Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded"))
Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post,
Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access",
ContentType:="application/x-www-form-urlencoded"))
McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString)
'弹窗
@@ -892,12 +901,14 @@ Retry:
Dim Result As String
Try
Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST",
$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
"application/x-www-form-urlencoded", 2)
Catch ex As Exception
If ex.Message.ContainsF("must sign in again", True) OrElse ex.Message.ContainsF("password expired", True) OrElse
(ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269
Result = NetRequestByClientMultiple("https://login.live.com/oauth20_token.srf", HttpMethod.Post,
Content:=$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
ContentType:="application/x-www-form-urlencoded",
Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}},
ThreadCount:=2)
Catch ex As ResponsedWebException
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
@@ -922,8 +933,8 @@ Retry:
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}"
Dim Result As String = NetRequestMultiple("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
Dim Result As String = NetRequestByClientMultiple("https://user.auth.xboxlive.com/user/authenticate", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Dim ResultJson As JObject = GetJson(Result)
Dim XBLToken As String = ResultJson("Token").ToString
Return XBLToken
@@ -944,21 +955,22 @@ Retry:
}"
Dim Result As String
Try
Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
Catch ex As Net.WebException
Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Catch ex As ResponsedWebException
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
If ex.Message.Contains("2148916227") Then
If ex.Response.Contains("2148916227") Then
MyMsgBox("该账号似乎已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True)
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916233") Then
ElseIf ex.Response.Contains("2148916233") Then
If MyMsgBox("你尚未注册 Xbox 账户，请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then
OpenWebsite("https://signup.live.com/signup")
End If
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916235") Then
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请尝试使用加速器或 VPN。", "登录失败", "我知道了")
ElseIf ex.Response.Contains("2148916235") Then
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN。", "登录失败", "我知道了")
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916238") Then
ElseIf ex.Response.Contains("2148916238") Then
If MyMsgBox("该账号年龄不足，你需要先修改出生日期，然后才能登录。" & vbCrLf &
"该账号目前填写的年龄是否在 13 岁以上？", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then
OpenWebsite("https://account.live.com/editprof.aspx")
@@ -975,10 +987,15 @@ Retry:
End If
End Try
Dim ResultJson As JObject = GetJson(Result)
Dim XSTSToken As String = ResultJson("Token").ToString
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
Return {XSTSToken, UHS}
Try '这个 Try 块仅为了追踪 #6683 而添加
Dim ResultJson As JObject = GetJson(Result)
Dim XSTSToken As String = ResultJson("Token").ToString
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
Return {XSTSToken, UHS}
Catch
Log("[Launch] 返回内容：" & vbCrLf & Result)
Throw
End Try
End Function
'微软登录步骤 4：从 {XSTSToken, UHS} 获取 Minecraft AccessToken
Private Function MsLoginStep4(Tokens As String()) As String
@@ -987,14 +1004,15 @@ Retry:
Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0)
Dim Result As String
Try
Result = NetRequestRetry("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json")
Result = NetRequestByClientRetry("https://api.minecraftservices.com/authentication/login_with_xbox", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then
Log(ex, "微软登录第 5 步汇报 429")
Log(ex, "微软登录第 4 步汇报 429")
Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！")
ElseIf Message.Contains("(403)") Then
Log(ex, "微软登录第 5 步汇报 403")
Log(ex, "微软登录第 4 步汇报 403")
Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器，请把它们关掉或更换节点后再试！")
Else
Throw
@@ -1009,7 +1027,8 @@ Retry:
Private Sub MsLoginStep5(AccessToken As String)
McLaunchLog("开始微软登录步骤 5/6")
Dim Result As String = NetRequestMultiple("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Dim Result As String = NetRequestByClientMultiple("https://api.minecraftservices.com/entitlements/mcstore",
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}})
Try
Dim ResultJson As JObject = GetJson(Result)
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
@@ -1020,7 +1039,7 @@ Retry:
Throw New Exception("$$")
End If
Catch ex As Exception
Log(ex, "微软登录第 6 步异常：" & Result)
Log(ex, "微软登录第 5 步异常：" & Result)
Throw
End Try
End Sub
@@ -1030,14 +1049,15 @@ Retry:
Dim Result As String
Try
Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile",
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}})
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then
Log(ex, "微软登录第 7 步汇报 429")
Log(ex, "微软登录第 6 步汇报 429")
Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！")
ElseIf Message.Contains("(404)") Then
Log(ex, "微软登录第 7 步汇报 404")
Log(ex, "微软登录第 6 步汇报 404")
RunInNewThread(
Sub()
Select Case MyMsgBox("请先创建 Minecraft 玩家档案，然后再重新登录。", "登录失败", "创建档案", "取消")
@@ -1084,8 +1104,7 @@ Retry:
Uuid = McLoginMojangUuid(SkinName, False)
End If
Catch ex As Exception
Log(ex, "离线启动时使用的正版皮肤获取失败")
MyMsgBox("由于设置的离线启动时使用的正版皮肤获取失败，游戏将以无皮肤的方式启动。" & vbCrLf & "请检查你的网络是否通畅，或尝试使用 VPN！" & vbCrLf & vbCrLf & "详细的错误信息：" & ex.Message, "皮肤获取失败")
Log(ex, "皮肤信息获取失败，游戏将以无皮肤的方式启动", LogLevel.Hint)
End Try
Case 4
'自定义
@@ -1104,7 +1123,7 @@ Retry:
If Len(Uuid) = 32 Then Return Uuid
'从官网获取
Try
Dim GotJson As JObject = NetGetCodeByRequestRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, IsJson:=True)
Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name))
If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在（" & Name & "）")
Uuid = If(GotJson("id"), "")
Catch ex As Exception
@@ -1210,6 +1229,12 @@ Retry:
End If
End If
'LiteLoader 检测
If McVersionCurrent.Version.HasLiteLoader AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本
'最高 Java 8
MaxVer = If(New Version(1, 8, 999, 999) < MaxVer, New Version(1, 8, 999, 999), MaxVer)
End If
'统一通行证检测
If Setup.Get("LoginType") = McLoginType.Nide Then
'至少 Java 8u101
@@ -1221,14 +1246,14 @@ Retry:
'选择 Java
McLaunchLog("Java 版本需求：最低 " & MinVer.ToString & "，最高 " & MaxVer.ToString)
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
If Task.IsAborted Then Exit Sub
If Task.IsAborted Then Return
If McLaunchJavaSelected IsNot Nothing Then
McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString)
Exit Sub
Return
End If
'无合适的 Java
If Task.IsAborted Then Exit Sub '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java
If Task.IsAborted Then Return '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java
McLaunchLog("无合适的 Java，需要确认是否自动下载")
Dim JavaCode As String
If MinVer >= New Version(1, 22) Then '潜在的向后兼容
@@ -1276,7 +1301,7 @@ Retry:
'检查下载结果
If JavaSearchLoader.State <> LoadState.Loading Then JavaSearchLoader.State = LoadState.Waiting '2872#
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
If Task.IsAborted Then Exit Sub
If Task.IsAborted Then Return
If McLaunchJavaSelected IsNot Nothing Then
McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString)
Else
@@ -1354,23 +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"
If Not Arguments.Contains("-Dstderr.encoding=") Then Arguments += " -Dstderr.encoding=UTF-8"
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"
End If
'替换参数
Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader)
If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then
'若自定义信息为空，则去掉该部分
Arguments = Arguments.Replace(" --versionType ${version_type}", "")
ReplaceArguments("${version_type}") = """"""
End If
For Each entry As KeyValuePair(Of String, String) In ReplaceArguments
Arguments = Arguments.Replace(entry.Key, If(entry.Value.Contains(" ") OrElse entry.Value.Contains(":\"), """" & entry.Value & """", entry.Value))
Next
'MJSB
Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
'全屏
@@ -1379,31 +1394,47 @@ Retry:
For Each Arg In CurrentLaunchOptions.ExtraArgs
Arguments += " " & Arg.Trim
Next
'自定义
Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
'进行参数替换
Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader)
If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then
'若自定义信息为空，则去掉该部分
Arguments = Arguments.Replace(" --versionType ${version_type}", "")
ReplaceArguments("${version_type}") = """"""
End If
Dim FinalArguments As String = ""
For Each Argument In Arguments.Split(" ")
For Each Entry As KeyValuePair(Of String, String) In ReplaceArguments
Argument = Argument.Replace(Entry.Key, Entry.Value)
Next
If (Argument.Contains(" ") OrElse Argument.Contains(":\")) AndAlso Not Argument.EndsWithF("""") Then Argument = $"""{Argument}"""
FinalArguments += Argument & " "
Next
FinalArguments = FinalArguments.TrimEnd
'进服
Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp)
If Server.Length > 0 Then
If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then
'QuickPlay
Arguments += $" --quickPlayMultiplayer ""{Server}"""
FinalArguments += $" --quickPlayMultiplayer ""{Server}"""
Else
'老版本
If Server.Contains(":") Then
'包含端口号
Arguments += " --server " & Server.Split(":")(0) & " --port " & Server.Split(":")(1)
FinalArguments += $" --server {Server.Split(":")(0)} --port {Server.Split(":")(1)}"
Else
'不包含端口号
Arguments += " --server " & Server & " --port 25565"
FinalArguments += $" --server {Server} --port 25565"
End If
If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Critical)
End If
End If
'自定义
Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
'输出
McLaunchLog("Minecraft 启动参数：")
McLaunchLog(Arguments)
McLaunchArgument = Arguments
McLaunchLog(FinalArguments)
McLaunchArgument = FinalArguments
End Sub
'Jvm 部分（第一段）
@@ -1429,11 +1460,12 @@ Retry:
End If
'Authlib-Injector
If McLoginLoader.Output.Type = "Auth" Then
If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#）
Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
Setup.Get("VersionServerAuthServer", McVersionCurrent))
Try
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8)
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
@@ -1498,11 +1530,12 @@ NextVersion:
End If
'Authlib-Injector
If McLoginLoader.Output.Type = "Auth" Then
If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#）
Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
Try
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8)
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
@@ -1536,10 +1569,8 @@ NextVersion:
DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu="))
Next
'#3511 的清理
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M")
'去重
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M") '#3511 的清理
Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ")
'添加 MainClass
@@ -1676,6 +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") '#6942
'窗口尺寸参数
Dim GameSize As Size
@@ -1688,7 +1720,7 @@ NextVersion:
Case 3 '自定义
GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth")), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight")))
Case Else
GameSize = New Size(875, 540)
GameSize = New Size(854, 480)
End Select
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso
McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso
@@ -1785,7 +1817,7 @@ NextVersion:
Catch ex As UnauthorizedAccessException
McLaunchLog("删除多余文件访问被拒绝，跳过删除步骤")
McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex))
Exit Sub
Return
End Try
Next
@@ -2100,25 +2132,24 @@ IgnoreCustomSkin:
'输出 bat
Try
Dim CmdString As String =
$"{If(McLaunchJavaSelected.VersionCode > 8 AndAlso McLaunchJavaSelected.VersionCode < 18, "chcp 65001>nul" & vbCrLf, "")}" &
$"{If(McLaunchJavaSelected.VersionCode > 8, "chcp 65001>nul" & vbCrLf, "")}" &
"@echo off" & vbCrLf &
$"title 启动 - {McVersionCurrent.Name}" & vbCrLf &
"echo 游戏正在启动，请稍候。" & vbCrLf &
$"set APPDATA=""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
$"cd /D ""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
CustomCommandGlobal & vbCrLf &
CustomCommandVersion & vbCrLf &
$"""{McLaunchJavaSelected.PathJava}"" {McLaunchArgument}" & vbCrLf &
"echo 游戏已退出。" & vbCrLf &
"pause"
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"),
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), FilterAccessToken(CmdString, "F"),
Encoding:=If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Encoding.Default))
If CurrentLaunchOptions.SaveBatch IsNot Nothing Then
McLaunchLog("导出启动脚本完成，强制结束启动过程")
AbortHint = "导出启动脚本成功！"
OpenExplorer(CurrentLaunchOptions.SaveBatch)
Loader.Parent.Abort()
Exit Sub '导出脚本完成
Return '导出脚本完成
End If
Catch ex As Exception
Log(ex, "输出启动脚本失败")
@@ -2189,8 +2220,6 @@ IgnoreCustomSkin:
StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder)
'设置其他参数
StartInfo.StandardErrorEncoding = If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Nothing)
StartInfo.StandardOutputEncoding = If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Nothing)
StartInfo.WorkingDirectory = ShortenPath(McVersionCurrent.PathIndie)
StartInfo.UseShellExecute = False
StartInfo.RedirectStandardOutput = True
@@ -2205,7 +2234,7 @@ IgnoreCustomSkin:
If Loader.IsAborted Then
McLaunchLog("由于取消启动，已强制结束游戏进程") '#1631
GameProcess.Kill()
Exit Sub
Return
End If
Loader.Output = GameProcess
McLaunchProcess = GameProcess
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+146 -115
View File
@@ -127,7 +127,7 @@ Public Module ModMinecraft
''' </summary>
Public Sub McFolderLauncherProfilesJsonCreate(Folder As String)
Try
If File.Exists(Folder & "launcher_profiles.json") Then Exit Sub
If File.Exists(Folder & "launcher_profiles.json") Then Return
Dim ResultJson As String =
"{
""profiles"": {
@@ -165,12 +165,12 @@ Public Module ModMinecraft
Return _McVersionCurrent
End Get
Set(value As McVersion)
If ReferenceEquals(_McVersionLast, value) Then Exit Property
If ReferenceEquals(_McVersionLast, value) Then Return
_McVersionCurrent = value '由于有可能是 Nothing，导致无法初始化，才得这样弄一圈
_McVersionLast = value
If value Is Nothing Then Exit Property
'重置缓存的 Mod 文件夹
PageDownloadCompDetail.CachedFolder = Nothing
If value Is Nothing Then Return
'重置缓存的下载文件夹
PageDownloadCompDetail.CachedFolder.Clear()
'统一通行证重判
If AniControlEnabled = 0 AndAlso
Setup.Get("VersionServerNide", Version:=value) <> Setup.Get("CacheNideServer") AndAlso
@@ -208,6 +208,7 @@ Public Module ModMinecraft
Public ReadOnly Property PathIndie As String
Get
If Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then
If Not IsLoaded Then Load()
'决定该版本是否应该被隔离
Dim ShouldBeIndie =
Function() As Boolean
@@ -224,17 +225,17 @@ Public Module ModMinecraft
Return True
End If
'根据全局的默认设置决定是否隔离
Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Setup.Get("LaunchArgumentIndieV2")}）判断")
Dim IsRelease As Boolean = State = McVersionState.Fool OrElse State = McVersionState.Old OrElse State = McVersionState.Snapshot
Dim IsRelease As Boolean = State <> McVersionState.Fool AndAlso State <> McVersionState.Old AndAlso State <> McVersionState.Snapshot
Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Setup.Get("LaunchArgumentIndieV2")}）判断，State {GetStringFromEnum(State)}，IsRelease {IsRelease}，Modable {Modable}")
Select Case Setup.Get("LaunchArgumentIndieV2")
Case 0 '关闭
Return False
Case 1 '仅隔离可安装 Mod 的版本
Return Modable
Case 2 '仅隔离非正式版
Return IsRelease
Return Not IsRelease
Case 3 '隔离非正式版与可安装 Mod 的版本
Return Modable OrElse IsRelease
Return Not IsRelease OrElse Modable
Case Else '隔离所有版本
Return True
End Select
@@ -439,6 +440,33 @@ VersionSearchFinish:
''' </summary>
Public ReleaseTime As New Date(1970, 1, 1, 15, 0, 0)
''' <summary>
''' 获取该版本的 JSON 路径。
''' </summary>
Public Function GetJsonPath() As String
Dim JsonPath As String = Path & Name & ".json"
If Not File.Exists(JsonPath) Then
'尝试寻找 JSON 文件
JsonPath = Nothing
For Each JsonCandidatePath In Directory.GetFiles(Path, "*.json")
Try
Dim JsonCandidate As JObject = GetJson(ReadFile(JsonCandidatePath))
If Not JsonCandidate.ContainsKey("mainClass") Then Continue For
If Not JsonCandidate.ContainsKey("type") Then Continue For
If Not JsonCandidate.ContainsKey("id") Then Continue For
Catch
End Try
JsonPath = JsonCandidatePath
Exit For
Next
If JsonPath Is Nothing Then
Throw New Exception($"未找到版本 JSON 文件：{Path}{Name}.json")
Else
Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug)
End If
End If
Return JsonPath
End Function
''' <summary>
''' 该版本的 Json 文本。
''' </summary>
@@ -451,17 +479,7 @@ VersionSearchFinish:
Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}")
End Function
If _JsonText Is Nothing Then
Dim JsonPath As String = Path & Name & ".json"
If Not File.Exists(JsonPath) Then
'如果文件夹下只有一个 JSON 文件，则将其作为版本 JSON
Dim JsonFiles As String() = Directory.GetFiles(Path, "*.json")
If JsonFiles.Count = 1 Then
JsonPath = JsonFiles(0)
Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug)
Else
Throw New Exception($"未找到版本 JSON 文件：{Path}{Name}.json")
End If
End If
Dim JsonPath As String = GetJsonPath()
_JsonText = ReadFile(JsonPath)
'如果 ReadFile 失败会返回空字符串；这可能是由于文件被临时占用，故延时后重试
If Not FastJsonCheck(_JsonText) Then
@@ -539,9 +557,15 @@ Recheck:
'继续循环
If Inherit.InheritVersion = InheritVersion Then Throw New Exception("版本依赖项出现嵌套：" & InheritVersion)
InheritVersion = Inherit.InheritVersion
'合并
'合并 Libraries 项：子版本放在前面，父版本放在后面（5978#：如果多个 jar 包中含有相同的类，Java 8 和之前的版本按照 -cp 指定的顺序选择第一个）
Dim CurrentLib As JArray = _JsonObject("libraries").DeepClone()
For Each LibToken In Inherit.JsonObject("libraries")
CurrentLib.Add(LibToken)
Next
'合并其他项：子版本优先于父版本
Inherit.JsonObject.Merge(_JsonObject)
_JsonObject = Inherit.JsonObject
_JsonObject("libraries") = CurrentLib
GoTo Recheck
End If
Catch ex As Exception
@@ -579,20 +603,18 @@ Recheck:
Get
If Not JsonVersionInited Then
JsonVersionInited = True
If File.Exists(Path & Name & ".jar") Then
Try
Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
If VersionJson IsNot Nothing Then
Using VersionJsonStream As New StreamReader(VersionJson.Open)
_JsonVersion = GetJson(VersionJsonStream.ReadToEnd)
End Using
End If
Try
If Not File.Exists($"{Path}{Name}.jar") Then Exit Try
Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
If VersionJson Is Nothing Then Exit Try
Using VersionJsonStream As New StreamReader(VersionJson.Open)
_JsonVersion = GetJson(VersionJsonStream.ReadToEnd)
End Using
Catch ex As Exception
Log(ex, "从版本 jar 中读取 version.json 失败")
End Try
End If
End Using
Catch ex As Exception
Log(ex, $"从版本 jar 中读取 version.json 失败（{Path}{Name}.jar）")
End Try
End If
Return _JsonVersion
End Get
@@ -967,7 +989,7 @@ ExitDataLoad:
If ToString = "" Then
Return "原版 " & McName
Else
Return McName & ToString & If(ModeDebug, " (" & SortCode & "#)", "")
Return McName & ToString
End If
End Function
@@ -1133,7 +1155,7 @@ Reload:
'改变当前选择的版本
OnLoaded:
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then
'尝试读取已储存的选择
Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version")
@@ -1145,7 +1167,7 @@ OnLoaded:
McVersionCurrent = Version
Setup.Set("LaunchVersionSelect", McVersionCurrent.Name)
Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本：" & McVersionCurrent.Path)
Exit Sub
Return
End If
Next
Next
@@ -1537,7 +1559,7 @@ OnLoaded:
''' 要求玩家选择一个皮肤文件，并进行相关校验。
''' </summary>
Public Function McSkinSelect() As McSkinInfo
Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.webp)|*.png;*.jpg;*.webp", "选择皮肤文件")
Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.jpeg;*.webp)|*.png;*.jpg;*.jpeg;*.webp", "选择皮肤文件")
'验证有效性
If FileName = "" Then Return New McSkinInfo With {.IsVaild = False}
@@ -1588,7 +1610,7 @@ OnLoaded:
Case Else
Throw New ArgumentException("皮肤地址种类无效：" & If(Type, "null"))
End Select
Dim SkinString = NetGetCodeByRequestRetry(Url & Uuid)
Dim SkinString = NetRequestByClientRetry(Url & Uuid)
If SkinString = "" Then Throw New Exception("皮肤返回值为空，可能是未设置自定义皮肤的用户")
'处理皮肤地址
Dim SkinValue As String
@@ -1609,7 +1631,8 @@ OnLoaded:
If SkinJson("textures") Is Nothing OrElse SkinJson("textures")("skin") Is Nothing OrElse SkinJson("textures")("skin")("url") Is Nothing Then
Throw New Exception("用户未设置自定义皮肤")
Else
SkinValue = SkinJson("textures")("skin")("url").ToString
Dim SkinUrl As String = SkinJson("textures")("skin")("url").ToString
SkinValue = If(SkinUrl.Contains("minecraft.net/"), SkinUrl.Replace("http://", "https://"), SkinUrl)
End If
'保存缓存
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue)
@@ -1626,9 +1649,9 @@ OnLoaded:
Dim FileAddress As String = PathTemp & "Cache\Skin\" & GetHash(Address) & ".png"
SyncLock McSkinDownloadLock
If Not File.Exists(FileAddress) Then
NetDownloadByClient(Address, FileAddress & NetDownloadEnd)
NetDownloadByClient(Address, FileAddress & ".PCLDownloading")
File.Delete(FileAddress)
FileSystem.Rename(FileAddress & NetDownloadEnd, FileAddress)
FileSystem.Rename(FileAddress & ".PCLDownloading", FileAddress)
Log("[Minecraft] 皮肤下载成功：" & FileAddress)
End If
Return FileAddress
@@ -1771,61 +1794,60 @@ OnLoaded:
'获取当前支持库列表
Log("[Minecraft] 获取支持库列表：" & Version.Name)
McLibListGet = McLibListGetWithJson(Version.JsonObject)
If Not IncludeVersionJar Then Return McLibListGet
Dim Result = McLibListGetWithJson(Version.JsonObject)
'需要添加原版 Jar
Dim RealVersion As McVersion
Dim RequiredJar As String = Version.JsonObject("jar")?.ToString
If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then
'HMCL 项直接使用自身的 Jar
'根据 Inherit 获取最深层版本
Dim OriginalVersion As McVersion = Version
'1.17+ 的 Forge 不寻找 Inherit
If Not ((Version.Version.HasForge OrElse Version.Version.HasNeoForge) AndAlso Version.Version.McCodeMain >= 17) Then
Do Until OriginalVersion.InheritVersion = ""
If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do
OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\")
Loop
If IncludeVersionJar Then
Dim RealVersion As McVersion
Dim RequiredJar As String = Version.JsonObject("jar")?.ToString
If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then
'HMCL 项直接使用自身的 Jar
'根据 Inherit 获取最深层版本
Dim OriginalVersion As McVersion = Version
'1.17+ 的 Forge 不寻找 Inherit
If Not ((Version.Version.HasForge OrElse Version.Version.HasNeoForge) AndAlso Version.Version.McCodeMain >= 17) Then
Do Until OriginalVersion.InheritVersion = ""
If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do
OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\")
Loop
End If
'需要新建对象，否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original
'复现：启动一个 Snapshot 版本
RealVersion = New McVersion(OriginalVersion.Path)
Else
'Json 已提供 Jar 字段，使用该字段的信息
RealVersion = New McVersion(RequiredJar)
End If
'需要新建对象，否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original
'复现：启动一个 Snapshot 版本
RealVersion = New McVersion(OriginalVersion.Path)
Else
'Json 已提供 Jar 字段，使用该字段的信息
RealVersion = New McVersion(RequiredJar)
Dim ClientUrl As String, ClientSHA1 As String
'判断需求的版本是否存在
'不能调用 RealVersion.Check()，可能会莫名其妙地触发 CheckPermission 正被另一进程使用，导致误判前置不存在
If Not File.Exists(RealVersion.Path & RealVersion.Name & ".json") Then
RealVersion = Version
Log("[Minecraft] 可能缺少前置版本 " & RealVersion.Name & "，找不到对应的 json 文件", LogLevel.Debug)
End If
'获取详细下载信息
If RealVersion.JsonObject("downloads") IsNot Nothing AndAlso RealVersion.JsonObject("downloads")("client") IsNot Nothing Then
ClientUrl = RealVersion.JsonObject("downloads")("client")("url")
ClientSHA1 = RealVersion.JsonObject("downloads")("client")("sha1")
Else
ClientUrl = Nothing
ClientSHA1 = Nothing
End If
'把所需的原版 Jar 添加进去
Result.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
End If
Dim ClientUrl As String, ClientSHA1 As String
'判断需求的版本是否存在
'不能调用 RealVersion.Check()，可能会莫名其妙地触发 CheckPermission 正被另一进程使用，导致误判前置不存在
If Not File.Exists(RealVersion.Path & RealVersion.Name & ".json") Then
RealVersion = Version
Log("[Minecraft] 可能缺少前置版本 " & RealVersion.Name & "，找不到对应的 json 文件", LogLevel.Debug)
End If
'获取详细下载信息
If RealVersion.JsonObject("downloads") IsNot Nothing AndAlso RealVersion.JsonObject("downloads")("client") IsNot Nothing Then
ClientUrl = RealVersion.JsonObject("downloads")("client")("url")
ClientSHA1 = RealVersion.JsonObject("downloads")("client")("sha1")
Else
ClientUrl = Nothing
ClientSHA1 = Nothing
End If
'把所需的原版 Jar 添加进去
McLibListGet.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
Return Result
End Function
''' <summary>
''' 获取 Minecraft 某一版本忽视继承的支持库列表，即结果中没有继承项。
''' </summary>
Public Function McLibListGetWithJson(JsonObject As JObject, Optional KeepSameNameDifferentVersionResult As Boolean = False, Optional CustomMcFolder As String = Nothing) As List(Of McLibToken)
CustomMcFolder = If(CustomMcFolder, PathMcFolder)
Dim BasicArray As New List(Of McLibToken)
'添加基础 Json 项
Dim AllLibs As JArray = JsonObject("libraries")
'转换为 LibToken
For Each Library As JObject In AllLibs.Children
Dim BasicArray As New List(Of McLibToken)
For Each Library As JObject In CType(JsonObject("libraries"), JArray).Children
'清理 null 项（BakaXL 会把没有的项序列化为 null，但会被 Newtonsoft 转换为 JValue，导致 Is Nothing = false；这导致了 #409）
For i = Library.Properties.Count - 1 To 0 Step -1
@@ -1944,8 +1966,7 @@ OnLoaded:
Try
Log("[Minecraft] 开始获取统一通行证下载信息")
'测试链接：https://auth.mc-user.com:233/00000000000000000000000000000000/
DownloadInfo = GetJson(NetGetCodeByLoader({
"https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)}, IsJson:=True))
DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)))
Catch ex As Exception
Log(ex, "获取统一通行证下载信息失败")
End Try
@@ -1967,10 +1988,9 @@ OnLoaded:
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByLoader({
DownloadInfo = GetJson(NetRequestByClientRetry(
"https://authlib-injector.yushi.moe/artifact/latest.json",
"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"
}, IsJson:=True))
BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
@@ -2015,12 +2035,16 @@ OnLoaded:
'获取
For Each Token As McLibToken In Libs
'检查文件
Dim Checker As New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
Dim Checker As FileChecker
If Token.Name.ContainsF("labymod") Then
Checker = New FileChecker '不检查 LabyMod 的文件，它们提供的文件校验信息是错的（#3225）
Else
Checker = New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
End If
If Checker.Check(Token.LocalPath) Is Nothing Then Continue For
'文件不符合，添加下载
Dim Urls As New List(Of String)
If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then
'特判修复 Forge 部分 universal 文件缺失 URL（#5455）
If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then '特判修复 Forge 部分 universal 文件缺失 URL（#5455）
Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/")
End If
If Token.Url IsNot Nothing Then
@@ -2192,16 +2216,16 @@ OnLoaded:
Dim LocalPath As String
If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToObject(Of Boolean) Then
'Remap
LocalPath = Version.PathIndie & "resources\" & File.Name.Replace("/", "\")
LocalPath = $"{Version.PathIndie}resources\{File.Name}"
ElseIf Json("virtual") IsNot Nothing AndAlso Json("virtual").ToObject(Of Boolean) Then
'Virtual
LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\")
LocalPath = $"{PathMcFolder}assets\virtual\legacy\{File.Name}"
Else
'正常
LocalPath = PathMcFolder & "assets\objects\" & Left(File.Value("hash").ToString, 2) & "\" & File.Value("hash").ToString
LocalPath = $"{PathMcFolder}assets\objects\{Left(File.Value("hash").ToString, 2)}\{File.Value("hash")}"
End If
Result.Add(New McAssetsToken With {
.LocalPath = LocalPath,
.LocalPath = LocalPath.Replace("/", "\"),
.SourcePath = File.Name,
.Hash = File.Value("hash").ToString,
.Size = File.Value("size").ToString
@@ -2263,7 +2287,7 @@ OnLoaded:
End If
Next
'进行提示
If Version Is Nothing Then Exit Sub
If Version Is Nothing Then Return
Dim Time As Date = Version("releaseTime")
Dim MsgBoxText As String = $"新版本：{VersionName}{vbCrLf}" &
If((Date.Now - Time).TotalDays > 1, "更新时间：" & Time.ToString, "更新于：" & GetTimeSpanString(Time - Date.Now, False))
@@ -2368,26 +2392,33 @@ NextEntry:
End Function
''' <summary>
''' 为邮箱地址或手机号账号进行部分打码。
''' 打码字符串中的 AccessToken。
''' </summary>
Public Function AccountFilter(Account As String) As String
If Account.Contains("@") Then
'是邮箱
Dim Splits = Account.Split("@")
'If Splits(0).Count >= 6 Then
' '前半部分至少 6 位，屏蔽后 4 位
' Return Mid(Splits(0), 1, Splits(0).Count - 4) & "****" & "@" & Splits(1)
'Else
'前半部分不到 6 位，返回全 *
Return "".PadLeft(Splits(0).Count, "*") & "@" & Splits(1)
'End If
ElseIf Account.Count >= 6 Then
'至少 6 位，屏蔽后 4 位
Return Mid(Account, 1, Account.Count - 4) & "****"
Else
'不到 6 位，返回全 *
Return "".PadLeft(Account.Count, "*")
Public Function FilterAccessToken(Raw As String, FilterChar As Char) As String
'打码 "accessToken " 后的内容
If Raw.Contains("accessToken ") Then
For Each Token In RegexSearch(Raw, "(?<=accessToken ([^ ]{5}))[^ ]+(?=[^ ]{5})")
Raw = Raw.Replace(Token, New String(FilterChar, Token.Count))
Next
End If
'打码当前登录的结果
Dim AccessToken As String = McLoginLoader.Output.AccessToken
If AccessToken IsNot Nothing AndAlso AccessToken.Length >= 10 AndAlso Raw.ContainsF(AccessToken, True) AndAlso
McLoginLoader.Output.Uuid <> McLoginLoader.Output.AccessToken Then 'UUID 和 AccessToken 一样则不打码
Raw = Raw.Replace(AccessToken, Left(AccessToken, 5) & New String(FilterChar, AccessToken.Length - 10) & Right(AccessToken, 5))
End If
Return Raw
End Function
''' <summary>
''' 打码字符串中的 Windows 用户名。
''' </summary>
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))
Next
End If
Return Raw
End Function
End Module
Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb
+30 -31
View File
@@ -1,7 +1,7 @@
Imports System.IO.Compression
Public Module ModMod
Private Const LocalModCacheVersion As Integer = 7
Private Const LocalModCacheVersion As Integer = 8
Public Class McMod
@@ -188,9 +188,9 @@ Public Module ModMod
Private _Dependencies As New Dictionary(Of String, String)
Private Sub AddDependency(ModID As String, Optional VersionRequirement As String = Nothing)
'确保信息正确
If ModID Is Nothing OrElse ModID.Count < 2 Then Exit Sub
If ModID Is Nothing OrElse ModID.Count < 2 Then Return
ModID = ModID.ToLower
If ModID = "name" OrElse Val(ModID).ToString = ModID Then Exit Sub '跳过 name 与纯数字 id
If ModID = "name" OrElse Val(ModID).ToString = ModID Then Return '跳过 name 与纯数字 id
If VersionRequirement Is Nothing OrElse ((Not VersionRequirement.Contains(".")) AndAlso (Not VersionRequirement.Contains("-"))) OrElse VersionRequirement.Contains("$") Then
VersionRequirement = Nothing
Else
@@ -279,7 +279,7 @@ Public Module ModMod
''' 进行文件可用性检查与 .class 以外的信息获取。
''' </summary>
Public Sub Load(Optional ForceReload As Boolean = False)
If IsLoaded AndAlso Not ForceReload Then Exit Sub
If IsLoaded AndAlso Not ForceReload Then Return
'初始化
Init()
Dim Jar As ZipArchive = Nothing
@@ -819,7 +819,7 @@ Finished:
Try
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod")
Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input)
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
Thread.Sleep(100)
Loop
Finally
@@ -872,7 +872,7 @@ Finished:
Dim ModUpdateList As New List(Of McMod)
For Each ModFile As FileInfo In ModFileList
Loader.Progress += 0.94 / ModFileList.Count
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
'加载 McMod 对象
Dim ModEntry As New McMod(ModFile.FullName)
ModEntry.Load()
@@ -912,7 +912,7 @@ Finished:
End Function)
'回设
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
Loader.Output = ModList
'开始联网加载
@@ -939,18 +939,18 @@ Finished:
'开始网络获取
Log($"[Mod] 目标加载器：{ModLoaders.Join("/")}，版本：{McVersion}")
Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False
Dim MainThread As Thread = Thread.CurrentThread
Dim CurrentTaskThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息
RunInNewThread(
Sub()
Try
'步骤 1：获取 Hash 与对应的工程 ID
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
Dim ModrinthVersion = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files", "POST",
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject)
Dim ModrinthVersion As JObject = DlModRequest("https://api.modrinth.com/v2/version_files", HttpMethod.Post,
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")
Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
If ModrinthVersion.Count = 0 Then Exit Sub
If ModrinthVersion.Count = 0 Then Return
Dim ModrinthMapping As New Dictionary(Of String, List(Of McMod))
For Each Entry In Mods
If Not ModrinthVersion.ContainsKey(Entry.ModrinthHash) Then Continue For
@@ -963,13 +963,12 @@ Finished:
Dim File As New CompFile(ModrinthVersion(Entry.ModrinthHash), CompType.Mod)
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
Next
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3：获取工程信息
If Not ModrinthMapping.Any() Then Exit Sub
Dim ModrinthProject = CType(GetJson(DlModRequest(
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]",
"GET", "", "application/json")), JArray)
If Not ModrinthMapping.Any() Then Return
Dim ModrinthProject As JArray = DlModRequest(
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]")
For Each ProjectJson In ModrinthProject
Dim Project As New CompProject(ProjectJson)
For Each Entry In ModrinthMapping(Project.Id)
@@ -978,9 +977,9 @@ Finished:
Next
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息，继续获取更新信息")
'步骤 4：获取更新信息
Dim ModrinthUpdate = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files/update", "POST",
Dim ModrinthUpdate As JObject = DlModRequest("https://api.modrinth.com/v2/version_files/update", HttpMethod.Post,
$"{{""hashes"": [""{ModrinthMapping.SelectMany(Function(l) l.Value.Select(Function(m) m.ModrinthHash)).Join(""",""")}""], ""algorithm"": ""sha1"",
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")), JObject)
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")
For Each Entry In Mods
If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For
Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod)
@@ -1013,13 +1012,13 @@ Finished:
Dim CurseForgeHashes As New List(Of UInteger)
For Each Entry In Mods
CurseForgeHashes.Add(Entry.CurseForgeHash)
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
Next
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Dim CurseForgeRaw As JContainer = DlModRequest("https://api.curseforge.com/v1/fingerprints/432", HttpMethod.Post,
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")("data")("exactMatches")
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
If Not CurseForgeRaw.Any() Then Exit Sub
If Not CurseForgeRaw.Any() Then Return
Dim CurseForgeMapping As New Dictionary(Of Integer, List(Of McMod))
For Each Project In CurseForgeRaw
Dim ProjectId = Project("id").ToString
@@ -1034,12 +1033,12 @@ Finished:
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
Next
Next
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
'步骤 3：获取工程信息
If Not CurseForgeMapping.Any() Then Exit Sub
Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST",
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
If Not CurseForgeMapping.Any() Then Return
Dim CurseForgeProject = DlModRequest("https://api.curseforge.com/v1/mods", HttpMethod.Post,
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")("data")
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject
@@ -1078,9 +1077,9 @@ Finished:
Next
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息，需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
'步骤 4：获取更新文件信息
If Not UpdateFileIds.Any() Then Exit Sub
Dim CurseForgeFiles = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST",
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data")
If Not UpdateFileIds.Any() Then Return
Dim CurseForgeFiles = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post,
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")("data")
Dim UpdateFiles As New Dictionary(Of McMod, CompFile)
For Each FileJson In CurseForgeFiles
Dim File As New CompFile(FileJson, CompType.Mod)
@@ -1114,13 +1113,13 @@ Finished:
End Sub, "Mod List Detail Loader CurseForge")
'等待线程结束
Do Until EndedThreadCount = 2
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
Thread.Sleep(10)
Loop
'保存缓存
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
Log($"[Mod] 联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Exit Sub
If Not Mods.Any() Then Return
For Each Entry In Mods
Entry.CompLoaded = Not IsFailed
Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb
+12 -6
View File
@@ -8,7 +8,7 @@ Public Module ModModpack
''' </summary>
Public Sub ModpackInstall()
Dim File As String = SelectFile("整合包文件(*.rar;*.zip;*.mrpack)|*.rar;*.zip;*.mrpack", "选择整合包压缩文件") '选择整合包文件
If String.IsNullOrEmpty(File) Then Exit Sub
If String.IsNullOrEmpty(File) Then Return
RunInThread(
Sub()
Try
@@ -128,7 +128,7 @@ Retry:
'完全不知道为啥会出现文件正在被另一进程使用的问题，总之加个重试
If RetryCount < 5 Then
Thread.Sleep(RetryCount * 2000)
If Loader IsNot Nothing AndAlso Loader.LoadingState <> MyLoading.MyLoadingState.Run Then Exit Sub
If Loader IsNot Nothing AndAlso Loader.LoadingState <> MyLoading.MyLoadingState.Run Then Return
RetryCount += 1
GoTo Retry
Else
@@ -244,7 +244,7 @@ Retry:
'获取 Mod 下载信息
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
Sub(Task As LoaderTask(Of Integer, JArray))
Task.Output = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data")
Task.Output = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json")("data")
'如果文件已被删除，则 API 会跳过那一项
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除，所以没法继续安装了，请向整合包作者反馈该问题")
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
@@ -258,8 +258,7 @@ Retry:
If FileList.ContainsKey(Id) Then Continue For
'可选 Mod 提示
If ModOptionalList.Contains(Id) Then
If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "？",
"下载可选文件", "是", "否") = 2 Then
If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "？", "下载可选文件", "是", "否") = 2 Then
Continue For
End If
End If
@@ -423,7 +422,7 @@ Retry:
End Select
End If
'添加下载文件
Dim Urls = File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToList
Dim Urls = File("downloads").SelectMany(Function(t) CompFile.HandleCurseForgeDownloadUrls(t.ToString)).ToList
Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
Urls = Urls.Distinct.ToList()
Dim TargetPath As String = $"{PathMcFolder}versions\{VersionName}\{File("path")}"
@@ -693,6 +692,7 @@ Retry:
End If
'解压
Dim InstallTemp As String = RequestTaskTempFolder()
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
@@ -701,6 +701,12 @@ Retry:
InstallTemp & ArchiveBaseFolder & "overrides",
PathMcFolder & "versions\" & VersionName,
Task, 0.4)
'JVM 参数
If Json("launchInfo") IsNot Nothing Then
Dim LaunchInfo As JObject = Json("launchInfo")
If LaunchInfo.ContainsKey("javaArgument") Then WriteIni(SetupFile, "VersionAdvanceJvm", String.Join(" ", LaunchInfo("javaArgument")))
If LaunchInfo.ContainsKey("launchArgument") Then WriteIni(SetupFile, "VersionAdvanceGame", String.Join(" ", LaunchInfo("launchArgument")))
End If
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造加载器
If Json("addons") Is Nothing Then Throw New Exception("该 MCBBS 整合包未提供游戏版本附加信息，无法安装！")
Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb
+20 -19
View File
@@ -15,7 +15,7 @@
TriggerLauncherShutdown = False
End If
Next
If IsWatcherRunning = IsRunning Then Exit Sub
If IsWatcherRunning = IsRunning Then Return
IsWatcherRunning = IsRunning
If IsWatcherRunning Then
MinecraftStart()
@@ -81,7 +81,7 @@
WatcherStateChanged()
'初始化进程与日志读取
Me.GameProcess = Loader.Input
GameProcess = Loader.Input
GameProcess.BeginOutputReadLine()
GameProcess.BeginErrorReadLine()
AddHandler GameProcess.OutputDataReceived, AddressOf LogReceived
@@ -118,7 +118,7 @@
Return _State
End Get
Set(value As MinecraftState)
If _State = value Then Exit Property
If _State = value Then Return
_State = value
WatcherStateChanged()
End Set
@@ -144,7 +144,7 @@
'输出文本
Dim Copyed As New List(Of String)
SyncLock WaitingLogLock
If Not WaitingLog.Any() Then Exit Sub
If Not WaitingLog.Any() Then Return
Copyed = WaitingLog
WaitingLog = New List(Of String)(1000)
End SyncLock
@@ -180,8 +180,9 @@
Public LatestLog As New Queue(Of String)
Private Sub GameLog(Text As String)
'预处理
If Text Is Nothing Then Exit Sub
If Text Is Nothing Then Return
Text = Text.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf)
'If Text.Contains("�����") Then Hint("检测到错误的日志编码：" & Text)
'加入预存储
LatestLog.Enqueue(Text)
If LatestLog.Count >= 501 Then LatestLog.Dequeue()
@@ -256,8 +257,8 @@
Private WindowHandle As IntPtr
Private Sub TimerWindow()
Try
If GameProcess.HasExited Then Exit Sub
If IsWindowFinished Then Exit Sub
If GameProcess.HasExited Then Return
If IsWindowFinished Then Return
'获取全部窗口，检查是否有新增的
Dim MinecraftWindow As KeyValuePair(Of IntPtr, String)? = Nothing
Try
@@ -267,10 +268,10 @@
Log(ex, "由于反作弊或安全软件拦截，PCL 无法操作游戏窗口", LogLevel.Hint)
IsWindowFinished = True
End Try
If MinecraftWindow Is Nothing Then Exit Sub
If MinecraftWindow Is Nothing Then Return
Dim MinecraftWindowName = MinecraftWindow.Value.Value, MinecraftWindowHandle = MinecraftWindow.Value.Key
'已找到窗口
If Not MinecraftWindowName.StartsWithF("FML") Then
If Not MinecraftWindowName.StartsWithF("FML") AndAlso Not MinecraftWindowName.StartsWithF("Quilt Loader") Then
'已找到 Minecraft 窗口
WindowHandle = MinecraftWindowHandle
WatcherLog($"Minecraft 窗口已加载：{MinecraftWindowName}（{MinecraftWindowHandle.ToInt64}）")
@@ -291,8 +292,8 @@
End Sub, "MinecraftWindowMaximize")
End If
ElseIf Not IsWindowAppeared Then
'已找到 FML 窗口
WatcherLog("FML 窗口已加载：" & MinecraftWindowName & "（" & MinecraftWindowHandle.ToInt64 & "）")
'已找到 Mod Loader 窗口
WatcherLog("Mod Loader 窗口已加载：" & MinecraftWindowName & "（" & MinecraftWindowHandle.ToInt64 & "）")
End If
IsWindowAppeared = True
Catch ex As Exception
@@ -307,27 +308,27 @@
TryGetMinecraftWindow = Nothing
EnumWindows(
Sub(hwnd As IntPtr, lParam As Integer)
If TryGetMinecraftWindow IsNot Nothing Then Exit Sub
If TryGetMinecraftWindow IsNot Nothing Then Return
'检查类名
Dim str As New StringBuilder(512)
GetClassName(hwnd, str, str.Capacity)
Dim ClassName As String = str.ToString
If Not (ClassName = "GLFW30" OrElse ClassName = "LWJGL" OrElse ClassName = "SunAwtFrame") Then Exit Sub
If Not (ClassName = "GLFW30" OrElse ClassName = "LWJGL" OrElse ClassName = "SunAwtFrame") Then Return
'获取窗口标题名
str = New StringBuilder(512)
GetWindowText(hwnd, str, str.Capacity)
Dim WindowText As String = str.ToString
'有的 Mod 可以修改窗口标题，所以不能检测是否为 Minecraft 打头，这并不准确
'部分版本会搞个 GLFW message window 出来所以得反选
If Not (WindowText.StartsWithF("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWithF("GLFW")) Then Exit Sub
If Not (WindowText.StartsWithF("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWithF("GLFW")) Then Return
'获取窗口关联的进程
Dim ProcessId As Integer
GetWindowThreadProcessId(hwnd, ProcessId)
Try
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Exit Sub '需要是此后启动的进程
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Return '需要是此后启动的进程
Catch ex As Exception
Log(ex, "枚举 Minecraft 窗口进程失败")
Exit Sub
Return
End Try
'返回
TryGetMinecraftWindow = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText)
@@ -344,18 +345,18 @@
'崩溃处理
Private Sub Crashed()
If State = MinecraftState.Crashed OrElse State = MinecraftState.Ended Then Exit Sub
If State = MinecraftState.Crashed OrElse State = MinecraftState.Ended Then Return
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)
Plain Craft Launcher 2/Modules/ModEvent.vb
+9 -5
View File
@@ -1,7 +1,7 @@
Public Module ModEvent
Public Sub TryStartEvent(Type As String, Data As String)
If String.IsNullOrWhiteSpace(Type) Then Exit Sub
If String.IsNullOrWhiteSpace(Type) Then Return
Dim RealData As String() = {""}
If Data IsNot Nothing Then RealData = Data.Split("|")
StartEvent(Type, RealData)
@@ -15,7 +15,7 @@
Data(0) = Data(0).Replace("\", "/")
If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议（#2200）
MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败")
Exit Sub
Return
End If
Hint("正在开启中，请稍候……")
OpenWebsite(Data(0))
@@ -39,7 +39,7 @@
Case 2
Setup.Set("HintCustomCommand", True)
Case 3
Exit Sub
Return
End Select
End If
Dim Info As New ProcessStartInfo With {
@@ -58,7 +58,7 @@
If Data(0) = "\current" Then
If McVersionCurrent Is Nothing Then
Hint("请先选择一个 Minecraft 版本！", HintType.Critical)
Exit Sub
Return
Else
Data(0) = McVersionCurrent.Name
End If
@@ -100,7 +100,7 @@
Data(0) = Data(0).Replace("\", "/")
If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败")
Exit Sub
Return
End If
Try
Select Case Data.Length
@@ -115,6 +115,10 @@
PageOtherTest.StartCustomDownload(Data(0), "未知")
End Try
Case "修改设置"
Setup.Set(Data(0), Data(1))
Hint($"已写入设置：{Data(0)} → {Data(1)}", HintType.Finish)
Case Else
MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败")
End Select
Plain Craft Launcher 2/Modules/ModMain.vb
+19 -18
View File
@@ -34,12 +34,12 @@ Public Module ModMain
''' <summary>
''' 等待弹出的提示列表。以 {String, HintType, Log As Boolean} 形式存储为数组。
''' </summary>
Private HintWaiting As List(Of HintMessage) = If(HintWaiting, New List(Of HintMessage))
Private HintWaiting As SafeList(Of HintMessage) = If(HintWaiting, New SafeList(Of HintMessage))
''' <summary>
''' 在窗口左下角弹出提示文本。
''' </summary>
Public Sub Hint(Text As String, Optional Type As HintType = HintType.Info, Optional Log As Boolean = True)
If HintWaiting Is Nothing Then HintWaiting = New List(Of HintMessage)
If HintWaiting Is Nothing Then HintWaiting = New SafeList(Of HintMessage)
HintWaiting.Add(New HintMessage With {.Text = If(Text, ""), .Type = Type, .Log = Log})
End Sub
@@ -47,7 +47,7 @@ Public Module ModMain
Try
'Tag 存储了：{ 是否可以重用, Uuid }
If Not HintWaiting.Any() Then Exit Sub
If Not HintWaiting.Any() Then Return
Do While HintWaiting.Any
''清除空提示
'If IsNothing(HintWaiting(0)) OrElse IsNothing(HintWaiting(0)(0)) Then
@@ -343,7 +343,7 @@ EndHint:
Public WaitingMyMsgBox As List(Of MyMsgBoxConverter) = If(WaitingMyMsgBox, New List(Of MyMsgBoxConverter))
Public Sub MyMsgBoxTick()
Try
If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing OrElse FrmMain.WindowState = WindowState.Minimized Then Exit Sub
If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing OrElse FrmMain.WindowState = WindowState.Minimized Then Return
If FrmMain.PanMsg.Children.Count > 0 Then
'弹窗中
FrmMain.PanMsg.Visibility = Visibility.Visible
@@ -637,7 +637,7 @@ NextFile:
Catch ex As Exception
Log(ex, "检查帮助文件夹失败", LogLevel.Msgbox)
End Try
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
'将文件实例化
Dim Dict As New List(Of HelpEntry)
@@ -653,7 +653,7 @@ NextFile:
'回设
If Not Dict.Any() Then Throw New Exception("未找到可用的帮助；若不需要帮助页面，可以在 设置 → 个性化 → 功能隐藏 中将其隐藏")
If Loader.IsAborted Then Exit Sub
If Loader.IsAborted Then Return
Loader.Output = Dict
Catch ex As Exception
@@ -696,8 +696,8 @@ NextFile:
Private AprilDistance As Integer = 0
Private Sub TimerFool()
Try
If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing Then Exit Sub
If IsAprilGiveup OrElse FrmMain.PageCurrent <> FormMain.PageType.Launch OrElse AniControlEnabled <> 0 OrElse Not FrmLaunchLeft.BtnLaunch.IsLoaded Then Exit Sub
If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing Then Return
If IsAprilGiveup OrElse FrmMain.PageCurrent <> FormMain.PageType.Launch OrElse AniControlEnabled <> 0 OrElse Not FrmLaunchLeft.BtnLaunch.IsLoaded Then Return
'计算是否空闲
Dim MousePos = FrmMain.lastMouseArg.GetPosition(FrmMain)
@@ -766,7 +766,7 @@ NextFile:
'移动
AprilSpeed = AprilSpeed * 0.8 + Acc
Dim SpeedValue = Math.Min(60, AprilSpeed.Length)
If SpeedValue < 0.01 Then Exit Sub
If SpeedValue < 0.01 Then Return
AprilSpeed.Normalize()
AprilSpeed *= SpeedValue
AprilDistance += SpeedValue
@@ -913,7 +913,7 @@ NextFile:
If ThemeDontClick = 2 Then ThemeRefresh()
#End Region
Catch ex As Exception
Log(ex, "短程主时钟执行异常", LogLevel.Assert)
Log(ex, "短程主时钟执行异常", LogLevel.Critical)
End Try
Timer4Count += 1
If Timer4Count = 4 Then
@@ -933,15 +933,16 @@ NextFile:
#Region "每 7.5s 执行一次的代码"
If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDistance <> 0 Then FrmMain.BtnExtraApril.Ribble()
'以未知原因窗口被丢到一边去的修复（Top、Left = -25600），还有 #745
RunInUi(Sub()
If Not FrmMain.Hidden Then
If FrmMain.Top < -9000 Then FrmMain.Top = 100
If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8
End If
End Sub)
RunInUi(
Sub()
If Not FrmMain.Hidden Then
If FrmMain.Top < -9000 Then FrmMain.Top = 100
If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8
End If
End Sub)
#End Region
Catch ex As Exception
Log(ex, "长程主时钟执行异常", LogLevel.Assert)
Log(ex, "长程主时钟执行异常", LogLevel.Critical)
End Try
End If
End Sub
@@ -957,7 +958,7 @@ NextFile:
Log(ex, "程序主时钟出错", LogLevel.Feedback)
End Try
End Sub, "Timer Main")
If Not IsAprilEnabled Then Exit Sub
If Not IsAprilEnabled Then Return
RunInNewThread(
Sub()
Try
Plain Craft Launcher 2/Modules/ModMusic.vb
+1 -1
View File
@@ -247,7 +247,7 @@
Log("[Music] 已恢复播放")
Try
MusicNAudio?.Play()
Catch 'https://github.com/Hex-Dragon/PCL2/pull/5415#issuecomment-2751135223
Catch 'https://github.com/Meloong-Git/PCL/pull/5415#issuecomment-2751135223
MusicNAudio?.Stop()
MusicNAudio?.Play()
End Try
Plain Craft Launcher 2/Modules/ModSecret.vb
+64 -71
View File
@@ -9,9 +9,11 @@ Friend Module ModSecret
'在开源版的注册表与常规版的注册表隔离，以防数据冲突
Public Const RegFolder As String = "PCLDebug"
'用于微软登录的 ClientId
Public Const OAuthClientId As String = ""
Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")
'CurseForge API Key
Public Const CurseForgeAPIKey As String = ""
Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "")
'用于匿名数据收集的腾讯云日志服务上报 URL，形如 https://{region}.cls.tencentcs.com/track?topic_id={topic_id}
Public Const ClsBaseUrl As String = ""
Friend Sub SecretOnApplicationStart()
'提升 UI 线程优先级
@@ -67,61 +69,27 @@ Friend Module ModSecret
If Not DataList.Any(Function(d) d.Contains("-Dlog4j2.formatMsgNoLookups=true")) Then DataList.Add("-Dlog4j2.formatMsgNoLookups=true")
End Sub
''' <summary>
''' 打码字符串中的 AccessToken。
''' </summary>
Friend Function SecretFilter(Raw As String, FilterChar As Char) As String
'打码 "accessToken " 后的内容
If Raw.Contains("accessToken ") Then
For Each Token In RegexSearch(Raw, "(?<=accessToken ([^ ]{5}))[^ ]+(?=[^ ]{5})")
Raw = Raw.Replace(Token, New String(FilterChar, Token.Count))
Next
End If
'打码当前登录的结果
Dim AccessToken As String = McLoginLoader.Output.AccessToken
If AccessToken Is Nothing OrElse AccessToken.Length < 10 OrElse Not Raw.ContainsF(AccessToken, True) OrElse
McLoginLoader.Output.Uuid = McLoginLoader.Output.AccessToken Then 'UUID 和 AccessToken 一样则不打码
Return Raw
Else
Return Raw.Replace(AccessToken, Left(AccessToken, 5) & New String(FilterChar, AccessToken.Length - 10) & Right(AccessToken, 5))
End If
End Function
#End Region
#Region "网络鉴权"
Friend Function SecretCdnSign(UrlWithMark As String)
Friend Function SecretCdnSign(UrlWithMark As String) As String
If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark
Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20")
End Function
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Client As WebClient, Optional UseBrowserUserAgent As Boolean = False)
Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional UseBrowserUserAgent As Boolean = False)
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Client.Headers("User-Agent") = "LogStatistic" '#4951
Req.Headers.Add("User-Agent", "LogStatistic") '#4951
ElseIf UseBrowserUserAgent Then
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Req.Headers.Add("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
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}")
End If
Client.Headers("Referer") = "http://" & VersionCode & ".open.pcl2.server/"
If Url.Contains("api.curseforge.com") Then Client.Headers("x-api-key") = CurseForgeAPIKey
End Sub
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Request As HttpWebRequest, Optional UseBrowserUserAgent As Boolean = False)
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Request.UserAgent = "LogStatistic" '#4951
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
End If
Request.Referer = "http://" & VersionCode & ".open.pcl2.server/"
If Url.Contains("api.curseforge.com") Then Request.Headers("x-api-key") = CurseForgeAPIKey
Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey)
End Sub
#End Region
@@ -198,45 +166,70 @@ Friend Module ModSecret
Public ThemeDontClick As Integer = 0
Public Sub ThemeRefresh(Optional NewTheme As Integer = -1)
Hint("该版本中不包含主题功能……")
Try
If ThemeNow = NewTheme AndAlso NewTheme >= 0 Then Return
If NewTheme >= 0 Then ThemeNow = NewTheme
Color1 = New MyColor().FromHSL2(ColorHue, ColorSat * 0.2, 25 + ColorLightAdjust * 0.3)
Color2 = New MyColor().FromHSL2(ColorHue, ColorSat, 45 + ColorLightAdjust)
Color3 = New MyColor().FromHSL2(ColorHue, ColorSat, 55 + ColorLightAdjust)
Color4 = New MyColor().FromHSL2(ColorHue, ColorSat, 65 + ColorLightAdjust)
Color5 = New MyColor().FromHSL2(ColorHue, ColorSat, 80 + ColorLightAdjust * 0.4)
Color6 = New MyColor().FromHSL2(ColorHue, ColorSat, 91 + ColorLightAdjust * 0.1)
Color7 = New MyColor().FromHSL2(ColorHue, ColorSat, 95)
Color8 = New MyColor().FromHSL2(ColorHue, ColorSat, 97)
ColorBg0 = Color4 * 0.4 + Color5 * 0.4 + ColorGray4 * 0.2
ColorBg1 = New MyColor(190, Color7)
ColorSemiTransparent = New MyColor(1, Color8)
Application.Current.Resources("ColorBrush1") = New SolidColorBrush(Color1)
Application.Current.Resources("ColorBrush2") = New SolidColorBrush(Color2)
Application.Current.Resources("ColorBrush3") = New SolidColorBrush(Color3)
Application.Current.Resources("ColorBrush4") = New SolidColorBrush(Color4)
Application.Current.Resources("ColorBrush5") = New SolidColorBrush(Color5)
Application.Current.Resources("ColorBrush6") = New SolidColorBrush(Color6)
Application.Current.Resources("ColorBrush7") = New SolidColorBrush(Color7)
Application.Current.Resources("ColorBrush8") = New SolidColorBrush(Color8)
Application.Current.Resources("ColorBrushBg0") = New SolidColorBrush(ColorBg0)
Application.Current.Resources("ColorBrushBg1") = New SolidColorBrush(ColorBg1)
Application.Current.Resources("ColorObject1") = CType(Color1, Color)
Application.Current.Resources("ColorObject2") = CType(Color2, Color)
Application.Current.Resources("ColorObject3") = CType(Color3, Color)
Application.Current.Resources("ColorObject4") = CType(Color4, Color)
Application.Current.Resources("ColorObject5") = CType(Color5, Color)
Application.Current.Resources("ColorObject6") = CType(Color6, Color)
Application.Current.Resources("ColorObject7") = CType(Color7, Color)
Application.Current.Resources("ColorObject8") = CType(Color8, Color)
Application.Current.Resources("ColorObjectBg0") = CType(ColorBg0, Color)
Application.Current.Resources("ColorObjectBg1") = CType(ColorBg1, Color)
ThemeRefreshMain()
Catch ex As Exception
Log(ex, "刷新主题颜色失败", LogLevel.Hint)
End Try
End Sub
Public Sub ThemeRefreshMain()
RunInUi(
Sub()
If Not FrmMain.IsLoaded Then Exit Sub
If Not FrmMain.IsLoaded Then Return
'顶部条背景
Dim Brush = New LinearGradientBrush With {.EndPoint = New Point(1, 0), .StartPoint = New Point(0, 0)}
If ThemeNow = 5 Then
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 25)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 15)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 25)})
FrmMain.PanTitle.Background = Brush
FrmMain.PanTitle.Background.Freeze()
ElseIf Not (ThemeNow = 12 OrElse ThemeDontClick = 2) Then
If TypeOf ColorHueTopbarDelta Is Integer Then
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 54 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
Else
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)})
End If
FrmMain.PanTitle.Background = Brush
FrmMain.PanTitle.Background.Freeze()
If TypeOf ColorHueTopbarDelta Is Integer Then
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 54 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
Else
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - 21, ColorSat, 53 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.33, .Color = New MyColor().FromHSL2(ColorHue - 7, ColorSat, 47 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.67, .Color = New MyColor().FromHSL2(ColorHue + 7, ColorSat, 47 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + 21, ColorSat, 53 + ColorLightAdjust)})
FrmMain.PanTitle.Background = Brush
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)})
End If
FrmMain.PanTitle.Background = Brush
FrmMain.PanTitle.Background.Freeze()
'主页面背景
If Setup.Get("UiBackgroundColorful") Then
Brush = New LinearGradientBrush With {.EndPoint = New Point(0.1, 1), .StartPoint = New Point(0.9, 0)}
Brush.GradientStops.Add(New GradientStop With {.Offset = -0.1, .Color = New MyColor().FromHSL2(ColorHue - 20, Math.Min(60, ColorSat) * 0.5, 80)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.9, 90)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1.1, .Color = New MyColor().FromHSL2(ColorHue + 20, Math.Min(60, ColorSat) * 0.5, 80)})
Brush.GradientStops.Add(New GradientStop With {.Offset = -0.1, .Color = New MyColor().FromHSL2(ColorHue - 15, ColorSat * 0.8, 91)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.8, 91)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1.1, .Color = New MyColor().FromHSL2(ColorHue + 15, ColorSat * 0.8, 91)})
FrmMain.PanForm.Background = Brush
Else
FrmMain.PanForm.Background = New MyColor(245, 245, 245)
Plain Craft Launcher 2/Modules/Reference/CookieWebClient.vb
-59
View File
@@ -1,59 +0,0 @@
Imports System.Net
Public Class CookieWebClient
Inherits WebClient
Public Sub New(container As CookieContainer, Headers As Dictionary(Of String, String))
Me.New(container)
For Each keyVal In Headers
Me.Headers(keyVal.Key) = keyVal.Value
Next
End Sub
Public Sub New()
Me.New(New CookieContainer())
End Sub
Public Sub New(container As CookieContainer)
Me.container = container
End Sub
Private Shadows ReadOnly container As New CookieContainer()
''' <summary>
''' 以毫秒为单位的超时。
''' </summary>
Public Timeout As Integer = 600000
Protected Overrides Function GetWebRequest(address As Uri) As WebRequest
Dim r As WebRequest = MyBase.GetWebRequest(address)
Dim request = TryCast(r, HttpWebRequest)
If request IsNot Nothing Then
request.CookieContainer = container
request.Timeout = Timeout
End If
Return r
End Function
Protected Overrides Function GetWebResponse(request As WebRequest, result As IAsyncResult) As WebResponse
Dim response As WebResponse = MyBase.GetWebResponse(request, result)
ReadCookies(response)
Return response
End Function
Protected Overrides Function GetWebResponse(request As WebRequest) As WebResponse
Dim response As WebResponse = MyBase.GetWebResponse(request)
ReadCookies(response)
Return response
End Function
Private Sub ReadCookies(r As WebResponse)
Dim response = TryCast(r, HttpWebResponse)
If response IsNot Nothing Then
Dim cookies As CookieCollection = response.Cookies
container.Add(cookies)
End If
End Sub
End Class
Plain Craft Launcher 2/Modules/Reference/SystemDropShadowChrome.vb
-299
View File
@@ -1,299 +0,0 @@
Public NotInheritable Class SystemDropShadowChrome
Inherits Decorator
'源码来源于：https://referencesource.microsoft.com/#PresentationFramework.Aero/parent/Shared/Microsoft/Windows/Themes/SystemDropShadowChrome.cs,6d9c27d92a8128c1
Public Shared ReadOnly ColorProperty As DependencyProperty = DependencyProperty.Register("Color", GetType(Color), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(Color.FromArgb(&H71, &H0, &H0, &H0), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)))
Public Property Color As Color
Get
Return CType(GetValue(ColorProperty), Color)
End Get
Set(value As Color)
SetValue(ColorProperty, value)
End Set
End Property
Public Shared ReadOnly CornerRadiusProperty As DependencyProperty = DependencyProperty.Register("CornerRadius", GetType(CornerRadius), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(New CornerRadius(), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)), New ValidateValueCallback(AddressOf IsCornerRadiusValid))
Public Property CornerRadius As CornerRadius
Get
Return CType(GetValue(CornerRadiusProperty), CornerRadius)
End Get
Set(value As CornerRadius)
SetValue(CornerRadiusProperty, value)
End Set
End Property
Private Shared Function IsCornerRadiusValid(value As Object) As Boolean
Dim cr As CornerRadius = CType(value, CornerRadius)
Return Not (cr.TopLeft < 0.0 OrElse cr.TopRight < 0.0 OrElse cr.BottomLeft < 0.0 OrElse cr.BottomRight < 0.0 OrElse Double.IsNaN(cr.TopLeft) OrElse Double.IsNaN(cr.TopRight) OrElse Double.IsNaN(cr.BottomLeft) OrElse Double.IsNaN(cr.BottomRight) OrElse Double.IsInfinity(cr.TopLeft) OrElse Double.IsInfinity(cr.TopRight) OrElse Double.IsInfinity(cr.BottomLeft) OrElse Double.IsInfinity(cr.BottomRight))
End Function
Private Const ShadowDepth As Double = 5
Protected Overrides Sub OnRender(drawingContext As DrawingContext)
Dim cornerRadius As CornerRadius = Me.CornerRadius
Dim shadowBounds As New Rect(New Point(ShadowDepth, ShadowDepth), New Size(RenderSize.Width, RenderSize.Height))
Dim color As Color = Me.Color
If shadowBounds.Width > 0 AndAlso shadowBounds.Height > 0 AndAlso color.A > 0 Then
Dim centerWidth As Double = shadowBounds.Right - shadowBounds.Left - 2 * ShadowDepth
Dim centerHeight As Double = shadowBounds.Bottom - shadowBounds.Top - 2 * ShadowDepth
Dim maxRadius As Double = Math.Min(centerWidth * 0.5, centerHeight * 0.5)
cornerRadius.TopLeft = Math.Min(cornerRadius.TopLeft, maxRadius)
cornerRadius.TopRight = Math.Min(cornerRadius.TopRight, maxRadius)
cornerRadius.BottomLeft = Math.Min(cornerRadius.BottomLeft, maxRadius)
cornerRadius.BottomRight = Math.Min(cornerRadius.BottomRight, maxRadius)
Dim brushes As Brush() = GetBrushes(color, cornerRadius)
Dim centerTop As Double = shadowBounds.Top + ShadowDepth
Dim centerLeft As Double = shadowBounds.Left + ShadowDepth
Dim centerRight As Double = shadowBounds.Right - ShadowDepth
Dim centerBottom As Double = shadowBounds.Bottom - ShadowDepth
Dim guidelineSetX As Double() = New Double() {centerLeft, centerLeft + cornerRadius.TopLeft, centerRight - cornerRadius.TopRight, centerLeft + cornerRadius.BottomLeft, centerRight - cornerRadius.BottomRight, centerRight}
Dim guidelineSetY As Double() = New Double() {centerTop, centerTop + cornerRadius.TopLeft, centerTop + cornerRadius.TopRight, centerBottom - cornerRadius.BottomLeft, centerBottom - cornerRadius.BottomRight, centerBottom}
drawingContext.PushGuidelineSet(New GuidelineSet(guidelineSetX, guidelineSetY))
cornerRadius.TopLeft += ShadowDepth
cornerRadius.TopRight += ShadowDepth
cornerRadius.BottomLeft += ShadowDepth
cornerRadius.BottomRight += ShadowDepth
Dim topLeft As New Rect(shadowBounds.Left, shadowBounds.Top, cornerRadius.TopLeft, cornerRadius.TopLeft)
drawingContext.DrawRectangle(brushes(Placement.TopLeft), Nothing, topLeft)
Dim topWidth As Double = guidelineSetX(2) - guidelineSetX(1)
If topWidth > 0 Then
Dim top As New Rect(guidelineSetX(1), shadowBounds.Top, topWidth, ShadowDepth)
drawingContext.DrawRectangle(brushes(Placement.Top), Nothing, top)
End If
Dim topRight As New Rect(guidelineSetX(2), shadowBounds.Top, cornerRadius.TopRight, cornerRadius.TopRight)
drawingContext.DrawRectangle(brushes(Placement.TopRight), Nothing, topRight)
Dim leftHeight As Double = guidelineSetY(3) - guidelineSetY(1)
If leftHeight > 0 Then
Dim left As New Rect(shadowBounds.Left, guidelineSetY(1), ShadowDepth, leftHeight)
drawingContext.DrawRectangle(brushes(Placement.Left), Nothing, left)
End If
Dim rightHeight As Double = guidelineSetY(4) - guidelineSetY(2)
If rightHeight > 0 Then
Dim right As New Rect(guidelineSetX(5), guidelineSetY(2), ShadowDepth, rightHeight)
drawingContext.DrawRectangle(brushes(Placement.Right), Nothing, right)
End If
Dim bottomLeft As New Rect(shadowBounds.Left, guidelineSetY(3), cornerRadius.BottomLeft, cornerRadius.BottomLeft)
drawingContext.DrawRectangle(brushes(Placement.BottomLeft), Nothing, bottomLeft)
Dim bottomWidth As Double = guidelineSetX(4) - guidelineSetX(3)
If bottomWidth > 0 Then
Dim bottom As New Rect(guidelineSetX(3), guidelineSetY(5), bottomWidth, ShadowDepth)
drawingContext.DrawRectangle(brushes(Placement.Bottom), Nothing, bottom)
End If
Dim bottomRight As New Rect(guidelineSetX(4), guidelineSetY(4), cornerRadius.BottomRight, cornerRadius.BottomRight)
drawingContext.DrawRectangle(brushes(Placement.BottomRight), Nothing, bottomRight)
If cornerRadius.TopLeft = ShadowDepth AndAlso cornerRadius.TopLeft = cornerRadius.TopRight AndAlso cornerRadius.TopLeft = cornerRadius.BottomLeft AndAlso cornerRadius.TopLeft = cornerRadius.BottomRight Then
Dim center As New Rect(guidelineSetX(0), guidelineSetY(0), centerWidth, centerHeight)
drawingContext.DrawRectangle(brushes(Placement.Center), Nothing, center)
Else
Dim figure As New PathFigure()
If cornerRadius.TopLeft > ShadowDepth Then
figure.StartPoint = New Point(guidelineSetX(1), guidelineSetY(0))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(1), guidelineSetY(1)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(1)), True))
Else
figure.StartPoint = New Point(guidelineSetX(0), guidelineSetY(0))
End If
If cornerRadius.BottomLeft > ShadowDepth Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(3)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(3)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(5)), True))
Else
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(5)), True))
End If
If cornerRadius.BottomRight > ShadowDepth Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(5)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(4)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(4)), True))
Else
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(5)), True))
End If
If cornerRadius.TopRight > ShadowDepth Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(2)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(2)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(0)), True))
Else
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(0)), True))
End If
figure.IsClosed = True
figure.Freeze()
Dim geometry As New PathGeometry()
geometry.Figures.Add(figure)
geometry.Freeze()
drawingContext.DrawGeometry(brushes(Placement.Center), Nothing, geometry)
End If
drawingContext.Pop()
End If
End Sub
Private Enum Placement
TopLeft = 0
Top = 1
TopRight = 2
Left = 3
Center = 4
Right = 5
BottomLeft = 6
Bottom = 7
BottomRight = 8
End Enum
Private Shared _commonBrushes As Brush()
Private Shared _commonCornerRadius As CornerRadius
Private Shared ReadOnly _resourceAccess As New Object()
Private _brushes As Brush()
Private Shared Sub ClearBrushes(o As DependencyObject, e As DependencyPropertyChangedEventArgs)
CType(o, SystemDropShadowChrome)._brushes = Nothing
End Sub
Private Shared Function CreateStops(c As Color, cornerRadius As Double) As GradientStopCollection
Dim gradientScale As Double = 1 / (cornerRadius + ShadowDepth)
Dim gsc As New GradientStopCollection From {
New GradientStop(c, (0.5 + cornerRadius) * gradientScale)
}
Dim stopColor As Color = c
stopColor.A = CByte(0.74336 * c.A)
gsc.Add(New GradientStop(stopColor, (1.5 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.38053 * c.A)
gsc.Add(New GradientStop(stopColor, (2.5 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.12389 * c.A)
gsc.Add(New GradientStop(stopColor, (3.5 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.02654 * c.A)
gsc.Add(New GradientStop(stopColor, (4.5 + cornerRadius) * gradientScale))
stopColor.A = 0
gsc.Add(New GradientStop(stopColor, (5 + cornerRadius) * gradientScale))
gsc.Freeze()
Return gsc
End Function
Private Shared Function CreateBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
Dim brushes As Brush() = New Brush(8) {}
brushes(Placement.Center) = New SolidColorBrush(c)
brushes(Placement.Center).Freeze()
Dim sideStops As GradientStopCollection = CreateStops(c, 0)
Dim top As New LinearGradientBrush(sideStops, New Point(0, 1), New Point(0, 0))
top.Freeze()
brushes(Placement.Top) = top
Dim left As New LinearGradientBrush(sideStops, New Point(1, 0), New Point(0, 0))
left.Freeze()
brushes(Placement.Left) = left
Dim right As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(1, 0))
right.Freeze()
brushes(Placement.Right) = right
Dim bottom As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(0, 1))
bottom.Freeze()
brushes(Placement.Bottom) = bottom
Dim topLeftStops As GradientStopCollection
If cornerRadius.TopLeft = 0 Then
topLeftStops = sideStops
Else
topLeftStops = CreateStops(c, cornerRadius.TopLeft)
End If
Dim topLeft As New RadialGradientBrush(topLeftStops) With {
.RadiusX = 1,
.RadiusY = 1,
.Center = New Point(1, 1),
.GradientOrigin = New Point(1, 1)
}
topLeft.Freeze()
brushes(Placement.TopLeft) = topLeft
Dim topRightStops As GradientStopCollection
If cornerRadius.TopRight = 0 Then
topRightStops = sideStops
ElseIf cornerRadius.TopRight = cornerRadius.TopLeft Then
topRightStops = topLeftStops
Else
topRightStops = CreateStops(c, cornerRadius.TopRight)
End If
Dim topRight As New RadialGradientBrush(topRightStops) With {
.RadiusX = 1,
.RadiusY = 1,
.Center = New Point(0, 1),
.GradientOrigin = New Point(0, 1)
}
topRight.Freeze()
brushes(Placement.TopRight) = topRight
Dim bottomLeftStops As GradientStopCollection
If cornerRadius.BottomLeft = 0 Then
bottomLeftStops = sideStops
ElseIf cornerRadius.BottomLeft = cornerRadius.TopLeft Then
bottomLeftStops = topLeftStops
ElseIf cornerRadius.BottomLeft = cornerRadius.TopRight Then
bottomLeftStops = topRightStops
Else
bottomLeftStops = CreateStops(c, cornerRadius.BottomLeft)
End If
Dim bottomLeft As New RadialGradientBrush(bottomLeftStops) With {
.RadiusX = 1,
.RadiusY = 1,
.Center = New Point(1, 0),
.GradientOrigin = New Point(1, 0)
}
bottomLeft.Freeze()
brushes(Placement.BottomLeft) = bottomLeft
Dim bottomRightStops As GradientStopCollection
If cornerRadius.BottomRight = 0 Then
bottomRightStops = sideStops
ElseIf cornerRadius.BottomRight = cornerRadius.TopLeft Then
bottomRightStops = topLeftStops
ElseIf cornerRadius.BottomRight = cornerRadius.TopRight Then
bottomRightStops = topRightStops
ElseIf cornerRadius.BottomRight = cornerRadius.BottomLeft Then
bottomRightStops = bottomLeftStops
Else
bottomRightStops = CreateStops(c, cornerRadius.BottomRight)
End If
Dim bottomRight As New RadialGradientBrush(bottomRightStops) With {
.RadiusX = 1,
.RadiusY = 1,
.Center = New Point(0, 0),
.GradientOrigin = New Point(0, 0)
}
bottomRight.Freeze()
brushes(Placement.BottomRight) = bottomRight
Return brushes
End Function
Private Function GetBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
If _commonBrushes Is Nothing Then
SyncLock _resourceAccess
If _commonBrushes Is Nothing Then
_commonBrushes = CreateBrushes(c, cornerRadius)
_commonCornerRadius = cornerRadius
End If
End SyncLock
End If
If c = CType(_commonBrushes(Placement.Center), SolidColorBrush).Color AndAlso cornerRadius = _commonCornerRadius Then
_brushes = Nothing
Return _commonBrushes
ElseIf _brushes Is Nothing Then
_brushes = CreateBrushes(c, cornerRadius)
End If
Return _brushes
End Function
End Class
Plain Craft Launcher 2/Modules/ThirdParty/DragHelper.vb
Vendored
+151
View File
@@ -0,0 +1,151 @@
'来源：https://blog.csdn.net/simpleman2000/article/details/140952294
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Imports System.Windows.Interop
Public Class DragHelper
Public Event DragDrop As EventHandler
Public Property DropFilePaths As String()
Get
Return _DropFilePathsBackingField
End Get
Private Set(value As String())
_DropFilePathsBackingField = value
End Set
End Property
Private _DropFilePathsBackingField As String()
Public Property DropPoint As POINT
Get
Return _DropPointBackingField
End Get
Private Set(value As POINT)
_DropPointBackingField = value
End Set
End Property
Private _DropPointBackingField As POINT
Public Property HwndIntPtrSource As HwndSource
Public Sub AddHook()
RemoveDragHook()
HwndIntPtrSource.AddHook(AddressOf WndProc)
Dim handle As IntPtr = HwndIntPtrSource.Handle
If IsUserAnAdmin() Then RevokeDragDrop(handle)
DragAcceptFiles(handle, True)
ChangeMessageFilter(handle)
End Sub
Public Sub RemoveDragHook()
HwndIntPtrSource.RemoveHook(AddressOf WndProc)
DragAcceptFiles(HwndIntPtrSource.Handle, False)
End Sub
Private Function WndProc(hwnd As IntPtr, msg As Integer, wParam As IntPtr, lParam As IntPtr, ByRef handled As Boolean) As IntPtr
Dim filePaths As String() = Nothing
Dim point As New POINT()
If TryGetDropInfo(msg, wParam, filePaths, point) Then
DropPoint = point
DropFilePaths = filePaths
RaiseEvent DragDrop(Me, EventArgs.Empty)
handled = True
End If
Return IntPtr.Zero
End Function
<DllImport("user32.dll", SetLastError:=True)>
Private Shared Function ChangeWindowMessageFilterEx(hWnd As IntPtr, msg As UInteger, action As UInteger, ByRef pChangeFilterStruct As CHANGEFILTERSTRUCT) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True)>
Private Shared Function ChangeWindowMessageFilter(msg As UInteger, flags As UInteger) As Boolean
End Function
<DllImport("shell32.dll")>
Private Shared Sub DragAcceptFiles(hWnd As IntPtr, fAccept As Boolean)
End Sub
<DllImport("shell32.dll", CharSet:=CharSet.Unicode)>
Private Shared Function DragQueryFile(hWnd As IntPtr, iFile As UInteger, lpszFile As StringBuilder, cch As Integer) As UInteger
End Function
<DllImport("shell32.dll")>
Private Shared Function DragQueryPoint(hDrop As IntPtr, ByRef lppt As POINT) As Boolean
End Function
<DllImport("shell32.dll")>
Private Shared Sub DragFinish(hDrop As IntPtr)
End Sub
<DllImport("ole32.dll")>
Private Shared Function RevokeDragDrop(hWnd As IntPtr) As Integer
End Function
<DllImport("shell32.dll")>
Private Shared Function IsUserAnAdmin() As Boolean
End Function
<StructLayout(LayoutKind.Sequential)>
Public Structure POINT
Public X As Integer
Public Y As Integer
End Structure
<StructLayout(LayoutKind.Sequential)>
Private Structure CHANGEFILTERSTRUCT
Public cbSize As UInteger
Public ExtStatus As UInteger
End Structure
Private Const WM_COPYGLOBALDATA As UInteger = &H49
Private Const WM_COPYDATA As UInteger = &H4A
Private Const WM_DROPFILES As UInteger = &H233
Private Const MSGFLT_ALLOW As UInteger = 1
Private Const MSGFLT_ADD As UInteger = 1
Private Const MAX_PATH As Integer = 260
Private Shared Sub ChangeMessageFilter(handle As IntPtr)
Dim ver As Version = Environment.OSVersion.Version
Dim isVistaOrHigher As Boolean = ver >= New Version(6, 0)
Dim isNt61OrHiger As Boolean = ver >= New Version(6, 1)
If isVistaOrHigher Then
Dim status As New CHANGEFILTERSTRUCT With {.cbSize = 8}
For Each msg As UInteger In New UInteger() {WM_DROPFILES, WM_COPYGLOBALDATA, WM_COPYDATA}
Dim [error] As Boolean = False
If isNt61OrHiger Then
[error] = Not ChangeWindowMessageFilterEx(handle, msg, MSGFLT_ALLOW, status)
Else
[error] = Not ChangeWindowMessageFilter(msg, MSGFLT_ADD)
End If
If [error] Then Throw New Win32Exception(Marshal.GetLastWin32Error())
Next
End If
End Sub
Private Shared Function TryGetDropInfo(msg As Integer, wParam As IntPtr, ByRef dropFilePaths As String(), ByRef dropPoint As POINT) As Boolean
dropFilePaths = Nothing
dropPoint = New POINT()
If msg <> WM_DROPFILES Then Return False
Dim fileCount As UInteger = DragQueryFile(wParam, UInteger.MaxValue, Nothing, 0)
ReDim dropFilePaths(CInt(fileCount) - 1)
For i As UInteger = 0 To CInt(fileCount) - 1
Dim sb As New StringBuilder(MAX_PATH)
Dim result As UInteger = DragQueryFile(wParam, i, sb, sb.Capacity)
If result > 0 Then dropFilePaths(i) = sb.ToString()
Next
DragQueryPoint(wParam, dropPoint)
DragFinish(wParam)
Return True
End Function
End Class