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

2.12.8.0

Browse Source
This commit is contained in:
龙腾猫跃
2026-05-15 22:06:22 +08:00
parent 277c020186
commit 53fe8204cf
110 changed files with 30470 additions and 4729 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Base/ModAnimation.vb
+11 -10
View File
@@ -12,7 +12,7 @@ Public Module ModAnimation
''' </summary>
Public ReadOnly Property AniSpeed As Double
Get
Dim Setting As Integer = Settings.Get("SystemDebugAnim")
Dim Setting As Integer = Settings.Get(Of Integer)("SystemDebugAnim")
Return If(Setting >= 30, 200, (Setting * 0.1 + 0.1).Clamp(0.1, 3))
End Get
End Property
@@ -114,7 +114,7 @@ Public Module ModAnimation
Public ValueLast As Object
Public Overrides Function ToString() As String
Return GetStringFromEnum(TypeMain) & " | " & TimeFinished & "/" & TimeTotal & "(" & Math.Round(TimePercent * 100) & "%)" & If(Obj Is Nothing, "", " | " & Obj.ToString & "(" & Obj.GetType.Name & ")")
Return TypeMain.ToString() & " | " & TimeFinished & "/" & TimeTotal & "(" & Math.Round(TimePercent * 100) & "%)" & If(Obj Is Nothing, "", " | " & Obj.ToString & "(" & Obj.GetType.Name & ")")
End Function
End Structure
@@ -521,13 +521,14 @@ Public Module ModAnimation
''' </summary>
''' <remarks></remarks>
Public Function AaStack(Stack As StackPanel, Optional Time As Integer = 100, Optional Delay As Integer = 25) As List(Of AniData)
AaStack = New List(Of AniData)
Dim Result = New List(Of AniData)
Dim AniDelay As Integer = 0
For Each Item In Stack.Children
Item.Opacity = 0
AaStack.Add(AaOpacity(Item, 1, Time, AniDelay))
Result.Add(AaOpacity(Item, 1, Time, AniDelay))
AniDelay += Delay
Next
Return Result
End Function
#End Region
@@ -810,7 +811,7 @@ Public Module ModAnimation
RunInNewThread(
Sub()
Try
Log("[Animation] 动画线程开始")
Logger.Info("动画线程开始")
Do While True
'两帧之间的间隔时间
Dim DeltaTime As Long = (GetTimeMs() - AniLastTick).Clamp(0, 100000)
@@ -831,7 +832,7 @@ Public Module ModAnimation
AniCount = 0
AniTimer(DeltaTime * AniSpeed)
If RandomInteger(0, 64 * If(ModeDebug, 5, 30)) = 0 AndAlso ((AniFPS < 62 AndAlso AniFPS > 0) OrElse AniCount > 4 OrElse NetManager.FileRemain <> 0) Then
Log("[Report] FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManager.FileRemain & "（" & FormatFileSize(NetManager.Speed) & "/s）")
Logger.Info($"FPS {AniFPS}, 动画 {AniCount}, 下载中 {NetManager.FileRemain}（{FormatFileSize(NetManager.Speed)}/s）")
End If
End Sub)
Sleeper:
@@ -839,7 +840,7 @@ Sleeper:
Thread.Sleep(1)
Loop
Catch ex As Exception
Log(ex, "动画帧执行失败", NotifyLevel.Critical)
Logger.Error(ex, "动画帧执行失败", LogBehavior.AlertThenCrash)
End Try
End Sub, "Animation", ThreadPriority.AboveNormal)
End Sub
@@ -850,7 +851,7 @@ Sleeper:
Public Sub AniTimer(DeltaTick As Integer)
Try
If DeltaTick / AniSpeed > 100 Then Log("[Animation] 两个动画帧间隔 " & DeltaTick & " ms", NotifyLevel.DevelopOnly)
If DeltaTick / AniSpeed > 100 Then Logger.Info($"两个动画帧间隔 {DeltaTick} ms")
Dim i As Integer = -1
'循环每个动画组
Do While i + 1 < AniGroups.Count
@@ -915,7 +916,7 @@ NextAni:
Loop
Catch ex As Exception
Log(ex, "动画刻执行失败", NotifyLevel.AllUsers)
Logger.Error(ex, "动画刻执行失败", LogBehavior.Toast)
End Try
End Sub
@@ -1052,7 +1053,7 @@ NextAni:
End Select
Ani.TimePercent = Ani.TimeFinished / Ani.TimeTotal '修改执行百分比
Catch ex As Exception
Log(ex, "执行动画失败：" & Ani.ToString, NotifyLevel.AllUsers)
Logger.Error(ex, $"执行动画失败：{Ani}", LogBehavior.Toast)
End Try
Return Ani
End Function
Plain Craft Launcher 2/Modules/Base/ModBase.vb
+150 -1207
View File
File diff suppressed because it is too large Load Diff
Plain Craft Launcher 2/Modules/Base/ModLoader.vb
+27 -28
View File
@@ -38,7 +38,7 @@
RealParent = RealParent.Parent
End While
Catch ex As Exception
Log(ex, "获取父加载器失败（" & Name & "）", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, $"获取父加载器失败（{Name}）")
Return Nothing
End Try
End Get
@@ -88,9 +88,9 @@
Set(value As LoadState)
If _State = value Then Return
Dim OldState = _State
If value = LoadState.Finished AndAlso Settings.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
If value = LoadState.Finished AndAlso Settings.Get(Of Boolean)("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
_State = value
If Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载器 {Name} 状态改变：{GetStringFromEnum(value)}")
If Not LogBlackList.Contains(Name) Then Logger.Info($"加载器 {Name} 状态改变：{value}")
'实现 ILoadingTrigger 接口与 OnStateChanged 回调
RunInUi(
Sub()
@@ -229,13 +229,13 @@
''' <summary>
''' 用于异步执行并监控单一函数的加载器。
''' </summary>
Public Class LoaderTask(Of InputType, OutputType)
Public Class LoaderTask(Of TIn, TOut)
Inherits LoaderBase
'线程设定
Protected Friend ThreadPriority As ThreadPriority
'执行事件
Protected Friend LoadDelegate As Action(Of LoaderTask(Of InputType, OutputType))
Protected Friend LoadDelegate As Action(Of LoaderTask(Of TIn, TOut))
Protected Friend InputDelegate As Func(Of Object)
'状态指示
''' <summary>
@@ -265,25 +265,25 @@
''' </summary>
Public LastRunningThread As Thread = Nothing
'输入输出
Public Input As InputType = Nothing
Public Output As OutputType = Nothing
Public Input As TIn = Nothing
Public Output As TOut = Nothing
'获取输入
Public Function StartGetInput(Optional Input As InputType = Nothing, Optional InputDelegate As Func(Of Object) = Nothing) As InputType 'InputDelegate 参数存在匿名调用
Public Function StartGetInput(Optional Input As TIn = Nothing, Optional InputDelegate As Func(Of TIn) = Nothing) As TIn 'InputDelegate 参数存在匿名调用
If InputDelegate Is Nothing Then InputDelegate = Me.InputDelegate
Dim NewInput As InputType = Nothing '若 InputType 不能为 Nothing，则会导致 Input Is Nothing 永远失败，因此需要额外判断
Dim NewInput As TIn = Nothing '若 InputType 不能为 Nothing，则会导致 Input Is Nothing 永远失败，因此需要额外判断
If (Input Is Nothing OrElse (NewInput IsNot Nothing AndAlso Input.Equals(NewInput))) AndAlso InputDelegate IsNot Nothing Then
RunInUiWait(Sub() Input = InputDelegate())
End If
Return Input
End Function
'代码执行
Public Function ShouldStart(ByRef Input As Object, Optional IsForceRestart As Boolean = False, Optional IgnoreReloadTimeout As Boolean = False) As Boolean
Public Function ShouldStart(ByRef Input As TIn, Optional IsForceRestart As Boolean = False, Optional IgnoreReloadTimeout As Boolean = False) As Boolean
'获取输入
Try
Input = StartGetInput(Input)
Catch ex As Exception
Log(ex, "加载输入获取失败（" & Name & "）", NotifyLevel.AllUsers)
Logger.Error(ex, $"加载输入获取失败（{Name}）", LogBehavior.Toast)
[Error] = ex
SyncLock LockState
State = LoadState.Failed
@@ -319,21 +319,21 @@
Sub()
Try
IsForceRestarting = IsForceRestart
If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
If Not LogBlackList.Contains(Name) Then Logger.Trace(Function() $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
LoadDelegate(Me)
If IsInterrupted Then
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", NotifyLevel.DevelopOnly)
Logger.Warn($"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）")
Return
End If
If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成")
If Not LogBlackList.Contains(Name) Then Logger.Trace(Function() $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成")
RaisePreviewFinish()
State = LoadState.Finished
LastFinishedTime = GetTimeMs() '未中断，本次输出有效
Catch ex As CancelledException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
Logger.Trace(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
If Not IsInterrupted Then State = LoadState.Interrupted
Catch ex As ThreadInterruptedException
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
Logger.Trace(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
'如果线程是因为判断到 IsInterrupted 而提前中止，则代表已有新线程被重启，此时不应当改为 Interrupted
'如果线程是在没有 IsInterrupted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Interrupted
If Not IsInterrupted Then State = LoadState.Interrupted
@@ -354,7 +354,7 @@
If IsInterrupted OrElse State >= LoadState.Finished Then Return
State = LoadState.Failed
End SyncLock
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%")
TriggerThreadInterrupt()
End Sub
Public Overrides Sub Interrupt()
@@ -368,7 +368,7 @@
If LastRunningThread Is Nothing Then Return
If LastRunningThread.IsAlive Then
LastRunningThread.Interrupt()
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断")
Logger.Trace(Function() $"加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断")
End If
LastRunningThread = Nothing
End Sub
@@ -376,7 +376,7 @@
Public Sub New()
'仅仅是为了避免一些智障报错（继承类必须重写 New 的情况）
End Sub
Public Sub New(Name As String, LoadDelegate As Action(Of LoaderTask(Of InputType, OutputType)), Optional InputDelegate As Func(Of InputType) = Nothing, Optional Priority As ThreadPriority = ThreadPriority.Normal)
Public Sub New(Name As String, LoadDelegate As Action(Of LoaderTask(Of TIn, TOut)), Optional InputDelegate As Func(Of TIn) = Nothing, Optional Priority As ThreadPriority = ThreadPriority.Normal)
Me.Name = Name
Me.LoadDelegate = LoadDelegate
Me.InputDelegate = InputDelegate
@@ -515,7 +515,7 @@
'检查是否需要重启
If Loader.GetType.Name.StartsWithF("LoaderTask") Then '类型名后面带有泛型，必须用 StartsWith
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
Log("[Loader] 由于输入条件变更，重启已完成的加载器 " & Loader.Name)
Logger.Info($"由于输入条件变更，重启已完成的加载器 {Loader.Name}")
GoTo Restart
End If
'更新下一个加载器的输入
@@ -527,7 +527,7 @@
'检查是否需要重启
If Loader.GetType.Name.StartsWithF("LoaderTask") Then
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
Log("[Loader] 由于输入条件变更，重启进行中的加载器 " & Loader.Name, NotifyLevel.DevelopOnly)
Logger.Warn($"由于输入条件变更，重启进行中的加载器 {Loader.Name}")
GoTo Restart
End If
End If
@@ -598,7 +598,7 @@ Restart:
Public Sub LoaderTaskbarAdd(Of T)(Loader As LoaderCombo(Of T))
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRemove(Loader)
LoaderTaskbar.Add(Loader)
Log($"[Taskbar] {Loader.Name} 已加入任务列表")
Logger.Info($"{Loader.Name} 已加入任务列表")
End Sub
Public Sub LoaderTaskbarProgressRefresh()
Try
@@ -610,7 +610,7 @@ Restart:
(Task.State = LoadState.Waiting OrElse Task.State = LoadState.Interrupted) Then
FrmSpeedLeft?.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
Logger.Info($"{Task.Name} 已移出任务列表")
End If
Next
'更新平滑后的进度
@@ -635,7 +635,7 @@ Restart:
FrmMain.BtnExtraDownload.ShowRefresh()
End If
Catch ex As Exception
Log(ex, "刷新任务栏进度显示失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "刷新任务栏进度显示失败")
End Try
End Sub
Public Function LoaderTaskbarProgressGet() As Double
@@ -643,7 +643,7 @@ Restart:
If Not LoaderTaskbar.Any Then Return 1
Return LoaderTaskbar.Select(Function(l) l.Progress).Average().Clamp(0, 1)
Catch ex As Exception
Log(ex, "获取任务栏进度出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "获取任务栏进度出错")
Return 0.5
End Try
End Function
@@ -671,11 +671,10 @@ Restart:
''' </summary>
''' <param name="ExtraPath">用于检查文件夹修改的额外路径。该路径不会传入加载器。</param>
Public Function LoaderFolderRun(Loader As LoaderBase, FolderPath As String, Type As LoaderFolderRunType, Optional MaxDepth As Integer = 0, Optional ExtraPath As String = "", Optional WaitForExit As Boolean = False) As Boolean
Dim FolderInfo As DirectoryInfo
Dim Value As New LoaderFolderDictionaryEntry With {.FolderPath = FolderPath & ExtraPath, .LastCheckTime = Nothing}
Try
'获取数据
FolderInfo = New DirectoryInfo(FolderPath & ExtraPath)
Dim FolderInfo = DirectoryUtils.GetInfo(FolderPath & ExtraPath)
Value.LastCheckTime = If(FolderInfo.Exists, GetActualLastWriteTimeUtc(FolderInfo, MaxDepth), DirectCast(Nothing, Date?))
'如果已经检查过，则跳过
If Type = LoaderFolderRunType.RunOnUpdated AndAlso LoaderFolderDictionary.ContainsKey(Loader) Then
@@ -687,7 +686,7 @@ Restart:
End If
End If
Catch ex As Exception
Log(ex, "文件夹加载器启动检测出错")
Logger.Warn(ex, "文件夹加载器启动检测出错")
End Try
'写入检查数据
LoaderFolderDictionary(Loader) = Value
Plain Craft Launcher 2/Modules/Base/ModNet.vb
+113 -179
View File
@@ -1,5 +1,4 @@
Imports System.Net.Sockets
Imports System.Runtime.CompilerServices
Imports System.Threading.Tasks
Public Module ModNet
@@ -14,12 +13,12 @@ Public Module ModNet
Optional Timeout As Integer = 25000, Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False,
Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False, Optional MakeLog As Boolean = True) As String
If Method Is Nothing Then Method = HttpMethod.Get
If MakeLog Then Log("[Net] 发起网络请求（" & Method.Method & "，" & Url & "），最大超时 " & Timeout)
If MakeLog Then Logger.Info($"发起网络请求（{Method.Method}，{Url}），最大超时 {Timeout}")
Try
Dim HeaderDictionary = If(Headers, {}).ToDictionary
If ContentType IsNot Nothing Then HeaderDictionary("Content-Type") = ContentType
If Accept IsNot Nothing Then HeaderDictionary("Accept") = Accept
Dim Result = If(Encoding, Encoding.UTF8).GetString(SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, SimulateBrowserHeaders:=SimulateBrowserHeaders))
Dim Result = SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, SimulateBrowserHeaders:=SimulateBrowserHeaders).GetString(Encoding)
'检查结果是否为完整 JSON（在 #6683 中可能返回空，在被 GFW 截断时可能不完整）
'在此处检查并报错，可以让 NetRequestByClientRetry 等方法进行重试
If RequireJson Then
@@ -36,7 +35,7 @@ Public Module ModNet
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If MakeLog Then Log(ex, "网络请求失败", NotifyLevel.DevelopOnly)
If MakeLog Then Logger.Warn(ex, "网络请求失败")
Throw
End Try
End Function
@@ -72,9 +71,10 @@ Retry:
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If TypeOf ex Is ResponsedWebException Then
If CType(ex, ResponsedWebException).StatusCode = HttpStatusCode.Forbidden Then Throw
If CType(ex, ResponsedWebException).StatusCode = 429 Then Thread.Sleep(10000) 'Too Many Requests
If TypeOf ex Is HttpRequestCodeException Then
If CType(ex, HttpRequestCodeException).StatusCode = HttpStatusCode.Forbidden Then Throw
If CType(ex, HttpRequestCodeException).StatusCode = HttpStatusCode.NotFound Then Throw
If CType(ex, HttpRequestCodeException).StatusCode = 429 Then Thread.Sleep(10000) 'Too Many Requests
End If
'重试
Select Case RetryCount
@@ -157,8 +157,9 @@ RequestFinished:
Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, SimulateBrowserHeaders)})
Try
NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时（第一下载源：" & Urls.First & "）")
NetRequestByLoader = ReadFile(Temp)
File.Delete(Temp)
Dim Result = FileUtils.ReadAsString(Temp)
FileUtils.Delete(Temp)
Return Result
Finally
NewTask.Interrupt()
End Try
@@ -173,29 +174,21 @@ RequestFinished:
''' 不建议用于下载大文件。
''' </summary>
Public Sub NetDownloadByClient(Url As String, LocalPath As String, Optional SimulateBrowserHeaders As Boolean = False)
Log($"[Net] 通过网络请求直接下载小文件：{Url} → {LocalPath}")
'初始化文件路径
Try
DirectoryUtils.Create(LocalPath, isFilePath:=True)
File.Delete(LocalPath)
Catch ex As Exception
Throw New Exception($"预处理下载文件路径失败（{LocalPath}）", ex)
End Try
'下载
Logger.Info($"通过网络请求直接下载小文件：{Url} → {LocalPath}")
Dim RetryCount As Integer = 0
Retry:
Try
File.WriteAllBytes(LocalPath, SendRequest(Url, HttpMethod.Get, SimulateBrowserHeaders:=SimulateBrowserHeaders))
FileUtils.Write(LocalPath, SendRequest(Url, HttpMethod.Get, SimulateBrowserHeaders:=SimulateBrowserHeaders))
Catch ex As ThreadInterruptedException
File.Delete(LocalPath)
FileUtils.Delete(LocalPath)
Throw
Catch ex As Exception
File.Delete(LocalPath)
FileUtils.Delete(LocalPath)
If RetryCount < 2 Then
RetryCount += 1
GoTo Retry
End If
Throw New WebException($"通过网络请求直接下载小文件失败（{LocalPath}）", ex)
Throw New HttpRequestException($"通过网络请求直接下载小文件失败（{LocalPath}）", ex)
End Try
End Sub
@@ -259,6 +252,7 @@ Retry:
HostIp = DNSLookup(Request, CancelToken.Token)
If HostIp IsNot Nothing Then IPReliability.GetOrAdd(HostIp, -0.01) '预先降低一点，这样快速的重复请求会使用不同的 IP 以提高成功率
'发送请求
Directory.CreateDirectory(PathTemp & "Cache\Http\")
SyncLock RequestClientLock
If RequestClient Is Nothing Then '延迟初始化，以避免在程序启动前加载 CacheCow 导致 DLL 加载失败
RequestClient = CacheCow.Client.ClientExtensions.CreateClient(New CacheCow.Client.FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With {
@@ -283,14 +277,14 @@ Retry:
Return ResponseBytes
Else
RecordIPReliability(HostIp, -0.7)
Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes)
Throw New ResponsedWebException(
Dim ResponseMessage = ResponseBytes.GetString(Encoding)
Throw New HttpRequestCodeException(
$"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}，{HostIp}" &
If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), Response.StatusCode, ResponseMessage)
End If
Catch ex As ThreadInterruptedException
Throw
Catch ex As ResponsedWebException
Catch ex As HttpRequestException
Throw
Catch ex As FileNotFoundException
'由于 CacheCow 读取缓存失败，然后系统调用不存在的 System.Net.Http.Formatting.resources 抛出（#8150）
@@ -299,7 +293,7 @@ Retry:
RecordIPReliability(HostIp, -1)
If TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException Then 'CancellationToken 超时
Throw New WebException($"连接服务器超时，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout)
ElseIf ex.IsNetworkRelated Then
ElseIf ex.IsBadNetwork Then
Throw New WebException($"网络请求失败，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout)
Else
Throw New Exception($"网络请求出现意外异常（{Method}, {Url}，{HostIp}）", ex)
@@ -337,12 +331,12 @@ Retry:
If WaitHandle.WaitAny(New WaitHandle() {AsyncResult.AsyncWaitHandle, CancelToken.WaitHandle}) Then Throw New TimeoutException("DNS 解析超时")
Candidates = Dns.EndGetHostAddresses(AsyncResult).Distinct.ToArray
Catch ex As Exception
Log(ex, $"DNS 解析失败（{Host}）")
Logger.Warn(ex, $"DNS 解析失败（{Host}）")
DNSFailureRecord(Host) = Date.Now
Return Nothing
End Try
If Not Candidates.Any Then
Log($"[Net] DNS 解析无结果（{Host}）")
Logger.Info($"DNS 解析无结果（{Host}）")
Return Nothing
End If
'若同时存在 IPv4 和 IPv6 地址，仅选择其中一类（因为 GFW 可能只屏蔽了 IPv4 或 IPv6）
@@ -353,7 +347,7 @@ Retry:
Dim IPv4Reliability = IPv4Targets.Max(Function(i) Reliabilities(i))
Dim IPv6Reliability = IPv6Targets.Max(Function(i) Reliabilities(i))
If Host = "api.modrinth.com" Then IPv6Reliability -= 0.1 '让 Modrinth 优先使用 IPv4 地址（#6887）
If ModeDebug Then Log($"[Net] DNS IPv4/IPv6 选择（{Host}），IPv4 {IPv4Reliability:0.000}，IPv6 {IPv6Reliability:0.000}")
Logger.Trace(Function() $"DNS IPv4/IPv6 选择（{Host}），IPv4 {IPv4Reliability:0.000}，IPv6 {IPv6Reliability:0.000}")
Candidates = If(IPv4Reliability >= IPv6Reliability, IPv4Targets, IPv6Targets)
End If
'选择可靠度最高的 IP
@@ -379,27 +373,6 @@ Retry:
)
End Sub
''' <summary>
''' 当 HTTP 状态码不指示成功时引发的异常。
''' 附带额外属性，可用于获取远程服务器给予的回复以及 HTTP 状态码。
''' </summary>
Public Class ResponsedWebException
Inherits WebException
''' <summary>
''' HTTP 状态码。
''' </summary>
Public StatusCode As HttpStatusCode
''' <summary>
''' 远程服务器给予的回复。
''' </summary>
Public Overloads Property Response As String
Public Sub New(Message As String, StatusCode As HttpStatusCode, Response As String)
MyBase.New(Message)
Me.StatusCode = StatusCode
Me.Response = Response
End Sub
End Class
#End Region
#Region "多线程下载引擎"
@@ -413,7 +386,7 @@ Retry:
''' </summary>
Public ReadOnly Property NetTaskThreadLimit As Integer
Get
Return Settings.Get("ToolDownloadThread") + 1
Return Settings.Get(Of Integer)("ToolDownloadThread") + 1
End Get
End Property
''' <summary>
@@ -426,7 +399,7 @@ Retry:
Public ReadOnly Property NetTaskSpeedLimitHigh As Long
Get
If _NetTaskSpeedLimitHigh Is Nothing Then
Dim Setting As Integer = Settings.Get("ToolDownloadSpeed")
Dim Setting As Integer = Settings.Get(Of Integer)("ToolDownloadSpeed")
If Setting <= 14 Then
_NetTaskSpeedLimitHigh = (Setting + 1) * 0.1 * 1024 * 1024L
ElseIf Setting <= 31 Then
@@ -822,7 +795,7 @@ Retry:
Private _Speed As Long = 0
''' <summary>
''' 该文件是否由本地文件直接拷贝完成。
''' 该文件是否由本地文件直接复制完成。
''' </summary>
Public IsCopy As Boolean = False
''' <summary>
@@ -901,7 +874,7 @@ Retry:
Me.LocalPath = LocalPath
Me.Check = Checker
Me.SimulateBrowserHeaders = SimulateBrowserHeaders
Me.LocalName = GetFileNameFromPath(LocalPath)
Me.LocalName = PathUtils.GetLastPart(LocalPath)
End Sub
''' <summary>
@@ -1003,7 +976,7 @@ StartThread:
''' 每个下载线程执行的代码。
''' </summary>
Private Sub Thread(Th As NetThread)
If ModeDebug OrElse Th.DownloadStart = 0 Then Log($"[Download] {LocalName}：开始，起始点 {Th.DownloadStart}，{Th.Source.Url}")
Logger.Log($"{LocalName}：开始，起始点 {Th.DownloadStart}，{Th.Source.Url}", If(Th.DownloadStart = 0, LogLevel.Info, LogLevel.Trace))
Dim ResultStream As Stream = Nothing, HttpRequest As HttpRequestMessage = Nothing,
Response As HttpResponseMessage = Nothing, ResponseStream As Stream = Nothing,
CancelToken As CancellationTokenSource = Nothing, HostIp As String = Nothing
@@ -1021,22 +994,24 @@ StartThread:
If Not Th.IsFirstThread Then HttpRequest.Headers.Range = New Headers.RangeHeaderValue(Th.DownloadStart, Nothing)
Dim ContentLength As Long = 0
Response = ThreadClient.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout)
If Not Response.IsSuccessStatusCode Then Throw New Exception($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Th.Source.Url}") '状态码检查
If Not Response.IsSuccessStatusCode Then '状态码检查
Throw New HttpRequestCodeException($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Th.Source.Url}", Response.StatusCode, Nothing)
End If
If State = NetState.Interrupted Then GoTo SourceBreak '快速中断
If ModeDebug AndAlso Response.RequestMessage.RequestUri.ToString <> Th.Source.Url Then Log($"[Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri}")
If Response.RequestMessage.RequestUri.ToString <> Th.Source.Url Then Logger.Trace(Function() $"{LocalName}：重定向至 {Response.RequestMessage.RequestUri}")
'文件大小校验
ContentLength = Response.Content.Headers.ContentLength.GetValueOrDefault(-1)
If ContentLength < 0 Then
If FileSize > 1 Then
If Th.DownloadStart = 0 Then
Log($"[Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理")
Logger.Info($"{LocalName}：文件大小未知，但已从其他下载源获取，不作处理")
Else
Log($"[Download] {LocalName}：ContentLength 返回了 {ContentLength}，无法确定是否支持分段下载，视作不支持")
Logger.Info($"{LocalName}：ContentLength 返回了 {ContentLength}，无法确定是否支持分段下载，视作不支持")
GoTo NotSupportRange
End If
Else
FileSize = -1 : IsUnknownSize = True
Log($"[Download] {LocalName}：文件大小未知")
Logger.Info($"{LocalName}：文件大小未知")
End If
ElseIf Th.IsFirstThread Then
If Check IsNot Nothing Then
@@ -1048,7 +1023,7 @@ StartThread:
End If
End If
FileSize = ContentLength : IsUnknownSize = False
Log($"[Download] {LocalName}：文件大小 {ContentLength}（{FormatFileSize(ContentLength)}）")
Logger.Info($"{LocalName}：文件大小 {ContentLength}（{FormatFileSize(ContentLength)}）")
'若文件大小大于 50 M，进行剩余磁盘空间校验
If ContentLength > 50 * 1024 * 1024 Then
For Each Drive As DriveInfo In DriveInfo.GetDrives
@@ -1084,17 +1059,16 @@ NotSupportRange:
ResultStream = Cache
Else
Th.Temp = $"{PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp"
DirectoryUtils.Create(Th.Temp, isFilePath:=True)
ResultStream = New FileStream(Th.Temp, FileMode.Create, FileAccess.Write, FileShare.Read)
ResultStream = FileUtils.CreateAsStream(Th.Temp)
End If
'开始下载
CancelToken.Dispose() : CancelToken = New CancellationTokenSource() '重置超时，不再让 CancellationToken 在固定时间后触发（#8488）
ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult()
If Settings.Get("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000))
If Settings.Get(Of Boolean)("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000))
Dim ResponseBytes As Byte() = New Byte(16384) {}
HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout)
While (IsUnknownSize OrElse Th.DownloadUndone > 0) AndAlso '判断是否下载完成
HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState.Merging AndAlso (Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th)
HttpDataCount > 0 AndAlso Not IsProgramEnding AndAlso State < NetState.Merging AndAlso (Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th)
'限速
While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0
Threading.Thread.Sleep(16)
@@ -1140,19 +1114,22 @@ SourceBreak:
If State = NetState.Interrupted OrElse (Th.Source.IsFailed AndAlso Th.Source.SingleThread <> Th) OrElse (Th.DownloadUndone > 0 AndAlso Not IsUnknownSize) Then
'被外部中断
Th.State = NetState.Interrupted
Log($"[Download] {LocalName}：中断")
Logger.Info($"{LocalName}：中断")
ElseIf HttpDataCount = 0 AndAlso Th.DownloadUndone > 0 AndAlso Not IsUnknownSize Then
'服务器无返回数据
Throw New Exception($"返回的 ContentLength 过多：ContentLength 为 {ContentLength}，但获取到的总数据量仅为 {Th.DownloadDone}（全文件总数据量 {DownloadDone}）")
Else
'本线程完成
Th.State = NetState.Finished
If ModeDebug Then Log($"[Download] {LocalName}：完成，已下载 {Th.DownloadDone}（{Th.DownloadStart}~{Th.DownloadEnd}）")
Logger.Trace(Function() $"{LocalName}：完成，已下载 {Th.DownloadDone}（{Th.DownloadStart}~{Th.DownloadEnd}）")
RecordIPReliability(HostIp, 0.5)
End If
Catch ex As Exception
Log($"[Download] {LocalName}：出错，{If(TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException,
$"已超时（{Timeout}ms）", ex.GetDetail())}，IP：{HostIp}")
If ex.IsBadNetwork OrElse TypeOf ex Is TaskCanceledException Then
Logger.Info(New TimeoutException($"{LocalName}：超时（{Timeout}ms），{ex.Message}，IP：{If(String.IsNullOrEmpty(HostIp), "自动", "")}"))
Else
Logger.Info(ex, $"{LocalName}：出错，IP：{HostIp}")
End If
RecordIPReliability(HostIp, -0.7)
SourceFail(Th, ex, False)
Finally
@@ -1194,9 +1171,8 @@ SourceBreak:
End SyncLock
'……后续处理
If IsThisFail Then
Log($"[Download] {LocalName}：下载源被禁用（{Th.Source.Id}，Range 问题：{IsRangeNotSupported}）：{Th.Source.Url}")
Log(ex, $"{If(SourcesOnce.FirstOrDefault?.SingleThread Is Nothing, "", "单线程")}下载源 {Th.Source.Id} 已被禁用",
If(IsRangeNotSupported OrElse ex.Message.Contains("(404)"), NotifyLevel.DevelopOnly, NotifyLevel.DebugModeOnly))
Logger.Info($"{LocalName}：下载源被禁用（{Th.Source.Id}，Range 问题：{IsRangeNotSupported}）：{Th.Source.Url}")
Logger.Warn(ex, $"{If(SourcesOnce.FirstOrDefault?.SingleThread Is Nothing, "", "单线程")}下载源 {Th.Source.Id} 已被禁用")
SyncLock LockSource
SourcesOnce.Remove(Th.Source)
End SyncLock
@@ -1208,7 +1184,7 @@ SourceBreak:
ElseIf Not Retried Then
'合并失败或首次下载失败，未重试：将所有下载源重新标记为不允许断点续传的下载源，逐个重新尝试下载
'若所有源均不支持 Range，也会走到这里重试
If Not IsRangeNotSupported Then Log($"[Download] {LocalName}：文件下载失败，正在自动重试……", NotifyLevel.DebugModeOnly)
If Not IsRangeNotSupported Then Logger.Warn($"{LocalName}：文件下载失败，正在自动重试……")
Retried = True
SyncLock LockSource
SourcesOnce.Clear()
@@ -1229,14 +1205,14 @@ SourceBreak:
End SyncLock
Else
'失败
Log($"[Download] {LocalName}：已无可用下载源，下载失败")
Logger.Info($"{LocalName}：已无可用下载源，下载失败")
Dim ExampleEx As Exception = Nothing
SyncLock LockSource
For Each Source As NetSource In Sources
Log("[Download] 已禁用的下载源：" & Source.Url)
Logger.Info($"已禁用的下载源：{Source.Url}")
If Source.Ex IsNot Nothing Then
ExampleEx = Source.Ex
Log(Source.Ex, "下载源禁用原因", NotifyLevel.DevelopOnly)
Logger.Warn(Source.Ex, "下载源禁用原因")
End If
Next
End SyncLock
@@ -1276,26 +1252,26 @@ SourceBreak:
Try
Retry:
'创建文件夹
DirectoryUtils.Create(LocalPath, isFilePath:=True)
If File.Exists(LocalPath) Then File.Delete(LocalPath)
DirectoryUtils.Create(PathUtils.RemoveLastPart(LocalPath))
FileUtils.Delete(LocalPath)
SyncLock LockChain
'合并文件
If IsNoSplit Then
'仅有一个线程，从内存中输出
If ModeDebug Then Log($"[Download] {LocalName}：下载结束，从内存输出文件")
Logger.Trace(Function() $"{LocalName}：下载结束，从内存输出文件")
FileUtils.Write(LocalPath, Cache)
ElseIf Threads.DownloadDone = DownloadDone AndAlso Threads.Temp IsNot Nothing Then
'仅有一个文件，直接复制
If ModeDebug Then Log($"[Download] {LocalName}：下载结束，仅有一个文件，无需合并")
CopyFile(Threads.Temp, LocalPath)
Logger.Trace(Function() $"{LocalName}：下载结束，仅有一个文件，无需合并")
FileUtils.Copy(Threads.Temp, LocalPath)
Else
'有多个线程，合并
If ModeDebug Then Log($"[Download] {LocalName}：下载结束，开始合并文件")
Using MergeFile As New FileStream(LocalPath, FileMode.Create)
Logger.Trace(Function() $"{LocalName}：下载结束，开始合并文件")
Using MergeFile = FileUtils.CreateAsStream(LocalPath)
Using AddWriter As New BinaryWriter(MergeFile)
For Each Thread As NetThread In Threads
If Thread.DownloadDone = 0 OrElse Thread.Temp Is Nothing Then Continue For
Using fs As New FileStream(Thread.Temp, FileMode.Open, FileAccess.Read, FileShare.Read)
Using fs = FileUtils.ReadAsStream(Thread.Temp)
Using TempReader As New BinaryReader(fs)
AddWriter.Write(TempReader.ReadBytes(Thread.DownloadDone))
End Using
@@ -1314,16 +1290,16 @@ Retry:
End If
End If
If CheckResult IsNot Nothing Then
Log($"[Download] {LocalName} 文件校验失败，下载线程细节：")
Logger.Info($"{LocalName} 文件校验失败，下载线程细节：")
For Each T As NetThread In Threads
Log($"[Download] - {T.Uuid}#，状态 {GetStringFromEnum(T.State)}，范围 {T.DownloadStart}~{T.DownloadEnd}，已下载 {T.DownloadDone}，未下载 {T.DownloadUndone}")
Logger.Info($"- {T.Uuid}#，状态 {T.State}，范围 {T.DownloadStart}~{T.DownloadEnd}，已下载 {T.DownloadDone}，未下载 {T.DownloadUndone}")
Next
Throw New Exception(CheckResult)
End If
'后处理
If Not IsNoSplit Then
For Each Thread As NetThread In Threads
If Thread.Temp IsNot Nothing Then File.Delete(Thread.Temp)
If Thread.Temp IsNot Nothing Then FileUtils.Delete(Thread.Temp)
Next
End If
Finish()
@@ -1331,7 +1307,7 @@ Retry:
Catch ex As Exception
RetryCount += 1
If State > NetState.Merging Then Return '通常是因为在合并时被中断了
Log(ex, $"合并文件出错，第 {RetryCount} 次尝试（{LocalName}）")
Logger.Warn(ex, $"合并文件出错，第 {RetryCount} 次尝试（{LocalName}）")
'重新尝试合并
If RetryCount < 3 Then
Threading.Thread.Sleep(500 * RetryCount)
@@ -1339,9 +1315,9 @@ Retry:
End If
'失败，禁用当前下载源并重启下载
Try
If File.Exists(LocalPath) Then File.Delete(LocalPath)
FileUtils.Delete(LocalPath)
Catch exx As Exception
Log(ex, $"删除合并失败的文件出错（{LocalPath}）")
Logger.Warn(ex, $"删除合并失败的文件出错（{LocalPath}）")
End Try
SourceFail(Th, ex, True)
Finally
@@ -1356,7 +1332,7 @@ Retry:
If State >= NetState.Finished Then Return
If RaiseEx IsNot Nothing Then Ex.Add(RaiseEx)
'凉凉
Log($"[Download] {LocalName}：已失败，当前状态 {State}")
Logger.Info($"{LocalName}：已失败，当前状态 {State}")
State = NetState.Interrupted
End SyncLock
InterruptInternal()
@@ -1374,7 +1350,7 @@ Retry:
'确认中断
SyncLock LockState
If State >= NetState.Finished Then Return
Log($"[Download] {LocalName}：已中断，当前状态 {State}")
Logger.Info($"{LocalName}：已中断，当前状态 {State}")
State = NetState.Interrupted
End SyncLock
InterruptInternal()
@@ -1395,7 +1371,7 @@ Retry:
State = NetState.Finished
End SyncLock
Interlocked.Decrement(NetManager.FileRemain)
If PrintLog Then Log($"[Download] {LocalName}：已完成")
If PrintLog Then Logger.Info($"{LocalName}：已完成")
For Each Task In Tasks
Task.OnFileFinish(Me)
Next
@@ -1403,7 +1379,7 @@ Retry:
End Class
Private Class RangeNotSupportedException
Inherits WebException
Inherits HttpRequestException
Public Sub New(Message As String)
MyBase.New(Message)
End Sub
@@ -1451,7 +1427,7 @@ Retry:
Set(value As Integer)
_FailCount = value
If State = LoadState.Loading AndAlso value >= Math.Min(10000, Math.Max(FileRemain * 5.5, NetTaskThreadLimit * 5.5 + 3)) Then
Log("[Download] 由于同加载器中失败次数过多引发强制失败：连续失败了 " & value & " 次", NotifyLevel.DebugModeOnly)
Logger.Warn($"由于同加载器中失败次数过多引发强制失败：连续失败了 {value} 次")
On Error Resume Next
Dim ExList As New List(Of Exception)
For Each File In Files
@@ -1492,7 +1468,7 @@ FinishExCatch:
_Progress = NewProgress
End Sub
Public Sub New(Name As String, FileTasks As List(Of NetFile))
Public Sub New(Name As String, FileTasks As IEnumerable(Of NetFile))
Me.Name = Name
Files = New ConcurrentList(Of NetFile)(FileTasks)
End Sub
@@ -1526,7 +1502,7 @@ FinishExCatch:
File.LocalPath = File.LocalPath.Replace("/", "\")
If Not File.LocalPath.Lower.Contains(":\") Then Throw New ArgumentException("输入的本地文件地址不正确：" & File.LocalPath)
If File.LocalPath.EndsWithF("\") Then Throw New ArgumentException("请输入含文件名的完整文件路径：" & File.LocalPath)
DirectoryUtils.Create(File.LocalPath, isFilePath:=True) '创建目标文件夹
DirectoryUtils.Create(PathUtils.RemoveLastPart(File.LocalPath)) '创建目标文件夹
Next
'接入下载管理器，获取新开始下载的文件列表
Dim NewFiles = NetManager.Start(Me)
@@ -1552,7 +1528,7 @@ FinishExCatch:
Dim Folders As New List(Of String)
Folders.Add(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\") '总是添加官启文件夹，因为 HMCL 会把所有文件存在这里
Folders.AddRange(McFolderList.Select(Function(f) f.Location))
Folders = Folders.Distinct.Where(Function(f) Directory.Exists(f)).ToList
Folders = Folders.Distinct.Where(Function(f) DirectoryUtils.Exists(f)).ToList
'平均分配到多个检查线程
Dim ThreadCount As Integer = (FilesToCheck.Count \ 40).Clamp(1, 8) '每个线程至少 40 个文件，最多 8 线程
If ThreadCount = 1 Then '只有一个线程，直接执行
@@ -1575,43 +1551,27 @@ FinishExCatch:
End Sub
Private Sub CheckExistingFiles(Files As List(Of NetFile), FolderList As List(Of String))
Try
If ModeDebug Then Log($"[Download] 文件检查开始，本线程负责的文件数：{Files.Count}")
Logger.Trace(Function() $"文件检查开始，本线程负责 {Files.Count} 个文件，首个文件为 {Files.FirstOrDefault?.LocalName}")
'列出 MC 文件夹中的各个版本文件夹
Dim VersionFolders As New List(Of String)
For Each McFolder In FolderList
Dim VersionsFolder As New DirectoryInfo(McFolder & "versions\")
If VersionsFolder.Exists() Then
For Each VersionFolder In VersionsFolder.GetDirectories
VersionFolders.Add(VersionFolder.FullName & "\")
Next
End If
For Each VersionFolder In DirectoryUtils.GetDirectories(McFolder & "versions\", True)
VersionFolders.Add(PathUtils.AddSlashSuffix(VersionFolder))
Next
Next
'处理每个文件
For Each File As NetFile In Files
Dim Target As String = CheckExistingFile(FolderList, VersionFolders, File)
If ModeDebug Then Log($"[Download] 文件检查结果：{File.LocalName} → {Target}，当前状态 {File.State}")
Logger.Trace(Function() $"本地文件匹配：{File.LocalName} → {If(Target, "无匹配")}，当前状态 {File.State}")
If File.State >= NetState.WaitingToDownload Then Continue For '中断
'已找到相同文件
If Target IsNot Nothing Then
File.IsCopy = True
Dim RetryCount As Integer = 0
Retry:
Try
If Target <> File.LocalPath Then
Log($"[Download] 复制已存在的文件：{Target} → {File.LocalPath}")
CopyFile(Target, File.LocalPath)
Else
If ModeDebug Then Log($"[Download] 需要下载的文件已存在，并通过校验：{Target}")
End If
FileUtils.Copy(Target, File.LocalPath)
File.Finish(False)
Continue For
Catch ex As Exception
RetryCount += 1
Log(ex, $"复制已存在的文件失败，第 {RetryCount} 次重试（{Target} → {File.LocalPath}）")
If RetryCount < 3 Then
Thread.Sleep(2000)
GoTo Retry
End If
Catch
End Try
End If
'回退到下载
@@ -1628,7 +1588,7 @@ Retry:
'目标文件已存在
If File.Check.Check(File.LocalPath) Is Nothing Then Return File.LocalPath
'在设置中禁用了复制
If Settings.Get("SystemDebugSkipCopy") Then Return Nothing
If Settings.Get(Of Boolean)("SystemDebugSkipCopy") Then Return Nothing
'没有可用的检查规则，只能开始下载
If File.Check.Hash Is Nothing AndAlso File.Check.ActualSize < 0 Then Return Nothing
'大致判断文件类别
@@ -1646,37 +1606,35 @@ Retry:
Dim Type = TypeIndexes.MaxBy(Function(kv) kv.Item2).FolderName.TrimStart("\"c)
'根据类别进行查找
Static Sizes As New ConcurrentDictionary(Of String, Long)
Static CheckCandidate As Func(Of String, FileChecker, Boolean) =
Function(Candidate, Checker)
'快速进行大小校验
Dim Length = Sizes.GetOrAdd(Candidate, Function(c) If(FileUtils.Exists(c), FileUtils.GetInfo(c).Length, -1))
If Checker.ActualSize <> Length Then Return False
'进一步进行 Hash 校验
Return Checker.Check(Candidate) Is Nothing
End Function
Select Case Type
Case "assets\", "libraries\"
'assets/libraries：查找 MC 文件夹下的相同路径
For Each Folder In FolderList
Dim Candidate = Folder & Type & File.LocalPath.AfterFirst(Type)
If File.Check.Check(Candidate) Is Nothing Then Return Candidate
If CheckCandidate(Candidate, File.Check) Then Return Candidate
Next
Return Nothing
Case "versions\"
'版本 jar 或 json：查找 MC 文件夹下的各个版本文件夹
For Each VersionFolder In VersionFolders
For Each Candidate In Directory.GetFiles(VersionFolder,
"*." & GetFileNameFromPath(File.LocalPath).AfterLast(".").Lower, SearchOption.TopDirectoryOnly)
'快速进行大小校验
Dim Length = Sizes.GetOrAdd(Candidate, Function(c) New FileInfo(c).Length)
If File.Check.ActualSize <> Length Then Continue For
'Hash 校验
If File.Check.Check(Candidate) Is Nothing Then Return Candidate
For Each Candidate In DirectoryUtils.GetFiles(VersionFolder, True, "*." & PathUtils.GetLastPart(File.LocalPath).AfterLast(".").Lower)
If CheckCandidate(Candidate, File.Check) Then Return Candidate
Next
Next
Case Else
'社区资源
If File.Check.ActualSize < 0 OrElse File.Check.Hash Is Nothing Then Return Nothing '必须要求指定了文件大小和 Hash
For Each Folder In FolderList.Concat(VersionFolders)
Dim TargetFolder = Folder & Type
If Not Directory.Exists(TargetFolder) Then Continue For
For Each Candidate In Directory.GetFiles(TargetFolder)
'快速进行大小校验
Dim Length = Sizes.GetOrAdd(Candidate, Function(c) New FileInfo(c).Length)
If File.Check.ActualSize <> Length Then Continue For
'Hash 校验
If File.Check.Check(Candidate) Is Nothing Then Return Candidate
For Each Candidate In DirectoryUtils.GetFiles(Folder & Type, True)
If CheckCandidate(Candidate, File.Check) Then Return Candidate
Next
Next
End Select
@@ -1719,7 +1677,7 @@ Retry:
For Each File In Files
If File.State <> NetState.Interrupted Then Continue For
If File.Sources.All(Function(s) TypeOf s.Ex Is OperationCanceledException OrElse TypeOf s.Ex Is TimeoutException OrElse TypeOf s.Ex Is ThreadInterruptedException) Then Continue For
Dim Detail As String = File.Sources.Select(Function(s) $"{If(s.Ex Is Nothing, "无错误信息。", s.Ex.GetBrief())}（{s.Url}）").Join(vbCrLf)
Dim Detail As String = File.Sources.Select(Function(s) $"{If(s.Ex Is Nothing, "无错误信息。", s.Ex.GetDisplay(False))}（{s.Url}）").Join(vbCrLf)
[Error] = New Exception("文件下载失败：" & File.LocalPath & vbCrLf &
"各下载源的错误如下：" & vbCrLf & Detail, [Error])
'上报
@@ -1736,18 +1694,14 @@ Retry:
TaskFile.Interrupt(Me)
Next
'在退出同步锁后再进行日志输出
Dim ErrOutput As New List(Of String)
For Each Ex As Exception In ExList
ErrOutput.Add(Ex.GetDetail())
Next
Log("[Download] " & ErrOutput.Distinct.Join(vbCrLf))
Logger.Error(New AggregateException(ExList), "下载加载器失败", LogBehavior.None)
End Sub
Public Overrides Sub Interrupt()
SyncLock LockState
If State >= LoadState.Finished Then Return
State = LoadState.Interrupted
End SyncLock
Log("[Download] " & Name & " 已取消！")
Logger.Info($"{Name} 已取消！")
'中断所有文件
For Each TaskFile In Files
TaskFile.Interrupt(Me)
@@ -1823,7 +1777,7 @@ Retry:
If SpeedLast.Count >= 10 Then Limit = SpeedLast.Take(10).Average * 0.85 '取近 1 秒的平均速度的 85%
If Limit > NetTaskSpeedLimitLow Then
NetTaskSpeedLimitLow = Limit
Log("[Download] " & "速度下限已提升到 " & FormatFileSize(Limit))
Logger.Info($"速度下限已提升到 {FormatFileSize(Limit)}")
End If
#End Region
#Region "刷新下载任务属性"
@@ -1832,7 +1786,7 @@ Retry:
Next
#End Region
Catch ex As Exception
Log(ex, "刷新下载公开属性失败")
Logger.Warn(ex, "刷新下载公开属性失败")
End Try
End Sub
Private RefreshStatLast As Long
@@ -1889,7 +1843,7 @@ Retry:
Next
End While
Catch ex As Exception
Log(ex, $"下载管理启动线程 {Id} 出错", NotifyLevel.Critical)
Logger.Error(ex, $"下载管理启动线程 {Id} 出错", LogBehavior.AlertThenCrash)
End Try
End Sub
RunInNewThread(Sub() ThreadStarter(0), "NetManager ThreadStarter 0")
@@ -1913,7 +1867,7 @@ Retry:
End If
End While
Catch ex As Exception
Log(ex, "下载管理刷新线程出错", NotifyLevel.Critical)
Logger.Error(ex, "下载管理刷新线程出错", LogBehavior.AlertThenCrash)
End Try
End Sub, "NetManager StatRefresher")
End Sub
@@ -1929,11 +1883,11 @@ Retry:
SyncLock DownloadCacheLock '防止同时开启多个下载任务时重复清理
If Not IsDownloadCacheCleared Then
Try
Log("[Net] 开始清理下载缓存")
DeleteDirectory(PathTemp & "Download")
Log("[Net] 下载缓存已清理")
Logger.Info("开始清理下载缓存")
DirectoryUtils.Delete(PathTemp & "Download")
Logger.Info("下载缓存已清理")
Catch ex As Exception
Log(ex, "清理下载缓存失败")
Logger.Warn(ex, "清理下载缓存失败")
End Try
IsDownloadCacheCleared = True
End If
@@ -1945,12 +1899,12 @@ Retry:
Dim OngoingFile As NetFile = Nothing
If AllFiles.TryGetValue(File.LocalPath, OngoingFile) AndAlso OngoingFile.State < NetState.Finished Then
'该文件正在被另一个任务下载
If ModeDebug Then Log($"[Download] {File.LocalName}：无需开始，该文件已在下载中，目标 {File.LocalPath}")
Logger.Trace(Function() $"{File.LocalName}：无需开始，该文件已在下载中，目标 {File.LocalPath}")
File = OngoingFile '将列表中的文件替换成下载中的文件，即两个任务指向同一个文件；抛弃现在的 File 对象
Task.Files(i) = File
Else
'常规情况（该文件可能已在其他任务中下载完成，但这并不影响）
If ModeDebug Then Log($"[Download] {File.LocalName}：开始，目标 {File.LocalPath}")
Logger.Trace(Function() $"{File.LocalName}：开始，目标 {File.LocalPath}")
AllFiles(File.LocalPath) = File
NewFiles.Add(File)
Interlocked.Increment(FileRemain)
@@ -2021,38 +1975,18 @@ Retry:
Try
PingResult = (New NetworkInformation.Ping).Send(Ip)
Catch ex As Exception
If MakeLog Then Log("[Net] Ping " & Ip & " 失败：" & ex.Message)
If MakeLog Then Logger.Info($"Ping {Ip} 失败：{ex.Message}")
Return -1
End Try
If PingResult.Status = NetworkInformation.IPStatus.Success Then
If MakeLog Then Log("[Net] Ping " & Ip & " 结束：" & PingResult.RoundtripTime & "ms")
If MakeLog Then Logger.Info($"Ping {Ip} 结束：{PingResult.RoundtripTime}ms")
Return PingResult.RoundtripTime
Else
If MakeLog Then Log("[Net] Ping " & Ip & " 失败")
If MakeLog Then Logger.Info($"Ping {Ip} 失败")
Return -1
End If
End Function
''' <summary>
''' 判断某个 Exception 是否为网络问题所导致。
''' </summary>
<Extension> Public Function IsNetworkRelated(Ex As Exception) As Boolean
'提取 Message（不能用 GetDetail，因为堆栈的方法参数中就有 timeout 字样）
Dim Detail As String = ""
Dim InnerEx As Exception = Ex
Detail += InnerEx.Message
Do Until InnerEx.InnerException Is Nothing
InnerEx = InnerEx.InnerException
Detail += InnerEx.Message
Loop
'判断
If Detail.Contains("(403)") Then Return False
Return {
"(408)", "超时", "timeout", "网络请求失败", "连接尝试失败", "远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称",
"由于目标计算机积极拒绝", "基础连接已经关闭"
}.Any(Function(k) Detail.ContainsIgnoreCase(k))
End Function
''' <summary>
''' 设置是否应当在正版登录时校验 SSL 证书。
''' </summary>
@@ -2062,7 +1996,7 @@ Retry:
Dim Request As HttpWebRequest = TryCast(Sender, HttpWebRequest)
If Failure = Net.Security.SslPolicyErrors.None Then Return True '已通过验证
'基于 #3018 和 #5879，只在访问正版登录 API 时跳过证书验证
Log($"[System] 未通过 SSL 证书验证（{Failure}），提供的证书为 {Certificate?.Subject}，URL：{Request?.Address}", NotifyLevel.DebugModeOnly)
Logger.Warn($"未通过 SSL 证书验证（{Failure}），提供的证书为 {Certificate?.Subject}，URL：{Request?.Address}")
If Request Is Nothing Then
Return Not Enabled
ElseIf Request.Address.Host.Contains("xboxlive") OrElse Request.Address.Host.Contains("minecraftservices") Then
Plain Craft Launcher 2/Modules/Base/ModValidate.vb
+16 -15
View File
@@ -80,7 +80,7 @@ Public Class ValidateRegex
Me.ErrorDescription = ErrorDescription
End Sub
Public Overrides Function Validate(Str As String) As String
If Not RegexCheck(Str, Regex) Then Return ErrorDescription
If Not Str.RegexCheck(Regex) Then Return ErrorDescription
Return ""
End Function
End Class
@@ -94,7 +94,7 @@ Public Class ValidateHttp
End Sub '用于 XAML 初始化
Public Overrides Function Validate(Str As String) As String
If Str.EndsWithF("/") Then Str = Str.Substring(0, Str.Length - 1)
If Not RegexCheck(Str, "^(http[s]?)\://") Then Return "输入的网址无效！"
If Not Str.RegexCheck("^(http[s]?)\://") Then Return "输入的网址无效！"
Return ""
End Function
End Class
@@ -247,7 +247,7 @@ Public Class ValidateFolderName
Public Property Folder As String
Public Property UseMinecraftCharCheck As Boolean = True
Public Property IgnoreCase As Boolean = True
Private ReadOnly PathIgnore As IEnumerable(Of DirectoryInfo)
Private ReadOnly PathIgnore As IEnumerable(Of String)
Public Sub New()
End Sub
Public Sub New(Folder As String, Optional UseMinecraftCharCheck As Boolean = True, Optional IgnoreCase As Boolean = True)
@@ -255,7 +255,7 @@ Public Class ValidateFolderName
Me.IgnoreCase = IgnoreCase
Me.UseMinecraftCharCheck = UseMinecraftCharCheck
On Error Resume Next
PathIgnore = New DirectoryInfo(Folder).EnumerateDirectories
PathIgnore = DirectoryUtils.GetDirectories(Folder, True)
End Sub
Public Overrides Function Validate(Str As String) As String
Try
@@ -277,19 +277,19 @@ Public Class ValidateFolderName
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %！", True).Validate(Str)
If InvalidStrCheck <> "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名（#4505）
If RegexCheck(Str, ".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式！"
If Str.RegexCheck(".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式！"
'检查文件夹重名
Dim Arr As New List(Of String)
If PathIgnore IsNot Nothing Then
For Each Folder As DirectoryInfo In PathIgnore
Arr.Add(Folder.Name)
For Each FolderPath In PathIgnore
Arr.Add(PathUtils.GetLastPart(FolderPath))
Next
End If
Dim SameNameCheck = New ValidateExceptSame(Arr, "不可与现有文件夹重名！", IgnoreCase).Validate(Str)
If Not SameNameCheck = "" Then Return SameNameCheck
Return ""
Catch ex As Exception
Log(ex, "检查文件夹名出错")
Logger.Warn(ex, "检查文件夹名出错")
Return "错误：" & ex.Message
End Try
End Function
@@ -332,10 +332,10 @@ Public Class ValidateFileName
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件名不可为 %！", True).Validate(Str)
If InvalidStrCheck <> "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名（#4505）
If RegexCheck(Str, ".{2,}~\d") Then Return "文件名不能包含这一特殊格式！"
If Str.RegexCheck(".{2,}~\d") Then Return "文件名不能包含这一特殊格式！"
'检查文件重名
If ParentFolder IsNot Nothing Then
Dim DirInfo As New DirectoryInfo(ParentFolder)
Dim DirInfo = DirectoryUtils.GetInfo(ParentFolder)
If DirInfo.Exists Then
Dim SameNameCheck = New ValidateExceptSame(DirInfo.EnumerateFiles("*").Select(Function(f) f.Name),
"不可与现有文件重名！", IgnoreCase).Validate(Str)
@@ -346,7 +346,7 @@ Public Class ValidateFileName
End If
Return ""
Catch ex As Exception
Log(ex, "检查文件名出错")
Logger.Warn(ex, "检查文件名出错")
Return "错误：" & ex.Message
End Try
End Function
@@ -375,9 +375,10 @@ Public Class ValidateFolderPath
If LengthCheck <> "" Then Return LengthCheck
'检查开头
If Str.StartsWithF("\\Mac\") Then GoTo Fin
For Each Drive As DriveInfo In My.Computer.FileSystem.Drives
If Str.Upper = Drive.Name Then Return ""
If Str.StartsWithF(Drive.Name, True) Then GoTo Fin
For Each Drive In Environment.GetLogicalDrives().Where(Function(p) DirectoryUtils.Exists(p))
Dim DriveName As String = Drive.Upper.First & ":\"
If Str.Upper = DriveName Then Return ""
If Str.StartsWithF(DriveName, True) Then GoTo Fin
Next
Return "文件夹路径头存在错误！"
Fin:
@@ -399,7 +400,7 @@ Fin:
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %！").Validate(SubStr)
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
'检查 NTFS 8.3 文件名（#4505）
If RegexCheck(Str, ".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式！"
If Str.RegexCheck(".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式！"
Next
Return ""
End Function
Plain Craft Launcher 2/Modules/Base/MyBitmap.vb
+3 -3
View File
@@ -72,7 +72,7 @@ Public Class MyBitmap
End If
Else
'使用这种自己接管 FileStream 的方法加载才能解除文件占用
Using InputStream As New FileStream(FilePathOrResourceName, FileMode.Open, FileAccess.Read, FileShare.Read)
Using InputStream = FileUtils.ReadAsStream(FilePathOrResourceName)
'判断是否为 WebP 文件头
Dim Header(1) As Byte
InputStream.Read(Header, 0, 2)
@@ -97,7 +97,7 @@ Public Class MyBitmap
Throw New Exception($"加载 MyBitmap 意外失败（{FilePathOrResourceName}）", ex)
End If
Else
Log(ex, $"指定类型有误的 MyBitmap 加载（{FilePathOrResourceName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"指定类型有误的 MyBitmap 加载（{FilePathOrResourceName}）")
Exit Try
End If
End Try
@@ -162,7 +162,7 @@ Public Class MyBitmap
Public Sub Save(FilePath As String)
Dim encoder As BitmapEncoder = New PngBitmapEncoder()
encoder.Frames.Add(BitmapFrame.Create(Me))
Using fileStream As New FileStream(FilePath, FileMode.Create)
Using fileStream = FileUtils.CreateAsStream(FilePath)
encoder.Save(fileStream)
End Using
End Sub
Plain Craft Launcher 2/Modules/Base/PclLogger.vb
+54
View File
@@ -0,0 +1,54 @@
Public Class PclLogger
Inherits FileLogger
''' <inheritdoc/>
Public Overrides Function Format(Text As String, Level As LogLevel, FilePath As String, Ex As Exception) As String
Text = MyBase.Format(Text, Level, FilePath, Ex)
Text = FilterUserName(FilterAccessToken(Text, "*"c), "*"c)
Return Text
End Function
''' <inheritdoc/>
Public Overrides Sub HandleBehavior(RawMessage As String, FormattedMessage As String, Behavior As LogBehavior, Ex As Exception)
If IsProgramEnding Then Return
MyBase.HandleBehavior(RawMessage, FormattedMessage, Behavior, Ex)
Dim BriefText = If(Ex Is Nothing, RawMessage, If(RawMessage Is Nothing, "", $"{RawMessage}：") & Ex.GetDisplay(False))
BriefText = FilterUserName(FilterAccessToken(BriefText, "*"c), "*"c)
Dim DetailText = If(Ex Is Nothing, RawMessage, If(RawMessage Is Nothing, "", $"{RawMessage}：") & Ex.GetDisplay(True))
DetailText = FilterUserName(FilterAccessToken(DetailText, "*"c), "*"c)
Select Case Behavior
Case LogBehavior.None
'啥也不干
Case LogBehavior.ToastIfDebug
If BuildType = BuildTypes.Debug OrElse ModeDebug Then Hint("[调试模式] " & BriefText, HintType.Blue, False)
Case LogBehavior.Toast
Hint(BriefText, HintType.Red, False)
Case LogBehavior.Alert
MyMsgBox(DetailText, "错误", IsWarn:=True)
Case LogBehavior.AlertThenFeedback
If PageSetupSystem.IsLauncherNewest Then
If MyMsgBox(DetailText & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", "错误", "反馈", "取消", IsWarn:=True) = 1 Then Feedback(False, True)
Else
MyMsgBox(DetailText & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", "错误", IsWarn:=True)
End If
Case LogBehavior.AlertThenCrash
Static FirstTrigger As Boolean = True
If FirstTrigger Then
'首次触发
FirstTrigger = False
If PageSetupSystem.IsLauncherNewest Then
If MsgBox(DetailText & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, "错误") = MsgBoxResult.Yes Then Feedback(False, True)
Else
MsgBox(DetailText & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, "错误")
End If
Else
'多次触发，直接使程序崩溃（这通常代表着在其他线程循环触发严重异常）
Thread.Sleep(2000)
End If
FormMain.EndProgramForce(ProcessReturnValues.Exception)
End Select
'遥测
If Behavior >= LogBehavior.Toast Then Telemetry("错误日志", "Exception", DetailText)
End Sub
End Class
Plain Craft Launcher 2/Modules/Constants.vb
-78
View File
@@ -1,78 +0,0 @@
''' <summary>
''' 社区资源的类型。
''' </summary>
<Flags> Public Enum ResourceTypes
''' <summary>
''' Mod。
''' </summary>
[Mod] = 1
''' <summary>
''' 整合包。
''' </summary>
ModPack = 2
''' <summary>
''' 资源包。
''' </summary>
ResourcePack = 4
''' <summary>
''' 光影包。
''' </summary>
Shader = 8
''' <summary>
''' 数据包。
''' </summary>
DataPack = 16
''' <summary>
''' 服务端插件。
''' </summary>
Plugin = 32
''' <summary>
''' 同时包含数据包以及 Mod。
''' </summary>
ModOrDataPack = [Mod] Or DataPack
''' <summary>
''' 允许任意种类，或种类未知。
''' </summary>
Any = [Mod] Or ModPack Or ResourcePack Or Shader Or DataPack Or Plugin
End Enum
''' <summary>
''' 社区资源的来源平台。
''' </summary>
<Flags> Public Enum ResourcePlatforms
CurseForge = 1
Modrinth = 2
Any = CurseForge Or Modrinth
End Enum
''' <summary>
''' Mod 加载器的类型。
''' </summary>
Public Enum ModLoaderTypes
'https://docs.curseforge.com/rest-api/#tocS_ModLoaderType
Any = 0
Forge = 1
LiteLoader = 3
Fabric = 4
Quilt = 5
NeoForge = 6
End Enum
''' <summary>
''' 在爱发电中的赞助等级。
''' </summary>
Public Enum DonationRanks
None = 0
Rank6 = 6
Rank12 = 12
Rank23 = 23
Rank54 = 54
Rank98 = 98
End Enum
Public Module Constants
''' <summary>
''' 土豆码版本号。
''' </summary>
Public Const POTATO_VERSION As Char = "1"c
End Module
Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb
+140 -147
View File
@@ -9,7 +9,7 @@
TempFolder = RequestTaskTempFolder()
DirectoryUtils.Create(TempFolder & "Temp\")
DirectoryUtils.Create(TempFolder & "Report\")
Log("[Crash] 崩溃分析暂存文件夹：" & TempFolder)
Logger.Info($"崩溃分析暂存文件夹：{TempFolder}")
End Sub
'1：准备用于分析的 Log 文件
@@ -19,35 +19,30 @@
''' </summary>
''' <param name="LatestLog">从 PCL 捕获到的最后 200 行程序输出。</param>
Public Sub Collect(VersionPathIndie As String, Optional LatestLog As IList(Of String) = Nothing)
Log("[Crash] 步骤 1：收集日志文件")
Logger.Info("步骤 1：收集日志文件")
'简单收集可能的日志文件路径
Dim PossibleLogs As New List(Of String)
Try
Dim DirInfo As New DirectoryInfo(VersionPathIndie & "crash-reports\")
If DirInfo.Exists Then
For Each File In DirInfo.EnumerateFiles
PossibleLogs.Add(File.FullName)
Next
End If
PossibleLogs.AddRange(DirectoryUtils.GetFiles(VersionPathIndie & "crash-reports\"))
Catch ex As Exception
Log(ex, "收集 Minecraft 崩溃日志文件夹下的日志失败")
Logger.Warn(ex, "收集 Minecraft 崩溃日志文件夹下的日志失败")
End Try
Try
For Each File In New DirectoryInfo(VersionPathIndie).Parent.Parent.EnumerateFiles
For Each File In DirectoryUtils.GetInfo(VersionPathIndie).Parent.Parent.EnumerateFiles
If If(File.Extension, "") <> ".log" Then Continue For
PossibleLogs.Add(File.FullName)
PossibleLogs.Add(PathUtils.RemoveExtendedPrefix(File.FullName))
Next
Catch ex As Exception
Log(ex, "收集 Minecraft 主文件夹下的日志失败")
Logger.Warn(ex, "收集 Minecraft 主文件夹下的日志失败")
End Try
Try
For Each File In New DirectoryInfo(VersionPathIndie).EnumerateFiles
For Each File In DirectoryUtils.GetInfo(VersionPathIndie).EnumerateFiles
If If(File.Extension, "") <> ".log" Then Continue For
PossibleLogs.Add(File.FullName)
PossibleLogs.Add(PathUtils.RemoveExtendedPrefix(File.FullName))
Next
Catch ex As Exception
Log(ex, "收集 Minecraft 隔离文件夹下的日志失败")
Logger.Warn(ex, "收集 Minecraft 隔离文件夹下的日志失败")
End Try
PossibleLogs.Add(VersionPathIndie & "logs\latest.log") 'Minecraft 日志
PossibleLogs.Add(VersionPathIndie & "logs\debug.log") 'Minecraft Debug 日志
@@ -57,74 +52,75 @@
Dim RightLogs As New List(Of String)
For Each LogFile In PossibleLogs
Try
Dim Info As New FileInfo(LogFile)
Dim Info = FileUtils.GetInfo(LogFile)
If Not Info.Exists Then Continue For
Dim Time = Math.Abs((Info.LastWriteTime - Date.Now).TotalMinutes)
If Time < 3 AndAlso Info.Length > 0 Then
RightLogs.Add(LogFile)
Log("[Crash] 可能可用的日志文件：" & LogFile & "（" & Math.Round(Time, 1) & " 分钟）")
Logger.Info($"可能可用的日志文件：{LogFile}（{Math.Round(Time, 1)} 分钟）")
End If
Catch ex As Exception
Log(ex, "确认崩溃日志时间失败（" & LogFile & "）")
Logger.Warn(ex, $"确认崩溃日志时间失败（{LogFile}）")
End Try
Next
If Not RightLogs.Any() Then Log("[Crash] 未发现可能可用的日志文件")
If Not RightLogs.Any() Then Logger.Info("未发现可能可用的日志文件")
'将可能可用的日志文件导出
For Each FilePath In RightLogs
Try
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, FileUtils.ReadAsLines(FilePath)))
Catch ex As Exception
Log(ex, "读取可能的崩溃日志文件失败（" & FilePath & "）")
Logger.Warn(ex, $"读取可能的崩溃日志文件失败（{FilePath}）")
End Try
Next
If LatestLog IsNot Nothing AndAlso LatestLog.Any Then
Dim RawOutput As String = LatestLog.Join(vbCrLf)
Log("[Crash] 以下为游戏输出的最后一段内容：" & vbCrLf & RawOutput)
Logger.Info($"以下为游戏输出的最后一段内容：{vbCrLf}{RawOutput}")
FileUtils.Write(TempFolder & "RawOutput.log", RawOutput)
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TempFolder & "RawOutput.log", LatestLog.ToArray))
LatestLog.Clear()
End If
Log("[Crash] 步骤 1：收集日志文件完成，收集到 " & AnalyzeRawFiles.Count & " 个文件")
Logger.Info($"步骤 1：收集日志文件完成，收集到 {AnalyzeRawFiles.Count} 个文件")
End Sub
''' <summary>
''' 从文件路径直接导入日志文件或崩溃报告压缩包。
''' </summary>
Public Sub Import(FilePath As String)
Log("[Crash] 步骤 1：自主导入日志文件")
Logger.Info("步骤 1：自主导入日志文件")
'尝试视作压缩包解压
Try
Dim Info As New FileInfo(FilePath)
Dim Info = FileUtils.GetInfo(FilePath)
If Info.Exists AndAlso Info.Length > 0 AndAlso Not FilePath.EndsWithF(".jar", True) Then
ExtractCompressedFile(FilePath, TempFolder & "Temp\")
Log("[Crash] 已解压导入的日志文件：" & FilePath)
FileUtils.ExtractToDirectory(FilePath, TempFolder & "Temp\")
Logger.Info($"已解压导入的日志文件：{FilePath}")
GoTo Extracted
End If
Catch
End Try
'并非压缩包
CopyFile(FilePath, TempFolder & "Temp\" & GetFileNameFromPath(FilePath))
Log("[Crash] 已复制导入的日志文件：" & FilePath)
FileUtils.Copy(FilePath, TempFolder & "Temp\" & PathUtils.GetLastPart(FilePath))
Logger.Info($"已复制导入的日志文件：{FilePath}")
Extracted:
'导入其中的日志文件
For Each TargetFile As FileInfo In New DirectoryInfo(TempFolder & "Temp\").EnumerateFiles.ToList()
For Each TargetFile As FileInfo In DirectoryUtils.GetInfo(TempFolder & "Temp\").EnumerateFiles
Try
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
Dim Ext As String = TargetFile.Extension.Lower
If Ext = ".log" OrElse Ext = ".txt" Then
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(
PathUtils.RemoveExtendedPrefix(TargetFile.FullName), FileUtils.ReadAsLines(TargetFile.FullName)))
Else
File.Delete(TargetFile.FullName)
FileUtils.Delete(TargetFile.FullName)
End If
Catch ex As Exception
Log(ex, "导入单个日志文件失败")
Logger.Warn(ex, "导入单个日志文件失败")
End Try
Next
Log("[Crash] 步骤 1：自主导入日志文件，收集到 " & AnalyzeRawFiles.Count & " 个文件")
Logger.Info($"步骤 1：自主导入日志文件，收集到 {AnalyzeRawFiles.Count} 个文件")
End Sub
'2：确认实际用于分析的 Log 文本
@@ -141,25 +137,25 @@ Extracted:
''' 返回是否有足够信息可用于分析。
''' </summary>
Public Function Prepare() As Boolean
Log("[Crash] 步骤 2：准备日志文本")
Logger.Info("步骤 2：准备日志文本")
'对日志文件进行分类
DirectFile = Nothing
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).Lower
Dim MatchName As String = PathUtils.GetLastPart(LogFile.Key).Lower
Dim TargetType As AnalyzeFileType
If MatchName.StartsWithF("hs_err") Then
TargetType = AnalyzeFileType.HsErr
DirectFile = LogFile
If DirectFile Is Nothing Then DirectFile = LogFile
ElseIf MatchName.StartsWithF("crash-") Then
TargetType = AnalyzeFileType.CrashReport
DirectFile = LogFile
If DirectFile Is Nothing Then DirectFile = LogFile
ElseIf MatchName = "latest.log" OrElse MatchName = "latest log.txt" OrElse
MatchName = "debug.log" OrElse MatchName = "debug log.txt" OrElse
MatchName = "游戏崩溃前的输出.txt" OrElse MatchName = "rawoutput.log" Then
TargetType = AnalyzeFileType.MinecraftLog
If DirectFile Is Nothing Then DirectFile = LogFile
DirectFile = LogFile
ElseIf MatchName = "启动器日志.txt" OrElse MatchName = "PCL2 启动器日志.txt" OrElse MatchName = "PCL 启动器日志.txt" OrElse MatchName = "log1.txt" Then
If LogFile.Value.Any(Function(s) s.Contains("以下为游戏输出的最后一段内容")) Then
TargetType = AnalyzeFileType.MinecraftLog
@@ -172,20 +168,20 @@ Extracted:
ElseIf MatchName.EndsWithF(".txt", True) Then
TargetType = AnalyzeFileType.ExtraReportFile
Else
Log("[Crash] " & MatchName & " 分类为 Ignore")
Logger.Info($"{MatchName} 分类为 Ignore")
Continue For
End If
If LogFile.Value.Any Then
AllFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
Log("[Crash] " & MatchName & " 分类为 " & GetStringFromEnum(TargetType))
Logger.Info($"{MatchName} 分类为 {TargetType}")
Else
Log("[Crash] " & MatchName & " 由于内容为空跳过")
Logger.Info($"{MatchName} 由于内容为空跳过")
End If
Next
'若只有额外日志，则将它们视作 Minecraft 日志
If AllFiles.Any() AndAlso AllFiles.All(Function(p) p.Key = AnalyzeFileType.ExtraLogFile) Then
Log("[Crash] 由于仅发现了额外日志，将它们视作 Minecraft 日志进行分析")
Logger.Info("由于仅发现了额外日志，将它们视作 Minecraft 日志进行分析")
AllFiles = AllFiles.Select(Function(p) New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(AnalyzeFileType.MinecraftLog, p.Value)).ToList
End If
@@ -205,9 +201,9 @@ Extracted:
Dim DatedFiles As New SortedList(Of Date, KeyValuePair(Of String, String()))()
For Each File In SelectedFiles
Try
DatedFiles.Add(New FileInfo(File.Key).LastWriteTime, File)
DatedFiles.Add(FileUtils.GetInfo(File.Key).LastWriteTime, File)
Catch ex As Exception
Log(ex, "获取日志文件修改时间失败")
Logger.Warn(ex, "获取日志文件修改时间失败")
DatedFiles.Add(New Date(1900, 1, 1), File)
End Try
Next
@@ -216,12 +212,12 @@ Extracted:
OutputFiles.Add(NewestFile.Key)
If SelectType = AnalyzeFileType.HsErr Then
LogHs = GetHeadTailLines(NewestFile.Value, 200, 100)
Log("[Crash] 输出报告：" & NewestFile.Key & "，作为虚拟机错误信息")
Log("[Crash] 导入分析：" & NewestFile.Key & "，作为虚拟机错误信息")
Logger.Info($"输出报告：{NewestFile.Key}，作为虚拟机错误信息")
Logger.Info($"导入分析：{NewestFile.Key}，作为虚拟机错误信息")
Else
LogCrash = GetHeadTailLines(NewestFile.Value, 300, 700)
Log("[Crash] 输出报告：" & NewestFile.Key & "，作为 Minecraft 崩溃报告")
Log("[Crash] 导入分析：" & NewestFile.Key & "，作为 Minecraft 崩溃报告")
Logger.Info($"输出报告：{NewestFile.Key}，作为 Minecraft 崩溃报告")
Logger.Info($"导入分析：{NewestFile.Key}，作为 Minecraft 崩溃报告")
End If
Case AnalyzeFileType.MinecraftLog
LogMc = ""
@@ -229,9 +225,9 @@ Extracted:
'创建文件名词典
Dim FileNameDict As New Dictionary(Of String, KeyValuePair(Of String, String()))
For Each SelectedFile In SelectedFiles
FileNameDict(GetFileNameFromPath(SelectedFile.Key).Lower) = SelectedFile
FileNameDict(PathUtils.GetLastPart(SelectedFile.Key).Lower) = SelectedFile
OutputFiles.Add(SelectedFile.Key)
Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为 Minecraft 或启动器日志")
Logger.Info($"输出报告：{SelectedFile.Key}，作为 Minecraft 或启动器日志")
Next
'选择一份最佳的来自启动器的游戏日志
For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt", "PCL 启动器日志.txt"}
@@ -244,13 +240,13 @@ Extracted:
LogMc += Line & vbLf
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
HasLauncherMark = True
Log("[Crash] 找到 PCL 输出的游戏实时日志头")
Logger.Info("找到 PCL 输出的游戏实时日志头")
End If
Next
'导入后 500 行
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
Logger.Info($"导入分析：{CurrentLog.Key}，作为启动器日志")
Exit For
Next
'选择一份最佳的 Minecraft Log
@@ -258,7 +254,7 @@ Extracted:
If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName)
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
Logger.Info($"导入分析：{CurrentLog.Key}，作为 Minecraft 日志")
Exit For
Next
'查找 Debug Log
@@ -266,7 +262,7 @@ Extracted:
If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName)
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft Debug 日志")
Logger.Info($"导入分析：{CurrentLog.Key}，作为 Minecraft Debug 日志")
Exit For
Next
'兜底
@@ -276,7 +272,7 @@ Extracted:
ElseIf FileNameDict.Any() Then '如果都没有找到，则使用第一个文件
Dim CurrentLog = FileNameDict.First.Value
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为兜底日志")
Logger.Info($"导入分析：{CurrentLog.Key}，作为兜底日志")
Else
LogMc = Nothing
Throw New Exception("无法找到匹配的 Minecraft Log")
@@ -287,21 +283,22 @@ Extracted:
'全部丢过去
For Each SelectedFile In SelectedFiles
OutputFiles.Add(SelectedFile.Key)
Log("[Crash] 输出报告：" & SelectedFile.Key & "，不用作分析")
Logger.Info($"输出报告：{SelectedFile.Key}，不用作分析")
Next
End Select
Catch ex As Exception
Log(ex, "分类处理日志文件时出错")
Logger.Warn(ex, "分类处理日志文件时出错")
End Try
Next
'结束
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("、") & "用作分析")
Dim Result = LogMc IsNot Nothing OrElse LogHs IsNot Nothing OrElse LogCrash IsNot Nothing
If Result Then
Logger.Info($"{("[Crash] 步骤 2：准备日志文本完成，找到" & If(LogMc Is Nothing, "", "游戏日志、") & If(LogMcDebug Is Nothing, "", "游戏 Debug 日志、") & If(LogHs Is Nothing, "", "虚拟机日志、") & If(LogCrash Is Nothing, "", "崩溃日志、")).TrimEnd("、")}用作分析")
Else
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
Logger.Info("步骤 2：准备日志文本完成，没有任何可供分析的日志")
End If
Return Result
End Function
''' <summary>
''' 输出字符串的前后某些行，并统一行尾为 vbLf (正则 \n)、删除空行和重复行。
@@ -392,7 +389,7 @@ Extracted:
''' 根据 AnalyzeLogs 与可能的版本信息分析崩溃原因。
''' </summary>
Public Sub Analyze()
Log("[Crash] 步骤 3：分析崩溃原因")
Logger.Info("步骤 3：分析崩溃原因")
LogAll = If(LogMc, If(LogMcDebug, "")) & If(LogHs, "") & If(LogCrash, "")
'1. 精准日志匹配，中/高优先级
@@ -406,21 +403,21 @@ Extracted:
Dim Keywords As New List(Of String)
'崩溃日志
If LogCrash IsNot Nothing Then
Log("[Crash] 开始进行崩溃日志堆栈分析")
Logger.Info("开始进行崩溃日志堆栈分析")
Keywords.AddRange(AnalyzeStackKeyword(LogCrash.BeforeFirst("System Details")))
End If
'Minecraft 日志
If LogMc IsNot Nothing Then
Dim Fatals As List(Of String) = RegexSearch(LogMc, "/FATAL] .+?(?=[\n]+\[)")
Dim Fatals As List(Of String) = LogMc.RegexSearch("/FATAL] .+?(?=[\n]+\[)").ToList
If LogMc.Contains("Unreported exception thrown!") Then Fatals.Add(LogMc.Between("Unreported exception thrown!", "at oolloo.jlw.Wrapper"))
Log("[Crash] 开始进行 Minecraft 日志堆栈分析，发现 " & Fatals.Count & " 个报错项")
Logger.Info($"开始进行 Minecraft 日志堆栈分析，发现 {Fatals.Count} 个报错项")
For Each Fatal In Fatals
Keywords.AddRange(AnalyzeStackKeyword(Fatal))
Next
End If
'虚拟机日志
If LogHs IsNot Nothing Then
Log("[Crash] 开始进行虚拟机堆栈分析")
Logger.Info("开始进行虚拟机堆栈分析")
Dim StackLogs As String = LogHs.Between("T H R E A D", "Registers:")
Keywords.AddRange(AnalyzeStackKeyword(StackLogs))
End If
@@ -435,7 +432,7 @@ Extracted:
GoTo Done
End If
Else
Log("[Crash] 可能并未安装 Mod，不进行堆栈分析")
Logger.Info("可能并未安装 Mod，不进行堆栈分析")
End If
'3. 精准日志匹配，低优先级
@@ -444,27 +441,27 @@ Extracted:
'输出到日志
Done:
If Not CrashReasons.Any() Then
Log("[Crash] 步骤 3：分析崩溃原因完成，未找到可能的原因")
Logger.Info("步骤 3：分析崩溃原因完成，未找到可能的原因")
Else
Log("[Crash] 步骤 3：分析崩溃原因完成，找到 " & CrashReasons.Count & " 条可能的原因")
Logger.Info($"步骤 3：分析崩溃原因完成，找到 {CrashReasons.Count} 条可能的原因")
For Each Reason In CrashReasons
Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Any, "（" & Reason.Value.Join("；"c) & "）", ""))
Logger.Info($"- {Reason.Key}{If(Reason.Value.Any, "（" & Reason.Value.Join("；"c) & "）", "")}")
Next
End If
End Sub
''' <summary>
''' 增加一个可能的崩溃原因。
''' </summary>
Private Sub AppendReason(Reason As CrashReason, Optional Additional As ICollection(Of String) = Nothing)
Private Sub AppendReason(Reason As CrashReason, Optional Additional As IEnumerable(Of String) = Nothing)
If CrashReasons.ContainsKey(Reason) Then
If Additional IsNot Nothing Then
CrashReasons(Reason).AddRange(Additional)
CrashReasons(Reason) = CrashReasons(Reason).Distinct.ToList
End If
Else
CrashReasons.Add(Reason, New List(Of String)(If(Additional, {})))
CrashReasons.Add(Reason, New List(Of String)(If(Additional, {}).ToList))
End If
Log("[Crash] 可能的崩溃原因：" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Any, "（" & Additional.Join("；"c) & "）", ""))
Logger.Info($"可能的崩溃原因：{Reason}{If(Additional IsNot Nothing AndAlso Additional.Any, "（" & Additional.Join("；"c) & "）", "")}")
End Sub
Private Sub AppendReason(Reason As CrashReason, Additional As String)
AppendReason(Reason, If(String.IsNullOrEmpty(Additional), Nothing, New List(Of String) From {Additional}))
@@ -485,7 +482,7 @@ Done:
'崩溃报告分析，高优先级
If LogCrash IsNot Nothing Then
If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高)
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(LogCrash.RegexSeek("(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(LogCrash.RegexSeek("(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071
End If
'游戏日志分析
@@ -495,7 +492,6 @@ Done:
If LogMc.Contains("The driver does not appear to support OpenGL") Then AppendReason(CrashReason.显卡不支持OpenGL)
If LogMc.Contains("java.lang.ClassCastException: java.base/jdk") Then AppendReason(CrashReason.使用JDK)
If LogMc.Contains("java.lang.ClassCastException: class jdk.") Then AppendReason(CrashReason.使用JDK)
If LogMc.Contains("TRANSFORMER/net.optifine/net.optifine.reflect.Reflector.<clinit>(Reflector.java") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
If LogMc.Contains("java.lang.NoSuchMethodError: 'void net.minecraft.client.renderer.texture.SpriteContents.<init>") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
If LogMc.Contains("java.lang.NoSuchMethodError: 'java.lang.String com.mojang.blaze3d.systems.RenderSystem.getBackendDescription") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
If LogMc.Contains("java.lang.NoSuchMethodError: 'void net.minecraft.client.renderer.block.model.BakedQuad.<init>") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
@@ -515,7 +511,7 @@ Done:
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") 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("signer information does not match signer information of other classes in the same package") Then AppendReason(CrashReason.文件或内容校验失败, If(LogMc.RegexSeek("(?<=class "")[^']+(?=""'s signer information)"), "").TrimEnd(vbCrLf))
If LogMc.Contains("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足)
If LogMc.Contains("java.lang.NoSuchMethodError: net.minecraft.world.server.ChunkManager$ProxyTicketManager.shouldForceTicks(J)Z") AndAlso LogMc.Contains("OptiFine") Then AppendReason(CrashReason.OptiFine导致无法加载世界)
If LogMc.Contains("Unsupported class file major version") Then AppendReason(CrashReason.Java版本不兼容)
@@ -536,18 +532,18 @@ Done:
End If
End If
'确定的 Mod 导致崩溃
If LogMc.Contains("Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(RegexSeek(LogMc, "(?<=Caught exception from )[^\n]+?")?.TrimEnd((vbCrLf & " ").ToCharArray)))
If LogMc.Contains("Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(LogMc.RegexSeek("(?<=Caught exception from )[^\n]+?")?.TrimEnd((vbCrLf & " ").ToCharArray)))
'Mod 重复 / 前置问题
If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList)
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, LogMc.RegexSearch("(?<=\n\t[\w]+ : [A-Z]:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, If(LogMc.RegexSeek("Found a duplicate mod[^\n]+"), "").RegexSearch("[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, LogMc.RegexSearch("(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList)
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, If(LogMc.RegexSeek("ModResolutionException: Duplicate[^\n]+"), "").RegexSearch("[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Incompatible mods found!") Then '#5006, #5115
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息：").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray))
AppendReason(CrashReason.Mod互不兼容, If(LogMc.RegexSeek("(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息：").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray))
End If
If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then
AppendReason(CrashReason.Mod缺少前置或MC版本错误,
RegexSearch(LogMc, "(?<=Missing or unsupported mandatory dependencies:)([\n\r]+\t(.*))+", RegularExpressions.RegexOptions.IgnoreCase).
LogMc.RegexSearch("(?<=Missing or unsupported mandatory dependencies:)([\n\r]+\t(.*))+", RegularExpressions.RegexOptions.IgnoreCase).
Select(Function(s) s.Trim((vbCrLf & vbTab & " ").ToCharArray)).Distinct().ToList())
End If
End If
@@ -569,19 +565,19 @@ Done:
If LogCrash.Contains("java.lang.OutOfMemoryError") Then AppendReason(CrashReason.内存不足)
If LogCrash.Contains("Pixel format not accelerated") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
If LogCrash.Contains("Manually triggered debug crash") Then AppendReason(CrashReason.玩家手动触发调试崩溃)
If LogCrash.Contains("has mods that were not found") AndAlso RegexCheck(LogCrash, "The Mod File [^\n]+optifine\\OptiFine[^\n]+ has mods that were not found") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
If LogCrash.Contains("has mods that were not found") AndAlso LogCrash.RegexCheck("The Mod File [^\n]+optifine\\OptiFine[^\n]+ has mods that were not found") Then AppendReason(CrashReason.OptiFine与Forge不兼容)
'Mod 导致的崩溃
If LogCrash.Contains("-- MOD ") Then
Dim LogCrashMod As String = LogCrash.Between("-- MOD ", "Failure message:")
If LogCrashMod.ContainsIgnoreCase(".jar") Then
AppendReason(CrashReason.确定Mod导致游戏崩溃, If(RegexSeek(LogCrashMod, "(?<=Mod File: ).+"), "").TrimEnd((vbCrLf & " ").ToCharArray))
AppendReason(CrashReason.确定Mod导致游戏崩溃, If(LogCrashMod.RegexSeek("(?<=Mod File: ).+"), "").TrimEnd((vbCrLf & " ").ToCharArray))
Else
AppendReason(CrashReason.Mod加载器报错, If(RegexSeek(LogCrash, "(?<=Failure message: )[\w\W]+?(?=\tMod)"), "").Replace(vbTab, " ").TrimEnd((vbCrLf & " ").ToCharArray))
AppendReason(CrashReason.Mod加载器报错, If(LogCrash.RegexSeek("(?<=Failure message: )[\w\W]+?(?=\tMod)"), "").Replace(vbTab, " ").TrimEnd((vbCrLf & " ").ToCharArray))
End If
End If
If LogCrash.Contains("Multiple entries with same key: ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Multiple entries with same key: )[^=]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("LoaderExceptionModCrash: Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=LoaderExceptionModCrash: Caught exception from )[^\n]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)})
If LogCrash.Contains("Multiple entries with same key: ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(LogCrash.RegexSeek("(?<=Multiple entries with same key: )[^=]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("LoaderExceptionModCrash: Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(LogCrash.RegexSeek("(?<=LoaderExceptionModCrash: Caught exception from )[^\n]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(LogCrash.RegexSeek("(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(LogCrash.RegexSeek("(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)})
End If
End Sub
@@ -600,14 +596,14 @@ Done:
LogText.Contains("mixin.injection.throwables.") OrElse LogText.Contains(".json] FAILED during )")
If Not IsMixin Then Return False
'Mod 名称匹配
Dim ModName As String = RegexSeek(LogText, "(?<=from mod )[^.\/ ]+(?=\] from)")
If ModName Is Nothing Then ModName = RegexSeek(LogText, "(?<=for mod )[^.\/ ]+(?= failed)")
Dim ModName As String = LogText.RegexSeek("(?<=from mod )[^.\/ ]+(?=\] from)")
If ModName Is Nothing Then ModName = LogText.RegexSeek("(?<=for mod )[^.\/ ]+(?= failed)")
If ModName IsNot Nothing Then
AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(ModName.TrimEnd((vbCrLf & " ").ToCharArray)))
Return True
End If
'JSON 名称匹配
For Each JsonName In RegexSearch(LogText, "(?<=^[^\t]+[ \[{(])[^ \[{(]+\.[^ ]+(?=\.json)", RegularExpressions.RegexOptions.Multiline)
For Each JsonName In LogText.RegexSearch("(?<=^[^\t]+[ \[{(])[^ \[{(]+\.[^ ]+(?=\.json)", RegularExpressions.RegexOptions.Multiline)
AppendReason(CrashReason.ModMixin失败,
TryAnalyzeModName(JsonName.Replace("mixins", "mixin").Replace(".mixin", "").Replace("mixin.", "")))
Return True
@@ -622,12 +618,12 @@ Done:
'Mixin 崩溃
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报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf))
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+").Join(vbLf))
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, LogMc.RegexSeek("(?<=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报错并给出解决方案, If(LogMc.RegexSeek("(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), "").RegexSearch("(?<=\s+)[^\n]+").Join(vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, If(LogMc.RegexSeek("(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), "").RegexSearch("(?<=\s+)[^\n]+").Join(vbLf))
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, If(LogMc.RegexSeek("(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), "").RegexSearch("(?<=\s+)[^\n]+").Join(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)))
AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(LogMc.RegexSeek("(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
End If
End If
@@ -639,7 +635,7 @@ Done:
If LogCrash.Contains("Suspected Mod") Then
Dim SuspectsRaw As String = LogCrash.Between("Suspected Mod", "Stacktrace")
If Not SuspectsRaw.StartsWithF("s: None") Then 'Suspected Mods: None
Dim Suspects = RegexSearch(SuspectsRaw, "(?<=\n\t[^(\t]+\()[^)\n]+")
Dim Suspects = SuspectsRaw.RegexSearch("(?<=\n\t[^(\t]+\()[^)\n]+")
If Suspects.Any Then AppendReason(CrashReason.怀疑Mod导致游戏崩溃, TryAnalyzeModName(Suspects))
End If
End If
@@ -660,14 +656,14 @@ Done:
'Mod 解析错误（常见于 Fabric 前置校验失败）
If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错)
'Mixin 失败可以导致大量 Mod 实例创建失败，因此需要放到低优先级中
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(LogMc.RegexSeek("(?<=Failed to create mod instance. ModID: )[^,]+"), If(LogMc.RegexSeek("(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
'注意：Fabric 的 Warnings were found! 不一定是崩溃原因，它可能是单纯的警报
End If
'崩溃报告分析
If LogCrash IsNot Nothing Then
If LogCrash.Contains(vbTab & "Block location: World: ") Then AppendReason(CrashReason.特定方块导致崩溃, If(RegexSeek(LogCrash, "(?<=\tBlock: Block\{)[^\}]+"), "") & " " & If(RegexSeek(LogCrash, "(?<=\tBlock location: World: )\([^\)]+\)"), ""))
If LogCrash.Contains(vbTab & "Entity's Exact location: ") Then AppendReason(CrashReason.特定实体导致崩溃, If(RegexSeek(LogCrash, "(?<=\tEntity Type: )[^\n]+(?= \()"), "") & " (" & If(RegexSeek(LogCrash, "(?<=\tEntity's Exact location: )[^\n]+"), "").TrimEnd(vbCrLf.ToCharArray) & ")")
If LogCrash.Contains(vbTab & "Block location: World: ") Then AppendReason(CrashReason.特定方块导致崩溃, If(LogCrash.RegexSeek("(?<=\tBlock: Block\{)[^\}]+"), "") & " " & If(LogCrash.RegexSeek("(?<=\tBlock location: World: )\([^\)]+\)"), ""))
If LogCrash.Contains(vbTab & "Entity's Exact location: ") Then AppendReason(CrashReason.特定实体导致崩溃, If(LogCrash.RegexSeek("(?<=\tEntity Type: )[^\n]+(?= \()"), "") & " (" & If(LogCrash.RegexSeek("(?<=\tEntity's Exact location: )[^\n]+"), "").TrimEnd(vbCrLf.ToCharArray) & ")")
End If
End Sub
@@ -679,8 +675,8 @@ Done:
'进行正则匹配
Dim StackSearchResults As New List(Of String)
StackSearchResults.AddRange(RegexSearch(ErrorStack, "(?<=\n[^{]+)[a-zA-Z_]+\w+\.[a-zA-Z_]+[\w\.]+(?=\.[\w\.$]+\.)"))
StackSearchResults.AddRange(RegexSearch(ErrorStack, "(?<=at [^(]+?\.\w+\$\w+\$)[\w\$]+?(?=\$\w+\()").Select(Function(s) s.Replace("$", "."))) 'Mixin 堆栈：xxx.xxx.xxxx$xxxx$xxx
StackSearchResults.AddRange(ErrorStack.RegexSearch("(?<=\n[^{]+)[a-zA-Z_]+\w+\.[a-zA-Z_]+[\w\.]+(?=\.[\w\.$]+\.)"))
StackSearchResults.AddRange(ErrorStack.RegexSearch("(?<=at [^(]+?\.\w+\$\w+\$)[\w\$]+?(?=\$\w+\()").Select(Function(s) s.Replace("$", "."))) 'Mixin 堆栈：xxx.xxx.xxxx$xxxx$xxx
StackSearchResults = StackSearchResults.Distinct.ToList
'检查堆栈开头
@@ -698,10 +694,10 @@ Done:
NextStack:
Next
PossibleStacks = PossibleStacks.Distinct.ToList
Log("[Crash] 找到 " & PossibleStacks.Count & " 条可能的堆栈信息")
Logger.Info($"找到 {PossibleStacks.Count} 条可能的堆栈信息")
If Not PossibleStacks.Any() Then Return New List(Of String)
For Each Stack As String In PossibleStacks
Log("[Crash] - " & Stack)
Logger.Info($"- {Stack}")
Next
'检查堆栈关键词
@@ -724,10 +720,10 @@ NextStack:
Next
Next
PossibleWords = PossibleWords.Distinct.ToList
Log("[Crash] 从堆栈信息中找到 " & PossibleWords.Count & " 个可能的 Mod ID 关键词")
If PossibleWords.Any Then Log("[Crash] - " & PossibleWords.Join(", "))
Logger.Info($"从堆栈信息中找到 {PossibleWords.Count} 个可能的 Mod ID 关键词")
If PossibleWords.Any Then Logger.Info($"- {PossibleWords.Join(", ")}")
If PossibleWords.Count > 10 Then
Log("[Crash] 关键词过多，考虑匹配出错，不纳入考虑")
Logger.Info("关键词过多，考虑匹配出错，不纳入考虑")
Return New List(Of String)
Else
Return PossibleWords
@@ -738,7 +734,7 @@ NextStack:
''' 根据 Mod 关键词尝试获取实际的 Mod 名称。
''' 若失败则返回 Nothing。
''' </summary>
Private Function AnalyzeModName(Keywords As List(Of String)) As List(Of String)
Private Function AnalyzeModName(Keywords As IEnumerable(Of String)) As List(Of String)
Dim ModFileNames As New List(Of String)
'预处理关键词（分割括号）
@@ -756,7 +752,7 @@ NextStack:
Dim IsFabricDetail As Boolean = Details.Contains("Fabric Mods") '是否为 Fabric 信息格式
If IsFabricDetail Then
Details = Details.Replace("Fabric Mods", "¨")
Log("[Crash] 崩溃报告中检测到 Fabric Mod 信息格式")
Logger.Info("崩溃报告中检测到 Fabric Mod 信息格式")
End If
Details = Details.AfterLast("¨")
@@ -765,9 +761,9 @@ NextStack:
Dim ModNameLines As New List(Of String)
For Each Line In Details.Split(vbLf)
If (Line.ContainsIgnoreCase(".jar") AndAlso Line.Length - Line.Replace(".jar", "").Length = 4) OrElse '只有一个 .jar
(IsFabricDetail AndAlso Line.StartsWithF(vbTab & vbTab) AndAlso Not RegexCheck(Line, "\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
(IsFabricDetail AndAlso Line.StartsWithF(vbTab & vbTab) AndAlso Not Line.RegexCheck("\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
Next
Log("[Crash] 崩溃报告中找到 " & ModNameLines.Count & " 个可能的 Mod 项目行")
Logger.Info($"崩溃报告中找到 {ModNameLines.Count} 个可能的 Mod 项目行")
'获取 Mod ID 与关键词的匹配行
Dim HintLines As New List(Of String)
@@ -781,18 +777,18 @@ NextStack:
Next
Next
HintLines = HintLines.Distinct.ToList
Log("[Crash] 崩溃报告中找到 " & HintLines.Count & " 个可能的崩溃 Mod 匹配行")
Logger.Info($"崩溃报告中找到 {HintLines.Count} 个可能的崩溃 Mod 匹配行")
For Each ModLine As String In HintLines
Log("[Crash] - " & ModLine)
Logger.Info($"- {ModLine}")
Next
'从 Mod 匹配行中提取 .jar 文件的名称
For Each Line As String In HintLines
Dim Name As String
If IsFabricDetail Then
Name = RegexSeek(Line, "(?<=: )[^\n]+(?= [^\n]+)")
Name = Line.RegexSeek("(?<=: )[^\n]+(?= [^\n]+)")
Else
Name = RegexSeek(Line, "(?<=\()[^\t]+.jar(?=\))|(?<=(\t\t)|(\| ))[^\t\|]+.jar", RegularExpressions.RegexOptions.IgnoreCase)
Name = Line.RegexSeek("(?<=\()[^\t]+.jar(?=\))|(?<=(\t\t)|(\| ))[^\t\|]+.jar", RegularExpressions.RegexOptions.IgnoreCase)
End If
If Name IsNot Nothing Then ModFileNames.Add(Name)
Next
@@ -803,8 +799,8 @@ NextStack:
If LogMcDebug IsNot Nothing Then
'Forge: Found valid mod file YungsBetterStrongholds-1.20-Forge-4.0.1.jar with {betterstrongholds} mods - versions {1.20-Forge-4.0.1}
Dim ModNameLines As List(Of String) = RegexSearch(LogMcDebug, "(?<=valid mod file ).*", RegularExpressions.RegexOptions.Multiline)
Log("[Crash] Debug 信息中找到 " & ModNameLines.Count & " 个可能的 Mod 项目行")
Dim ModNameLines = LogMcDebug.RegexSearch("(?<=valid mod file ).*", RegularExpressions.RegexOptions.Multiline)
Logger.Info($"Debug 信息中找到 {ModNameLines.Count} 个可能的 Mod 项目行")
'获取 Mod ID 与关键词的匹配行
Dim HintLines As New List(Of String)
@@ -814,15 +810,15 @@ NextStack:
Next
Next
HintLines = HintLines.Distinct.ToList
Log("[Crash] Debug 信息中找到 " & HintLines.Count & " 个可能的崩溃 Mod 匹配行")
Logger.Info($"Debug 信息中找到 {HintLines.Count} 个可能的崩溃 Mod 匹配行")
For Each ModLine As String In HintLines
Log("[Crash] - " & ModLine)
Logger.Info($"- {ModLine}")
Next
'从 Mod 匹配行中提取 .jar 文件的名称
For Each Line As String In HintLines
Dim Name As String
Name = RegexSeek(Line, ".*(?= with)")
Name = Line.RegexSeek(".*(?= with)")
If Name IsNot Nothing Then ModFileNames.Add(Name)
Next
@@ -833,9 +829,9 @@ NextStack:
If Not ModFileNames.Any() Then
Return Nothing
Else
Log("[Crash] 找到 " & ModFileNames.Count & " 个可能的崩溃 Mod 文件名")
Logger.Info($"找到 {ModFileNames.Count} 个可能的崩溃 Mod 文件名")
For Each ModFileName As String In ModFileNames
Log("[Crash] - " & ModFileName)
Logger.Info($"- {ModFileName}")
Next
Return ModFileNames
End If
@@ -851,9 +847,9 @@ NextStack:
''' <summary>
''' 尝试从关键字获取 Mod 名称，若失败则返回原关键字。
''' </summary>
Private Function TryAnalyzeModName(Keywords As List(Of String)) As List(Of String)
If Not Keywords.Any Then Return Keywords
Return If(AnalyzeModName(Keywords), Keywords)
Private Function TryAnalyzeModName(Keywords As IEnumerable(Of String)) As List(Of String)
If Not Keywords.Any Then Return Keywords.ToList
Return If(AnalyzeModName(Keywords), Keywords.ToList)
End Function
'4：根据原因输出信息
@@ -866,11 +862,11 @@ NextStack:
FrmMain.ShowWindowToTop()
Dim Detail As String = GetAnalyzeResult(IsManualAnalyze)
Select Case MyMsgBox(Detail, If(IsManualAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
"确定", If(IsManualAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsManualAnalyze, "", "导出错误报告"),
"确定", If(IsManualAnalyze OrElse DirectFile Is Nothing, "", "查看输出"), If(IsManualAnalyze, "", "导出错误报告"),
Button2Action:=If(IsManualAnalyze OrElse DirectFile Is Nothing, Nothing,
Sub()
'弹窗选择：查看日志
If File.Exists(DirectFile.Value.Key) Then
'弹窗选择：查看输出
If FileUtils.Exists(DirectFile.Value.Key) Then
StartProcess(DirectFile.Value.Key)
Else
Dim FilePath As String = PathTemp & "Crash.txt"
@@ -883,17 +879,16 @@ NextStack:
Dim FileAddress As String = Nothing
Try
'获取文件路径
RunInUiWait(Sub() FileAddress = SelectSaveFile("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", "Minecraft 错误报告(*.zip)|*.zip"))
If String.IsNullOrEmpty(FileAddress) Then Return
If File.Exists(FileAddress) Then File.Delete(FileAddress)
DirectoryUtils.Create(FileAddress, isFilePath:=True)
RunInUiWait(Sub() FileAddress = Dialogs.SaveFile("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", filter:={("zip", "Minecraft 错误报告")}))
If FileAddress Is Nothing Then Return
FileUtils.Delete(FileAddress)
'输出诊断信息
FeedbackInfo()
LogFlush()
Logger.Instance.Flush()
'复制文件
If ExtraFiles IsNot Nothing Then OutputFiles.AddRange(ExtraFiles)
For Each OutputFile In OutputFiles
Dim FileName As String = GetFileNameFromPath(OutputFile)
Dim FileName As String = PathUtils.GetLastPart(OutputFile)
Dim FileEncoding As Encoding = Nothing
Select Case FileName
Case "LatestLaunch.bat"
@@ -905,23 +900,21 @@ NextStack:
FileName = "游戏崩溃前的输出.txt"
FileEncoding = Encoding.UTF8
End Select
If File.Exists(OutputFile) Then
If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile))
Dim FileContent As String = ReadFile(OutputFile, FileEncoding)
FileContent = FilterUserName(FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")), "*")
FileUtils.Write(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding)
Log($"[Crash] 导出文件：{FileName}，编码：{FileEncoding.HeaderName}")
End If
If Not FileUtils.Exists(OutputFile) Then Continue For
Dim FileContent As String = FileUtils.ReadAsString(OutputFile, FileEncoding)
FileContent = FilterUserName(FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")), "*")
FileUtils.Write(TempFolder & "Report\" & FileName, FileContent, FileEncoding)
Logger.Info($"导出错误报告文件：{FileName}")
Next
'导出报告
Compression.ZipFile.CreateFromDirectory(TempFolder & "Report\", FileAddress)
DeleteDirectory(TempFolder & "Report\")
FileUtils.CreateZipFromDirectory(FileAddress, TempFolder & "Report\")
DirectoryUtils.Delete(TempFolder & "Report\")
Hint("错误报告已导出！", HintType.Green)
OpenExplorer(FileAddress)
Catch ex As Exception
Log(ex, "导出错误报告失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "导出错误报告失败")
Return
End Try
OpenExplorer(FileAddress)
End Select
'上报
If IsManualAnalyze Then Return
Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb
+59 -57
View File
@@ -13,7 +13,7 @@
Instance = New McInstance(Instance.InheritName)
Loop
Catch ex As Exception
Log(ex, "获取底层继承版本失败")
Logger.Warn(ex, "获取底层继承版本失败")
End Try
'检查 Json 是否标准
If Instance.JsonObject("downloads") Is Nothing OrElse Instance.JsonObject("downloads")("client") Is Nothing OrElse Instance.JsonObject("downloads")("client")("url") Is Nothing Then
@@ -39,7 +39,7 @@
'获取信息
Dim IndexInfo = McAssetsGetIndex(Instance, True, True)
Dim IndexAddress As String = McFolderSelected & "assets\indexes\" & IndexInfo("id").ToString & ".json"
Log("[Download] 版本 " & Instance.Name & " 对应的资源文件索引为 " & IndexInfo("id").ToString)
Logger.Info($"版本 {Instance.Name} 对应的资源文件索引为 {IndexInfo("id")}")
Dim IndexUrl As String = If(IndexInfo("url"), "")
If IndexUrl = "" Then
Return Nothing
@@ -65,7 +65,7 @@
#Region "下载资源文件"
If ShouldIgnoreFileCheck(Instance) Then
Log("[Download] 已跳过所有 Assets 检查")
Logger.Info("已跳过所有 Assets 检查")
Else
Dim LoadersAssets As New List(Of LoaderBase)
'获取资源文件索引地址
@@ -75,7 +75,7 @@
Dim IndexFile = DlClientAssetIndexGet(Instance)
If IndexFile Is Nothing Then
Task.Output = New List(Of NetFile)
Log("[Download] 未找到版本 " & Instance.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", NotifyLevel.DebugModeOnly)
Logger.Warn($"未找到版本 {Instance.Name} 的合适的资源索引下载地址，游戏 assets 可能缺失")
ElseIf AssetsIndexBehaviour <> AssetsIndexExistsBehaviour.AlwaysDownload AndAlso IndexFile.Check.Check(IndexFile.LocalPath) Is Nothing Then
Task.Output = New List(Of NetFile)
Else
@@ -96,7 +96,7 @@
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Instance)
If BackAssetsFile Is Nothing Then
Log("[Download] 未找到版本 " & Instance.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", NotifyLevel.DebugModeOnly)
Logger.Warn($"未找到版本 {Instance.Name} 的合适的资源索引下载地址，游戏 assets 可能缺失")
Task.Interrupt()
Throw New ThreadInterruptedException
End If
@@ -105,19 +105,19 @@
BackAssetsFile.LocalPath = TempAddress
Task.Output = New List(Of NetFile) From {BackAssetsFile}
'检查是否需要更新：每天只更新一次
If File.Exists(RealAddress) AndAlso Math.Abs((File.GetLastWriteTime(RealAddress).Date - Now.Date).TotalDays) < 1 Then
Log("[Download] 无需更新资源文件索引，取消")
If FileUtils.Exists(RealAddress) AndAlso Math.Abs((FileUtils.GetInfo(RealAddress).LastWriteTime.Date - Now.Date).TotalDays) < 1 Then
Logger.Info("无需更新资源文件索引，取消")
Task.Interrupt()
End If
End Sub))
LoadersAssetsUpdate.Add(New LoaderDownload("后台下载资源文件索引", New List(Of NetFile)))
LoadersAssetsUpdate.Add(New LoaderTask(Of List(Of NetFile), String)("后台复制资源文件索引",
Sub(Task As LoaderTask(Of List(Of NetFile), String))
CopyFile(TempAddress, RealAddress)
FileUtils.Copy(TempAddress, RealAddress)
McLaunchLog("后台更新资源文件索引成功：" & TempAddress)
End Sub))
Dim Updater As New LoaderCombo(Of String)("后台更新资源文件索引", LoadersAssetsUpdate)
Log("[Download] 开始后台检查资源文件索引")
Logger.Info("开始后台检查资源文件索引")
Updater.Start()
End If
'获取资源文件地址
@@ -158,8 +158,8 @@
Public Property AllDrops As List(Of Integer)
Get
If _AllDrops Is Nothing Then
_AllDrops = Settings.Get("CacheDrops").ToString.
Split(",".ToCharArray, StringSplitOptions.RemoveEmptyEntries).Select(Function(d) CInt(Val(d))).ToList()
_AllDrops = Settings.Get(Of String)("CacheDrops").ToString.
Split(",", True).Select(Function(d) CInt(Val(d))).ToList()
End If
Return If(_AllDrops.Any, _AllDrops, Nothing) '不要将 _AllDrops 再设为 Nothing，以防止反复获取设置尝试初始化
End Get
@@ -191,7 +191,7 @@
''' </summary>
Public DlClientListLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Main", AddressOf DlClientListMain)
Private Sub DlClientListMain(Loader As LoaderTask(Of String, DlClientListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, DlClientListResult), Integer)(DlClientListBmclapiLoader, 30),
@@ -211,7 +211,9 @@
'提取所有 Drop 序数
Dim Drops As New List(Of Integer)
For Each Version As JObject In Loader.Output.Value("versions")
Dim Drop As Integer = McVersion.VersionToDrop(Version("id"))
Dim Id As String = Version("id").ToString
If Id.Contains("-") Then Continue For
Dim Drop As Integer = McVersion.VersionToDrop(Id)
If Drop = 209 Then Continue For
Drops.Add(Drop)
Next
@@ -233,10 +235,10 @@
If Not DlPreferMojang Then
Dim DeltaTime = GetTimeMs() - StartTime
DlPreferMojang = DeltaTime < 4000
Log($"[Download] Mojang 官方源加载耗时：{DeltaTime}ms，{If(DlPreferMojang, "可优先使用官方源", "不优先使用官方源")}")
Logger.Info($"Mojang 官方源加载耗时：{DeltaTime}ms，{If(DlPreferMojang, "可优先使用官方源", "不优先使用官方源")}")
End If
'添加 PCL 特供项
If File.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(ReadFile(PathTemp & "Cache\download.json")))
If FileUtils.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(FileUtils.ReadAsString(PathTemp & "Cache\download.json")))
'返回
Loader.Output = New DlClientListResult With {.IsOfficial = True, .SourceName = "Mojang 官方源", .Value = Json}
'MC 更新提示
@@ -244,16 +246,16 @@
Dim Version As String
'快照版
Version = Json("latest")("snapshot")
If Settings.Get("ToolUpdateSnapshot") AndAlso Not Settings.Get("ToolUpdateSnapshotLast") = "" AndAlso
Settings.Get("ToolUpdateSnapshotLast") <> Version AndAlso Not IsHinted Then
If Settings.Get(Of Boolean)("ToolUpdateSnapshot") AndAlso Not Settings.Get(Of String)("ToolUpdateSnapshotLast") = "" AndAlso
Settings.Get(Of String)("ToolUpdateSnapshotLast") <> Version AndAlso Not IsHinted Then
IsHinted = True
McDownloadClientUpdateHint(Version, Json)
End If
Settings.Set("ToolUpdateSnapshotLast", If(Version, "Nothing"))
'正式版
Version = Json("latest")("release")
If Settings.Get("ToolUpdateRelease") AndAlso Not Settings.Get("ToolUpdateReleaseLast") = "" AndAlso
Settings.Get("ToolUpdateReleaseLast") <> Version AndAlso Not IsHinted Then
If Settings.Get(Of Boolean)("ToolUpdateRelease") AndAlso Not Settings.Get(Of String)("ToolUpdateReleaseLast") = "" AndAlso
Settings.Get(Of String)("ToolUpdateReleaseLast") <> Version AndAlso Not IsHinted Then
IsHinted = True
McDownloadClientUpdateHint(Version, Json)
End If
@@ -272,7 +274,7 @@
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）")
'添加 PCL 特供项
If File.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(ReadFile(PathTemp & "Cache\download.json")))
If FileUtils.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(FileUtils.ReadAsString(PathTemp & "Cache\download.json")))
'检查是否有要求的版本（#5195）
If Not String.IsNullOrEmpty(Loader.Input) Then
Dim Id = Loader.Input
@@ -313,10 +315,10 @@
For Each Version As JObject In DlClientListLoader.Output.Value("versions")
If Version("id") = Id Then Return Version("url").ToString
Next
Log($"未发现版本 {Id} 的 json 下载地址，版本列表返回为：{vbCrLf}{DlClientListLoader.Output.Value.ToString}", NotifyLevel.DebugModeOnly)
Logger.Warn($"未发现版本 {Id} 的 json 下载地址，版本列表返回为：{vbCrLf}{DlClientListLoader.Output.Value}")
Return Nothing
Catch ex As Exception
Log(ex, $"获取版本 {Id} 的 json 下载地址失败")
Logger.Warn(ex, $"获取版本 {Id} 的 json 下载地址失败")
Return Nothing
End Try
End Function
@@ -385,7 +387,7 @@
''' </summary>
Public DlOptiFineListLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Main", AddressOf DlOptiFineListMain)
Private Sub DlOptiFineListMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlOptiFineListResult), Integer)(DlOptiFineListBmclapiLoader, 30),
@@ -413,9 +415,9 @@
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
Try
'获取所有版本信息
Dim Forge As List(Of String) = RegexSearch(Result, "(?<=colForge'>)[^<]*")
Dim ReleaseTime As List(Of String) = RegexSearch(Result, "(?<=colDate'>)[^<]+")
Dim Name As List(Of String) = RegexSearch(Result, "(?<=OptiFine_)[0-9A-Za-z_.]+(?=.jar"")")
Dim Forge As List(Of String) = Result.RegexSearch("(?<=colForge'>)[^<]*").ToList
Dim ReleaseTime As List(Of String) = Result.RegexSearch("(?<=colDate'>)[^<]+").ToList
Dim Name As List(Of String) = Result.RegexSearch("(?<=OptiFine_)[0-9A-Za-z_.]+(?=.jar"")").ToList
If Not ReleaseTime.Count = Name.Count Then Throw New Exception("版本与发布时间数据无法对应")
If Not Forge.Count = Name.Count Then Throw New Exception("版本与 Forge 兼容数据无法对应")
If ReleaseTime.Count < 10 Then Throw New Exception("获取到的版本数量不足（" & Result & "）")
@@ -491,7 +493,7 @@
''' </summary>
Public DlForgeListLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Main", AddressOf DlForgeListMain)
Private Sub DlForgeListMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlForgeListResult), Integer)(DlForgeListBmclapiLoader, 30),
@@ -518,7 +520,7 @@
Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", SimulateBrowserHeaders:=True)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+((_pre|[_-]snapshot[_-]?)[0-9]?)?(?=.html)")
Dim Names As List(Of String) = Result.RegexSearch("(?<=a href=""index_)[0-9.]+((_pre|[_-]snapshot[_-]?)[0-9]?)?(?=.html)").ToList
Names.Add("1.2.4") '1.2.4 不会被匹配上
If Names.Count < 10 Then Throw New Exception("获取到的版本数量不足（" & Result & "）")
Loader.Output = New DlForgeListResult With {.IsOfficial = True, .SourceName = "Forge 官方源", .Value = Names}
@@ -640,7 +642,7 @@
Public Sub DlForgeVersionMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim DlForgeVersionOfficialLoader As New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Official", AddressOf DlForgeVersionOfficialMain)
Dim DlForgeVersionBmclapiLoader As New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Bmclapi", AddressOf DlForgeVersionBmclapiMain)
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)) From {
New KeyValuePair(Of LoaderTask(Of String, List(Of DlForgeVersionEntry)), Integer)(DlForgeVersionBmclapiLoader, 30),
@@ -669,7 +671,7 @@
Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4，#4057
".html", SimulateBrowserHeaders:=True)
Catch ex As Exception
If ex.GetBrief().Contains("(404)") Then
If ex.GetDisplay(False).Contains("(404)") Then
Throw New Exception("无")
Else
Throw
@@ -685,14 +687,14 @@
Dim VersionCode = VersionCodes(i)
Try
'基础信息获取
Dim Name As String = RegexSeek(VersionCode, "(?<=[^(0-9)]+)[0-9\.]+")
Dim Name As String = VersionCode.RegexSeek("(?<=[^(0-9)]+)[0-9\.]+")
Dim IsRecommended As Boolean = VersionCode.Contains("fa promo-recommended")
Dim Inherit As String = Loader.Input
'分支获取
Dim Branch As String = RegexSeek(VersionCode, $"(?<=-{Name}-)[^-""]+(?=-[a-z]+.[a-z]{{3}})")
Dim Branch As String = VersionCode.RegexSeek($"(?<=-{Name}-)[^-""]+(?=-[a-z]+.[a-z]{{3}})")
If String.IsNullOrWhiteSpace(Branch) Then Branch = Nothing
'发布时间获取
Dim ReleaseTimeOriginal = RegexSeek(VersionCode, "(?<=""download-time"" title="")[^""]+")
Dim ReleaseTimeOriginal = VersionCode.RegexSeek("(?<=""download-time"" title="")[^""]+")
Dim ReleaseTimeSplit = ReleaseTimeOriginal.Split(" -:".ToCharArray) '原格式："2021-02-15 03:24:02"
Dim ReleaseDate As New Date(ReleaseTimeSplit(0), ReleaseTimeSplit(1), ReleaseTimeSplit(2), '年月日
ReleaseTimeSplit(3), ReleaseTimeSplit(4), ReleaseTimeSplit(5), '时分秒
@@ -703,17 +705,17 @@
If VersionCode.Contains("classifier-installer""") Then
'类型为 installer.jar，支持范围 ~753 (~ 1.6.1 部分), 738~684 (1.5.2 全部)
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("installer.jar"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
MD5 = VersionCode.RegexSeek("(?<=MD5:</strong> )[^<]+")
Category = "installer"
ElseIf VersionCode.Contains("classifier-universal""") Then
'类型为 universal.zip，支持范围 751~449 (1.6.1 部分), 682~183 (1.5.1 ~ 1.3.2 部分)
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("universal.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
MD5 = VersionCode.RegexSeek("(?<=MD5:</strong> )[^<]+")
Category = "universal"
ElseIf VersionCode.Contains("client.zip") Then
'类型为 client.zip，支持范围 182~ (1.3.2 部分 ~)
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("client.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
MD5 = VersionCode.RegexSeek("(?<=MD5:</strong> )[^<]+")
Category = "client"
Else
'没有任何下载（1.6.4 有一部分这种情况）
@@ -875,7 +877,7 @@
''' </summary>
Public DlNeoForgeListLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Main", AddressOf DlNeoForgeListMain)
Private Sub DlNeoForgeListMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlNeoForgeListResult), Integer)(DlNeoForgeListBmclapiLoader, 30),
@@ -931,7 +933,7 @@
End Sub
Private Function GetNeoForgeEntries(LatestJson As String, LatestLegacyJson As String) As List(Of DlNeoForgeListEntry)
Dim VersionNames = RegexSearch(LatestLegacyJson & LatestJson,
Dim VersionNames = (LatestLegacyJson & LatestJson).RegexSearch(
"(?<="")(1\.20\.1-)?\d+\.[^\.]+\.\d+(\.\d+)?(-(beta|alpha)(\.\d+)?)?(\+snapshot-\d+)?(?="")")
Dim Versions = VersionNames.
Where(Function(name) name <> "47.1.82"). '这个版本虽然在版本列表中，但不能下载
@@ -1000,7 +1002,7 @@
''' </summary>
Public DlLiteLoaderListLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Main", AddressOf DlLiteLoaderListMain)
Private Sub DlLiteLoaderListMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlLiteLoaderListResult), Integer)(DlLiteLoaderListBmclapiLoader, 30),
@@ -1099,7 +1101,7 @@
''' </summary>
Public DlFabricListLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Main", AddressOf DlFabricListMain)
Private Sub DlFabricListMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Select Case Settings.Get("ToolDownloadVersion")
Select Case Settings.Get(Of Integer)("ToolDownloadVersion")
Case 0
DlSourceLoader(Loader, New List(Of KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)) From {
New KeyValuePair(Of LoaderTask(Of Integer, DlFabricListResult), Integer)(DlFabricListBmclapiLoader, 30),
@@ -1170,32 +1172,32 @@
''' </summary>
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))
Dim Urls As New List(Of (Url As String, Timeout As Integer))
Dim McimUrl As String = DlSourceModGet(Url)
If McimUrl <> Url Then
Select Case Settings.Get("ToolDownloadMod")
Select Case Settings.Get(Of Integer)("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))
Urls.Add((McimUrl, 10))
Urls.Add((McimUrl, 10))
Urls.Add((Url, 30))
Case 1
Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10))) '至少 20s，要不然 Modrinth 返回不过来
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))
Urls.Add((Url, If(Url.Contains("modrinth"), 20, 10))) '至少 20s，要不然 Modrinth 返回不过来
Urls.Add((McimUrl, 10))
Urls.Add((Url, 30))
Urls.Add((McimUrl, 30))
Case Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10)))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add((Url, If(Url.Contains("modrinth"), 20, 10)))
Urls.Add((Url, 30))
Urls.Add((McimUrl, 30))
End Select
Else
Urls.Add(New KeyValuePair(Of String, Integer)(Url, If(Url.Contains("modrinth"), 20, 10)))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
Urls.Add((Url, If(Url.Contains("modrinth"), 20, 10)))
Urls.Add((Url, 30))
End If
Dim Exs As String = ""
For Each Source In Urls
Try
Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8, RequireJson:=True))
Return GetJson(NetRequestByClient(Source.Url, Method, Content, ContentType, Timeout:=Source.Timeout * 1000, Encoding:=Encoding.UTF8, RequireJson:=True))
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
@@ -1213,7 +1215,7 @@
''' </summary>
Public ReadOnly Property DlSourcePreferMojang As Boolean
Get
Return Settings.Get("ToolDownloadSource") = 2 OrElse (Settings.Get("ToolDownloadSource") = 1 AndAlso DlPreferMojang)
Return Settings.Get(Of Integer)("ToolDownloadSource") = 2 OrElse (Settings.Get(Of Integer)("ToolDownloadSource") = 1 AndAlso DlPreferMojang)
End Get
End Property
''' <summary>
@@ -1227,7 +1229,7 @@
''' </summary>
Public ReadOnly Property DlVersionListPreferMojang As Boolean
Get
Return Settings.Get("ToolDownloadVersion") = 2 OrElse (Settings.Get("ToolDownloadVersion") = 1 AndAlso DlPreferMojang)
Return Settings.Get(Of Integer)("ToolDownloadVersion") = 2 OrElse (Settings.Get(Of Integer)("ToolDownloadVersion") = 1 AndAlso DlPreferMojang)
End Get
End Property
''' <summary>
Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb
+79 -80
View File
@@ -79,8 +79,7 @@
''' 输入 javaw.exe 文件所在文件夹的路径，不限制结尾。
''' </summary>
Public Sub New(Folder As String, IsUserImport As Boolean)
If Not Folder.EndsWithF("\") Then Folder += "\"
PathFolder = Folder.Replace("/", "\")
PathFolder = PathUtils.AddSlashSuffix(PathUtils.ForCompare(Folder))
Me.IsUserImport = IsUserImport
End Sub
@@ -94,18 +93,18 @@
Dim Output As String = Nothing
Try
'确定文件存在
If Not File.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava)
If Not FileUtils.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava)
If {"finalshell", "Paranoia File"}.Any(Function(n) PathJava.ContainsIgnoreCase(n)) Then Throw New Exception("不兼容该精简版 Java") '#2249、#8080
If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
IsJre = Not File.Exists(PathFolder & "javac.exe")
If FileUtils.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
IsJre = Not FileUtils.Exists(PathFolder & "javac.exe")
'运行 -version
Output = StartProcessAndGetOutput(PathJava, "-version", 15000).Lower
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
If ModeDebug Then Log("[Java] Java 检查输出：" & PathJava & vbCrLf & Output)
Logger.Trace($"Java 检查输出：{PathJava}{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
Dim VersionString = If(Output.RegexSeek("(?<=version "")[^""]+"), If(Output.RegexSeek("(?<=openjdk )[0-9]+"), "")).Replace("_", ".").Split("-").First
If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493，VersionString = "21.0.2.0.2"
Do While VersionString.Split(".").Count < 4
If VersionString.StartsWithF("1.") Then
@@ -117,7 +116,7 @@
If VersionString = "" Then Throw New ApplicationException($"未找到该 Java 的版本号{If(Output.Length < 500, $"{vbCrLf}输出为：{vbCrLf}{Output}", "")}")
Version = New Version(VersionString)
If Version.Minor = 0 Then
Log("[Java] 疑似 X.0.X.X 格式版本号：" & Version.ToString)
Logger.Info($"疑似 X.0.X.X 格式版本号：{Version}")
Version = New Version(1, Version.Major, Version.Build, Version.Revision)
End If
Is64Bit = Output.Contains("64-bit")
@@ -129,7 +128,7 @@
Catch ex As ThreadInterruptedException
Throw ex
Catch ex As Exception
Log("[Java] 检查失败的 Java 输出：" & If(PathJava, "Nothing") & vbCrLf & If(Output, "无程序输出"))
Logger.Info($"检查失败的 Java 输出：{If(PathJava, "Nothing")}{vbCrLf}{If(Output, "无程序输出")}")
Throw New Exception("检查 Java 失败（" & If(PathJava, "Nothing") & "）", ex)
End Try
IsChecked = True
@@ -165,25 +164,25 @@
Public Sub JavaListInit()
JavaList = New List(Of JavaEntry)
Try
If Settings.Get("CacheJavaListVersion") < JavaListCacheVersion Then
If Settings.Get(Of Integer)("CacheJavaListVersion") < JavaListCacheVersion Then
'不使用缓存
Log("[Java] 要求 Java 列表缓存更新")
Logger.Info("要求 Java 列表缓存更新")
Settings.Set("CacheJavaListVersion", JavaListCacheVersion)
Else
'使用缓存
For Each JsonEntry In GetJson(Settings.Get("LaunchArgumentJavaAll"))
For Each JsonEntry In GetJson(Settings.Get(Of String)("LaunchArgumentJavaAll"))
JavaList.Add(JavaEntry.FromJson(JsonEntry))
Next
End If
If Not JavaList.Any() Then
Log("[Java] 初始化未找到可用的 Java，将自动触发搜索", NotifyLevel.DevelopOnly)
Logger.Warn("初始化未找到可用的 Java，将自动触发搜索")
JavaSearchLoader.Start(0)
Else
Log("[Java] 缓存中有 " & JavaList.Count & " 个可用的 Java：")
JavaList.ForEach(Sub(j) Log($"[Java] - {j}"))
Logger.Info($"缓存中有 {JavaList.Count} 个可用的 Java：")
JavaList.ForEach(Sub(j) Logger.Info($"- {j}"))
End If
Catch ex As Exception
Log(ex, "初始化 Java 列表失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "初始化 Java 列表失败")
Settings.Set("LaunchArgumentJavaAll", "[]")
End Try
End Sub
@@ -205,7 +204,7 @@
'添加特定的 Java
Dim JavaPreList As New Dictionary(Of String, Boolean)
If McFolderSelected.Split("\").Count > 3 AndAlso Not McFolderSelected.Contains("AppData\Roaming") Then
JavaSearchFolder(GetPathFromFullPath(McFolderSelected), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录或 %APPDATA% 的话）
JavaSearchFolder(PathUtils.AddSlashSuffix(PathUtils.RemoveLastPart(McFolderSelected)), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录或 %APPDATA% 的话）
End If
JavaSearchFolder(McFolderSelected, JavaPreList, False, True) 'Minecraft 文件夹
JavaPreList = JavaPreList.Where(Function(j) Not j.Key.Contains(".minecraft\runtime")).
@@ -219,9 +218,9 @@
'检查特定的 Java
If TargetJavaList.Any Then
TargetJavaList = JavaCheckList(TargetJavaList)
Log("[Java] 检查后找到 " & TargetJavaList.Count & " 个特定路径下的 Java：")
Logger.Info($"检查后找到 {TargetJavaList.Count} 个特定路径下的 Java：")
For Each Java In TargetJavaList
Log($"[Java] - {Java}")
Logger.Info($"- {Java}")
Next
End If
@@ -232,7 +231,7 @@
'获取版本独立设置中指定的 Java
Dim VersionSelect As String = ""
If GameInstance IsNot Nothing Then
VersionSelect = Settings.Get("VersionArgumentJavaSelect", Instance:=GameInstance)
VersionSelect = Settings.Get(Of String)("VersionArgumentJavaSelect", Instance:=GameInstance)
If VersionSelect.StartsWithF("{") Then
Try
UserJava = JavaEntry.FromJson(GetJson(VersionSelect))
@@ -242,28 +241,28 @@
Catch ex As Exception
UserJava = Nothing
Settings.Reset("VersionArgumentJavaSelect", Instance:=GameInstance)
Log(ex, "版本独立设置中指定的 Java 已无法使用，此设置已重置", NotifyLevel.AllUsers)
Logger.Error(ex, "版本独立设置中指定的 Java 已无法使用，此设置已重置", LogBehavior.Toast)
End Try
End If
End If
'获取全局设置中指定的 Java
If UserJava Is Nothing AndAlso VersionSelect <> "" AndAlso Settings.Get("LaunchArgumentJavaSelect") <> "" Then
If UserJava Is Nothing AndAlso VersionSelect <> "" AndAlso Settings.Get(Of String)("LaunchArgumentJavaSelect") <> "" Then
Try
UserJava = JavaEntry.FromJson(GetJson(Settings.Get("LaunchArgumentJavaSelect")))
UserJava = JavaEntry.FromJson(GetJson(Settings.Get(Of String)("LaunchArgumentJavaSelect")))
UserJava.Check()
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
UserJava = Nothing
Settings.Reset("LaunchArgumentJavaSelect")
Log(ex, "全局设置中指定的 Java 已无法使用，此设置已重置", NotifyLevel.AllUsers)
Logger.Error(ex, "全局设置中指定的 Java 已无法使用，此设置已重置", LogBehavior.Toast)
End Try
End If
'添加到特定 Java 列表
If UserJava IsNot Nothing Then
Log($"[Java] 用户指定的 Java：{UserJava}")
Logger.Info($"用户指定的 Java：{UserJava}")
TargetJavaList.Add(UserJava)
End If
@@ -294,7 +293,7 @@ RetryGet:
'若未找到适合的 Java，尝试触发搜索
If Not AllowedJavaList.Any() AndAlso JavaSearchLoader.State = LoadState.Waiting Then
Log("[Java] 未找到满足条件的 Java，尝试进行搜索")
Logger.Info("未找到满足条件的 Java，尝试进行搜索")
JavaSearchLoader.Start(IsForceRestart:=True)
GoTo RetryGet
End If
@@ -304,16 +303,16 @@ RetryGet:
'确保指定的 Java 可用
If UserJava Is Nothing Then GoTo ExitUserJavaCheck
If AllowedJavaList.Any(Function(j) j.PathFolder = UserJava.PathFolder) Then
Log("[Java] 使用用户指定的 Java：" & UserJava.PathFolder)
Logger.Info($"使用用户指定的 Java：{UserJava.PathFolder}")
AllowedJavaList = New List(Of JavaEntry) From {UserJava}
GoTo UserPass
End If
'指定的 Java 不可用，弹窗要求选择
Log("[Java] 发现用户指定的不兼容 Java：" & UserJava.ToString)
Log($"[Java] 目前实际可用的 Java 列表：")
Logger.Info($"发现用户指定的不兼容 Java：{UserJava}")
Logger.Info($"目前实际可用的 Java 列表：")
For Each Java In AllowedJavaList
Log($"[Java] - {Java}")
Logger.Info($"- {Java}")
Next
Dim Requirement As String = ""
Dim ShowRevision As Boolean = False
@@ -330,20 +329,20 @@ RetryGet:
Requirement = "需要 Java " & If(Left = Right, Left, Left & " ~ " & Right)
End If
Dim JavaCurrent As String = UserJava.MajorVersion & If(ShowRevision, "." & UserJava.Version.MajorRevision & "." & UserJava.Version.MinorRevision, "")
If GameInstance IsNot Nothing AndAlso Settings.Get("VersionAdvanceJava", GameInstance) Then
If GameInstance IsNot Nothing AndAlso Settings.Get(Of Boolean)("VersionAdvanceJava", GameInstance) Then
'直接跳过弹窗
Log("[Java] 设置中指定了使用 Java " & JavaCurrent & "，但当前版本" & Requirement & "，这可能会导致游戏崩溃！", NotifyLevel.DebugModeOnly)
Logger.Warn($"设置中指定了使用 Java {JavaCurrent}，但当前版本{Requirement}，这可能会导致游戏崩溃！")
AllowedJavaList = New List(Of JavaEntry) From {UserJava}
Else
Select Case MyMsgBox("你在设置中手动指定了使用 Java " & JavaCurrent & "，但当前" & Requirement & "。" & vbCrLf &
"如果强制使用该 Java，可能导致游戏崩溃。" & vbCrLf &
"你也可以将 游戏 Java 设置修改为 自动选择合适的 Java。" & vbCrLf &
"你也可以将 游戏 Java 设置修改为 自动选择。" & vbCrLf &
vbCrLf &
" - 指定的 Java：" & UserJava.ToString,
"Java 兼容性警告", "让 PCL 自动选择", "强制使用该 Java", "取消")
Case 1 '让 PCL 自动选择
Case 2 '强制使用指定的 Java
Log("[Java] 已强制使用用户指定的不兼容 Java")
Logger.Info("已强制使用用户指定的不兼容 Java")
AllowedJavaList = New List(Of JavaEntry) From {UserJava}
Case 3 '取消启动
Throw New Exception(CancelException)
@@ -364,7 +363,7 @@ ExitUserJavaCheck:
If TargetJavaList.Contains(Java) Then
'直接使用指定的 Java
AllowedJavaList = New List(Of JavaEntry) From {Java}
Log("[Java] 优先使用特定路径下的 Java：" & Java.ToString)
Logger.Info($"优先使用特定路径下的 Java：{Java}")
GoTo UserPass
End If
Next
@@ -372,9 +371,9 @@ UserPass:
'对适合的 Java 进行排序
AllowedJavaList = AllowedJavaList.SortByComparison(AddressOf JavaSorter)
Log($"[Java] 排序后的 Java 优先顺序：")
Logger.Info($"排序后的 Java 优先顺序：")
For Each Java In AllowedJavaList
Log($"[Java] - {Java}")
Logger.Info($"- {Java}")
Next
'检查选定的 Java，若测试失败则尝试进行搜索
@@ -384,23 +383,23 @@ UserPass:
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If ex.InnerException IsNot Nothing AndAlso TypeOf (ex.InnerException) Is ThreadInterruptedException Then Throw ex.InnerException
Log(ex, "最终选定的 Java 已无法使用，尝试进行搜索")
If ex.InnerException IsNot Nothing AndAlso TypeOf ex.InnerException Is ThreadInterruptedException Then Throw ex.InnerException
Logger.Warn(ex, "最终选定的 Java 已无法使用，尝试进行搜索")
AllowedJavaList = New List(Of JavaEntry)
JavaSearchLoader.Start(IsForceRestart:=True)
GoTo RetryGet
End Try
'返回
Log("[Java] 最终选定的 Java：" & AllowedJavaList.First.ToString)
Logger.Info($"最终选定的 Java：{AllowedJavaList.First}")
Return SelectedJava
Catch ex As ThreadInterruptedException
Log(ex, "查找符合条件的 Java 时出现加载器中断")
Logger.Warn(ex, "查找符合条件的 Java 时出现加载器中断")
Return Nothing
Catch ex As Exception
If ex.Message = "$$" Then Throw ex
Log(ex, "查找符合条件的 Java 失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "查找符合条件的 Java 失败")
Return Nothing
End Try
End Function
@@ -410,9 +409,9 @@ UserPass:
Public Function JavaIs64Bit(Optional GameInstance As McInstance = Nothing) As Boolean
Try
'检查强制指定
Dim UserSetup As String = Settings.Get("LaunchArgumentJavaSelect")
Dim UserSetup As String = Settings.Get(Of String)("LaunchArgumentJavaSelect")
If GameInstance IsNot Nothing Then
Dim UserSetupVersion As String = Settings.Get("VersionArgumentJavaSelect", Instance:=GameInstance)
Dim UserSetupVersion As String = Settings.Get(Of String)("VersionArgumentJavaSelect", Instance:=GameInstance)
If UserSetupVersion <> "使用全局设置" Then UserSetup = UserSetupVersion
End If
If UserSetup <> "" Then
@@ -420,7 +419,7 @@ UserPass:
Try
UserJava = JavaEntry.FromJson(GetJson(UserSetup))
Catch ex As Exception
Log(ex, "版本指定的 Java 信息已损坏，已重置版本设置中指定的 Java")
Logger.Warn(ex, "版本指定的 Java 信息已损坏，已重置版本设置中指定的 Java")
Settings.Set("VersionArgumentJavaSelect", "使用全局设置", Instance:=GameInstance)
GoTo NoUserJava
End Try
@@ -435,7 +434,7 @@ NoUserJava:
Next
Return False
Catch ex As Exception
Log(ex, "检查 Java 类别时出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "检查 Java 类别时出错")
Settings.Set("LaunchArgumentJavaSelect", "")
Return True
End Try
@@ -444,12 +443,12 @@ NoUserJava:
''' 将 Java 按照适用性排序。
''' </summary>
Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean
Dim PathInfo As New DirectoryInfo(PathExeFolder)
Dim PathMcInfo As New DirectoryInfo(McFolderSelected)
'1. 尽量在当前文件夹或当前 Minecraft 文件夹
Dim ProgramPathParent As String, MinecraftPathParent As String = ""
ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName
If McFolderSelected <> "" Then MinecraftPathParent = If(PathMcInfo.Parent, PathMcInfo).FullName
Dim PathInfo = DirectoryUtils.GetInfo(PathExeFolder)
ProgramPathParent = PathUtils.RemoveExtendedPrefix(If(PathInfo.Parent, PathInfo).FullName)
Dim PathMcInfo = DirectoryUtils.GetInfo(McFolderSelected)
If McFolderSelected <> "" Then MinecraftPathParent = PathUtils.RemoveExtendedPrefix(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 McFolderSelected <> "" Then
@@ -505,12 +504,12 @@ NoUserJava:
#Region "模糊查找可能可用的 Java"
'查找环境变量中的 Java
For Each PathInEnv As String In Split((PathEnv & ";" & PathJavaHome).Replace("\\", "\").Replace("/", "\"), ";")
For Each PathInEnv As String In (PathEnv & ";" & PathJavaHome).Replace("\\", "\").Replace("/", "\").Split(";")
PathInEnv = PathInEnv.Trim(" """.ToCharArray())
If PathInEnv = "" Then Continue For
If Not PathInEnv.EndsWithF("\") Then PathInEnv += "\"
'粗略检查有效性
If File.Exists(PathInEnv & "javaw.exe") Then JavaPreList(PathInEnv) = False
If FileUtils.Exists(PathInEnv & "javaw.exe") Then JavaPreList(PathInEnv) = False
Next
'查找磁盘中的 Java
For Each Disk As DriveInfo In DriveInfo.GetDrives()
@@ -530,15 +529,15 @@ NoUserJava:
Dim JavaWithoutReparse As New Dictionary(Of String, Boolean)
For Each Pair In JavaPreList
Dim Folder As String = Pair.Key.Replace("\\", "\").Replace("/", "\")
Dim Info As FileSystemInfo = New FileInfo(Folder & "javaw.exe")
Dim Info As FileSystemInfo = FileUtils.GetInfo(Folder & "javaw.exe")
Do
If Info.Attributes.HasFlag(FileAttributes.ReparsePoint) Then
Log("[Java] 位于 " & Folder & " 的 Java 包含符号链接")
Logger.Info($"位于 {Folder} 的 Java 包含符号链接")
Continue For
End If
Info = If(TypeOf Info Is FileInfo, CType(Info, FileInfo).Directory, CType(Info, DirectoryInfo).Parent)
Loop While Info IsNot Nothing
Log("[Java] 位于 " & Folder & " 的 Java 不含符号链接")
Logger.Info($"位于 {Folder} 的 Java 不含符号链接")
JavaWithoutReparse.Add(Pair.Key, Pair.Value)
Next
If JavaWithoutReparse.Any Then JavaPreList = JavaWithoutReparse
@@ -547,7 +546,7 @@ NoUserJava:
Dim JavaWithoutInherit As New Dictionary(Of String, Boolean)
For Each Pair In JavaPreList
If Pair.Key.Contains("java8path_target_") OrElse Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") OrElse Pair.Key.Contains("system32") Then
Log("[Java] 位于 " & Pair.Key & " 的 Java 位于特殊路径，不应优先使用")
Logger.Info($"位于 {Pair.Key} 的 Java 位于特殊路径，不应优先使用")
Else
JavaWithoutInherit.Add(Pair.Key, Pair.Value)
End If
@@ -558,14 +557,14 @@ NoUserJava:
#Region "添加玩家手动导入的 Java"
Dim ImportedJava As String = Settings.Get("LaunchArgumentJavaAll")
Dim ImportedJava As String = Settings.Get(Of String)("LaunchArgumentJavaAll")
Try
For Each JavaJsonObject In GetJson(ImportedJava)
Dim Entry = JavaEntry.FromJson(JavaJsonObject)
If Entry.IsUserImport Then JavaPreList(Entry.PathFolder) = True
Next
Catch ex As Exception
Log(ex, "Java 列表已损坏", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "Java 列表已损坏")
Settings.Set("LaunchArgumentJavaAll", "[]")
End Try
@@ -587,11 +586,11 @@ NoUserJava:
JavaList = NewJavaList
Catch ex As Exception
Log(ex, "搜索 Java 时出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "搜索 Java 时出错")
JavaList = New List(Of JavaEntry)
End Try
Log("[Java] Java 搜索完成，发现 " & JavaList.Count & " 个 Java")
Logger.Info($"Java 搜索完成，发现 {JavaList.Count} 个 Java")
If FrmSetupLaunch IsNot Nothing Then RunInUi(Sub() FrmSetupLaunch.UpdateJavaComboBox())
If FrmInstanceSetup IsNot Nothing Then RunInUi(Sub() FrmInstanceSetup.RefreshJavaComboBox())
End Sub
@@ -600,8 +599,8 @@ NoUserJava:
''' 多线程检查列表中的所有 Java 项。
''' </summary>
Private Function JavaCheckList(JavaEntries As List(Of JavaEntry)) As List(Of JavaEntry)
Log("[Java] 开始确认列表 Java 状态，共 " & JavaEntries.Count & " 项")
JavaCheckList = New List(Of JavaEntry)
Logger.Info($"开始确认列表 Java 状态，共 {JavaEntries.Count} 项")
Dim Result = New List(Of JavaEntry)
Dim ListLock As New Object
'启动检查线程
@@ -611,16 +610,16 @@ NoUserJava:
Sub()
Try
Entry.Check()
If ModeDebug Then Log("[Java] - " & Entry.ToString)
Logger.Trace($"- {Entry}")
SyncLock ListLock
JavaCheckList.Add(Entry)
Result.Add(Entry)
End SyncLock
Catch ex As ThreadInterruptedException
Catch ex As Exception
If Entry.IsUserImport Then
Log(ex, "位于 " & Entry.PathFolder & " 的 Java 存在异常，将被自动移除", NotifyLevel.AllUsers)
Logger.Error(ex, $"位于 {Entry.PathFolder} 的 Java 存在异常，将被自动移除", LogBehavior.Toast)
Else
Log(ex, "位于 " & Entry.PathFolder & " 的 Java 存在异常")
Logger.Warn(ex, $"位于 {Entry.PathFolder} 的 Java 存在异常")
End If
End Try
End Sub)
@@ -634,6 +633,7 @@ Wait:
For Each CheckThread In CheckThreads
If CheckThread.IsAlive Then GoTo Wait
Next
Return Result
End Function
''' <summary>
''' 模糊搜索指定文件夹下的 Java，并只进行粗略的检查。这不会搜索全部路径。
@@ -642,12 +642,12 @@ Wait:
''' <param name="IsFullSearch">搜索当前文件夹下的全部文件夹（此参数不会传递到子文件夹）。</param>
Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
Try
Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找：" & OriginalPath)
JavaSearchFolder(New DirectoryInfo(OriginalPath), Results, Source, IsFullSearch)
Logger.Info($"开始{If(IsFullSearch, "完全", "部分")}遍历查找：{OriginalPath}")
JavaSearchFolder(DirectoryUtils.GetInfo(OriginalPath), Results, Source, IsFullSearch)
Catch ex As UnauthorizedAccessException
Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹：" & OriginalPath)
Logger.Info($"遍历查找 Java 时遭遇无权限的文件夹：{OriginalPath}")
Catch ex As Exception
Log(ex, "遍历查找 Java 时出错（" & OriginalPath & "）")
Logger.Warn(ex, $"遍历查找 Java 时出错（{OriginalPath}）")
End Try
End Sub
''' <summary>
@@ -659,10 +659,9 @@ Wait:
Try
'确认目录存在
If Not OriginalPath.Exists Then Return
Dim Folder As String = OriginalPath.FullName.Replace("\\", "\")
If Not Folder.EndsWithF("\") Then Folder += "\"
Dim Folder As String = PathUtils.AddSlashSuffix(PathUtils.ForCompare(OriginalPath.FullName))
'若该目录有 Java，则加入结果
If File.Exists(Folder & "javaw.exe") Then Results(Folder) = Source
If FileUtils.Exists(Folder & "javaw.exe") Then Results(Folder) = Source
'查找其下的所有文件夹
'不应使用网易的 Java：https://github.com/Meloong-Git/PCL/issues/1279#issuecomment-2761489121
Static Keywords As String() = {
@@ -674,16 +673,16 @@ Wait:
"download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages", "4297127d64ec6", "1.", "启动", "jbr"}
For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories
If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接
Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).Lower '用于搜索的字符串
Dim SearchEntry = PathUtils.GetLastPart(FolderInfo.Name).Lower '用于搜索的字符串
If IsFullSearch OrElse
OriginalPath.Name.Lower = "users" OrElse Val(SearchEntry) > 0 OrElse Keywords.Any(Function(w) SearchEntry.Contains(w)) OrElse SearchEntry = "bin" Then
JavaSearchFolder(FolderInfo, Results, Source)
End If
Next
Catch ex As UnauthorizedAccessException
Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹：" & OriginalPath.FullName)
Logger.Trace(Function() $"遍历查找 Java 时遭遇无权限的文件夹（{OriginalPath.FullName}）：{ex.GetDisplay(False)}")
Catch ex As Exception
Log(ex, "遍历查找 Java 时出错（" & OriginalPath.FullName & "）")
Logger.Warn(ex, $"遍历查找 Java 时出错（{OriginalPath.FullName}）")
End Try
End Sub
@@ -704,8 +703,8 @@ Wait:
AddHandler JavaDownloadLoader.OnStateChangedThread,
Sub(Raw As LoaderBase, NewState As LoadState, OldState As LoadState)
If (NewState = LoadState.Failed OrElse NewState = LoadState.Interrupted) AndAlso LastJavaBaseDir IsNot Nothing Then
Log($"[Java] 由于下载未完成，清理未下载完成的 Java 文件：{LastJavaBaseDir}", NotifyLevel.DebugModeOnly)
DeleteDirectory(LastJavaBaseDir)
Logger.Warn($"由于下载未完成，清理未下载完成的 Java 文件：{LastJavaBaseDir}")
DirectoryUtils.Delete(LastJavaBaseDir)
ElseIf NewState = LoadState.Finished Then
LastJavaBaseDir = Nothing
End If
@@ -715,7 +714,7 @@ Wait:
End Function
Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹，防止残留只下了一半但 -version 能跑的 Java
Private Sub JavaFileList(Loader As LoaderTask(Of String, List(Of NetFile)))
Log("[Java] 开始获取 Java 下载信息")
Logger.Info("开始获取 Java 下载信息")
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"}
@@ -751,7 +750,7 @@ Wait:
Results.Add(New NetFile(DlSourceOrder({Url}, {Url.Replace("piston-data.mojang.com", "bmclapi2.bangbang93.com")}), LastJavaBaseDir & File.Name, Checker))
Next
Loader.Output = Results
Log($"[Java] 需要下载 {Results.Count} 个文件，目标文件夹：{LastJavaBaseDir}")
Logger.Info($"需要下载 {Results.Count} 个文件，目标文件夹：{LastJavaBaseDir}")
End Sub
#End Region
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+262 -272
View File
File diff suppressed because it is too large Load Diff
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+280 -254
View File
File diff suppressed because it is too large Load Diff
Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb
+136 -143
View File
@@ -5,7 +5,7 @@
''' 弹窗要求选择一个整合包文件并进行安装。
''' </summary>
Public Sub ModpackInstall()
Dim File As String = SelectFile("整合包文件(*.rar;*.zip;*.mrpack)|*.rar;*.zip;*.mrpack", "选择整合包压缩文件") '选择整合包文件
Dim File As String = Dialogs.SelectFile("选择整合包压缩文件", False, filter:={({"rar", "zip", "mrpack"}, "整合包文件")}).FirstOrDefault() '选择整合包文件
If String.IsNullOrEmpty(File) Then Return
RunInThread(
Sub()
@@ -13,7 +13,7 @@
ModpackInstall(File)
Catch ex As CancelledException
Catch ex As Exception
Log(ex, "手动安装整合包失败", NotifyLevel.MsgBox)
Logger.Error(ex, "手动安装整合包失败", LogBehavior.Alert)
End Try
End Sub)
End Sub
@@ -23,7 +23,7 @@
''' </summary>
''' <exception cref="CancelledException" />
Public Function ModpackInstall(File As String, Optional InstanceName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
Log("[ModPack] 整合包安装请求：" & If(File, "null"))
Logger.Info($"整合包安装请求：{If(File, "null")}")
Dim Archive As ZipArchive = Nothing
Dim ArchiveBaseFolder As String = ""
Try
@@ -33,13 +33,13 @@
'获取整合包种类与关键 Json
Dim PackType As Integer = -1
Try
Archive = New ZipArchive(New FileStream(File, FileMode.Open, FileAccess.Read, FileShare.Read))
Archive = FileUtils.OpenZip(File)
'从根目录判断整合包类型
If Archive.GetEntry("mcbbs.packmeta") IsNot Nothing Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
If Archive.GetEntry("mmc-pack.json") IsNot Nothing Then PackType = 2 : Exit Try 'MMC 整合包（优先于 manifest.json 判断，#4194）
If Archive.GetEntry("modrinth.index.json") IsNot Nothing Then PackType = 4 : Exit Try 'Modrinth 整合包
If Archive.GetEntry("manifest.json") IsNot Nothing Then
Dim Json As JObject = GetJson(ReadFile(Archive.GetEntry("manifest.json").Open, Encoding.UTF8))
Dim Json As JObject = GetJson(Archive.GetEntry("manifest.json").Open().ReadString(Encoding.UTF8))
If Json("addons") Is Nothing Then
PackType = 0 : Exit Try 'CurseForge 整合包
Else
@@ -50,27 +50,27 @@
If Archive.GetEntry("modpack.zip") IsNot Nothing OrElse Archive.GetEntry("modpack.mrpack") IsNot Nothing Then PackType = 9 : Exit Try '带启动器的压缩包
'从一级目录判断整合包类型
For Each Entry In Archive.Entries
Dim FullNames As String() = Entry.FullName.Split("/")
ArchiveBaseFolder = FullNames(0) & "/"
Dim PathSplits As String() = Entry.FullName.Split("/")
ArchiveBaseFolder = PathSplits(0) & "/"
'确定为一级目录下
If FullNames.Count <> 2 Then Continue For
If PathSplits.Count <> 2 Then Continue For
'判断是否为关键文件
If FullNames(1) = "mcbbs.packmeta" Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包（优先于 manifest.json 判断，#4194）
If FullNames(1) = "modrinth.index.json" Then PackType = 4 : Exit Try 'Modrinth 整合包
If FullNames(1) = "manifest.json" Then
Dim Json As JObject = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
If PathSplits(1) = "mcbbs.packmeta" Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
If PathSplits(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包（优先于 manifest.json 判断，#4194）
If PathSplits(1) = "modrinth.index.json" Then PackType = 4 : Exit Try 'Modrinth 整合包
If PathSplits(1) = "manifest.json" Then
Dim Json As JObject = GetJson(Entry.Open().ReadString(Encoding.UTF8))
If Json("addons") Is Nothing Then
PackType = 0 : Exit Try 'CurseForge 整合包
Else
PackType = 3 : ArchiveBaseFolder = "overrides/" : Exit Try 'MCBBS 整合包
End If
End If
If FullNames(1) = "modpack.json" Then PackType = 1 : Exit Try 'HMCL 整合包
If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包
If PathSplits(1) = "modpack.json" Then PackType = 1 : Exit Try 'HMCL 整合包
If PathSplits(1) = "modpack.zip" OrElse PathSplits(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包
Next
Catch ex As Exception
If ex.GetDetail(True).Contains("Error.WinIOError") Then
If ex.GetDisplay(True).Contains("Error.WinIOError") Then
Throw New Exception("打开整合包文件失败", ex)
ElseIf File.EndsWithF(".rar", True) Then
Throw New Exception("PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", ex)
@@ -81,25 +81,25 @@
'执行对应的安装方法
Select Case PackType
Case 0
Log("[ModPack] 整合包种类：CurseForge")
Logger.Info("整合包种类：CurseForge")
Return InstallPackCurseForge(File, Archive, ArchiveBaseFolder, InstanceName, Logo)
Case 1
Log("[ModPack] 整合包种类：HMCL")
Logger.Info("整合包种类：HMCL")
Return InstallPackHMCL(File, Archive, ArchiveBaseFolder)
Case 2
Log("[ModPack] 整合包种类：MMC")
Logger.Info("整合包种类：MMC")
Return InstallPackMMC(File, Archive, ArchiveBaseFolder)
Case 3
Log("[ModPack] 整合包种类：MCBBS")
Logger.Info("整合包种类：MCBBS")
Return InstallPackMCBBS(File, Archive, ArchiveBaseFolder, InstanceName)
Case 4
Log("[ModPack] 整合包种类：Modrinth")
Logger.Info("整合包种类：Modrinth")
Return InstallPackModrinth(File, Archive, ArchiveBaseFolder, InstanceName, Logo)
Case 9
Log("[ModPack] 整合包种类：带启动器的压缩包")
Logger.Info("整合包种类：带启动器的压缩包")
Return InstallPackLauncherPack(File, Archive, ArchiveBaseFolder)
Case Else
Log("[ModPack] 整合包种类：未能识别，假定为压缩包")
Logger.Info("整合包种类：未能识别，假定为压缩包")
Return InstallPackCompress(File, Archive)
End Select
Finally
@@ -111,13 +111,14 @@
'解压文件
Dim RetryCount As Integer = 1
Dim InitialProgress = Loader.Progress
Try
Retry:
Try
Loader.Progress = InitialProgress
DeleteDirectory(InstallTemp)
ExtractCompressedFile(FileAddress, InstallTemp, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * ProgressIncrement)
DirectoryUtils.Delete(InstallTemp)
Dim RawProgress As Double = Loader.Progress
FileUtils.ExtractToDirectory(FileAddress, InstallTemp, progressHandler:=Sub(Percentage) Loader.Progress = RawProgress + Percentage * ProgressIncrement)
Catch ex As Exception
Log(ex, "第 " & RetryCount & " 次解压尝试失败")
Logger.Warn(ex, $"第 {RetryCount} 次解压尝试失败")
'完全不知道为啥会出现文件正在被另一进程使用的问题，总之加个重试
If RetryCount < 5 Then
Thread.Sleep(RetryCount * 2000)
@@ -134,25 +135,24 @@ Retry:
''' 从整合包的 override 目录复制文件，同时设置 PCL 的配置文件与版本隔离。
''' 对路径末尾是否为 \ 没有要求。
''' </summary>
Private Sub CopyOverrideDirectory(OverridesFolder As String, VersionFolder As String, Loader As LoaderBase, ProgressIncrement As Double)
Private Sub CopyOverrideDirectory(OverridesFolder As String, VersionFolder As String, Loader As LoaderBase)
If Not OverridesFolder.EndsWithF("\") Then OverridesFolder += "\"
If Not VersionFolder.EndsWithF("\") Then VersionFolder += "\"
'复制文件
If Directory.Exists(OverridesFolder) Then
Log($"[ModPack] 处理整合包覆写文件夹：{OverridesFolder} → {VersionFolder}")
CopyDirectory(OverridesFolder, VersionFolder, Sub(Delta) Loader.Progress += Delta * ProgressIncrement)
If DirectoryUtils.Exists(OverridesFolder) Then
Logger.Info($"处理整合包覆写文件夹：{OverridesFolder} → {VersionFolder}")
DirectoryUtils.Copy(OverridesFolder, VersionFolder)
Else
Log($"[ModPack] 整合包中没有覆写文件夹：{OverridesFolder}")
Loader.Progress += ProgressIncrement
Logger.Info($"整合包中没有覆写文件夹：{OverridesFolder}")
End If
'设置 ini
Dim OverridesIni As String = $"{OverridesFolder}PCL\Setup.ini"
Dim VersionIni As String = $"{VersionFolder}PCL\Setup.ini"
If File.Exists(OverridesIni) Then
If FileUtils.Exists(OverridesIni) Then
WriteIni(OverridesIni, "VersionArgumentIndie", 1) '开启版本隔离
WriteIni(OverridesIni, "VersionArgumentIndieV2", True)
WriteIni(OverridesIni, "IsStar", False)
CopyFile(OverridesIni, VersionIni) '覆写已有的 ini
FileUtils.Copy(OverridesIni, VersionIni) '覆写已有的 ini
Else
WriteIni(VersionIni, "VersionArgumentIndie", 1) '开启版本隔离
WriteIni(VersionIni, "VersionArgumentIndieV2", True)
@@ -178,7 +178,7 @@ Retry:
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open))
Json = GetJson(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open().ReadString)
Catch ex As Exception
Throw New Exception("CurseForge 整合包安装信息存在问题", ex)
End Try
@@ -194,24 +194,23 @@ Retry:
End If
'获取 Mod API 版本信息
Dim ForgeVersion As String = Nothing
Dim NeoForgeVersion As String = Nothing
Dim FabricVersion As String = Nothing
Dim TargetVersion As New McVersion
TargetVersion.VanillaName = Json("minecraft")("version").ToString
For Each Entry In If(Json("minecraft")("modLoaders"), {})
Dim Id As String = If(Entry("id"), "").ToString.Lower
If Id.StartsWithF("forge-") Then
'Forge 指定
If Id.Contains("recommended") Then Throw New Exception("该整合包版本过老，已不支持进行安装！")
Log("[ModPack] 整合包 Forge 版本：" & Id)
ForgeVersion = Id.Replace("forge-", "")
Logger.Info($"整合包 Forge 版本：{Id}")
TargetVersion.Forge = Id.Replace("forge-", "")
ElseIf Id.StartsWithF("neoforge-") Then
'NeoForge 指定
Log("[ModPack] 整合包 NeoForge 版本：" & Id)
NeoForgeVersion = Id.Replace("neoforge-", "")
Logger.Info($"整合包 NeoForge 版本：{Id}")
TargetVersion.NeoForge = Id.Replace("neoforge-", "")
ElseIf Id.StartsWithF("fabric-") Then
'Fabric 指定
Log("[ModPack] 整合包 Fabric 版本：" & Id)
FabricVersion = Id.Replace("fabric-", "")
Logger.Info($"整合包 Fabric 版本：{Id}")
TargetVersion.Fabric = Id.Replace("fabric-", "")
Else
'ElseIf Id.StartsWithF("quilt-") Then
NotifyIncompatibleLoader(Id)
@@ -227,10 +226,9 @@ Retry:
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & If(OverrideHome = "." OrElse OverrideHome = "./", "", OverrideHome), '#5613
$"{McFolderSelected}versions\{InstanceName}",
Task, 0.4)
$"{McFolderSelected}versions\{InstanceName}", Task)
End Sub) With {
.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
.ProgressWeight = FileUtils.GetInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
End If
'获取 Mod 列表
Dim ModList As New List(Of Integer)
@@ -253,17 +251,17 @@ Retry:
'如果文件已被删除，则 API 会跳过那一项，导致返回的列表数量小于请求的数量。后面的都是对此的错误处理。
'获取缺失的 fileId 列表
Dim MissingIds = ModList.Except(Task.Output.Select(Function(j) j("id").ToObject(Of Integer))).ToList
Log("[Modpack] 缺失的 fileIds：" & MissingIds.Join("、"))
Logger.Info($"缺失的 fileIds：{MissingIds.Join("、")}")
'将 fileId 映射到 projectId
Dim Missings = MissingIds.Select(Of (ProjectId As Integer, FileId As Integer))(
Function(id) (CType(Json("files").AsEnumerable.First(Function(f) f("fileID").ToObject(Of Integer) = id), JObject)("projectID").ToObject(Of Integer), id)).ToList
Log("[Modpack] 缺失项：" & Missings.Join("、"))
Logger.Info($"缺失项：{Missings.Join("、")}")
'尝试获取对应的工程信息
Dim Projects As New List(Of ResourceProject)
Try
Projects = ResourceProject.FromProjectIds(Missings.Select(Function(e) e.ProjectId.ToString), ResourcePlatforms.CurseForge).ToList
Catch ex As Exception
Log(ex, "获取缺失的工程信息失败")
Logger.Warn(ex, "获取缺失的工程信息失败")
End Try
Dim MissingDesc As New List(Of String)
For Each Missing In Missings
@@ -312,7 +310,8 @@ Retry:
Dim File = ResourceVersion.FromPlatformJson(ModJson, Type)
If Not File.DownloadAvailable Then Continue For
'实际的添加
FileList.Add(Id, File.ToNetFile($"{McFolderSelected}versions\{InstanceName}\{TargetFolder}\"))
FileList.Add(Id, File.ToNetFile($"{McFolderSelected}versions\{InstanceName}\{TargetFolder}\",
ResourceVersion.DownloadReason.ModPack, TargetVersion.VanillaName, TargetVersion.ModLoaders))
Task.Progress += 1 / (1 + ModList.Count)
Next
Task.Output = FileList.Values.ToList
@@ -328,10 +327,10 @@ Retry:
Dim Request As New McInstallRequest With {
.NewInstanceName = InstanceName,
.VersionFolder = $"{McFolderSelected}versions\{InstanceName}\",
.MinecraftName = Json("minecraft")("version").ToString,
.ForgeVersion = ForgeVersion,
.NeoForgeVersion = NeoForgeVersion,
.FabricVersion = FabricVersion
.MinecraftName = TargetVersion.VanillaName,
.ForgeVersion = TargetVersion.Forge,
.NeoForgeVersion = TargetVersion.NeoForge,
.FabricVersion = TargetVersion.Fabric
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
'构造总加载器
@@ -342,22 +341,22 @@ Retry:
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = $"{McFolderSelected}versions\{InstanceName}\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
If Logo IsNot Nothing AndAlso FileUtils.Exists(Logo) Then
FileUtils.Copy(Logo, VersionFolder & "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo：" & Logo)
Logger.Info($"已设置整合包 Logo：{Logo}")
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If File.Exists(Target) Then
Log("[ModPack] 删除原始整合包文件：" & Target)
File.Delete(Target)
If FileUtils.Exists(Target) Then
Logger.Info($"删除原始整合包文件：{Target}")
FileUtils.Delete(Target)
End If
Next
If File.Exists(FileAddress) AndAlso Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Log("[ModPack] 删除安装整合包文件：" & FileAddress)
File.Delete(FileAddress)
If FileUtils.Exists(FileAddress) AndAlso PathUtils.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Logger.Info($"删除安装整合包文件：{FileAddress}")
FileUtils.Delete(FileAddress)
End If
End Sub) With {.ProgressWeight = 0.1, .Show = False})
@@ -383,29 +382,26 @@ Retry:
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modrinth.index.json").Open))
Json = GetJson(Archive.GetEntry(ArchiveBaseFolder & "modrinth.index.json").Open().ReadString)
Catch ex As Exception
Throw New Exception("Modrinth 整合包安装信息存在问题", ex)
End Try
If Json("dependencies") Is Nothing OrElse Json("dependencies")("minecraft") Is Nothing Then Throw New Exception("Modrinth 整合包未提供 Minecraft 版本信息")
'获取 Mod API 版本信息
Dim MinecraftVersion As String = Nothing
Dim ForgeVersion As String = Nothing
Dim NeoForgeVersion As String = Nothing
Dim FabricVersion As String = Nothing
Dim TargetVersion As New McVersion
For Each Entry As JProperty In If(Json("dependencies"), {})
Select Case Entry.Name.Lower
Case "minecraft"
MinecraftVersion = Entry.Value.ToString
TargetVersion.VanillaName = Entry.Value.ToString
Case "forge" 'eg. 14.23.5.2859 / 1.19-41.1.0
ForgeVersion = Entry.Value.ToString
Log("[ModPack] 整合包 Forge 版本：" & ForgeVersion)
TargetVersion.Forge = Entry.Value.ToString
Logger.Info($"整合包 Forge 版本：{TargetVersion.Forge}")
Case "neoforge", "neo-forge" 'eg. 20.6.98-beta
NeoForgeVersion = Entry.Value.ToString
Log("[ModPack] 整合包 NeoForge 版本：" & NeoForgeVersion)
TargetVersion.NeoForge = Entry.Value.ToString
Logger.Info($"整合包 NeoForge 版本：{TargetVersion.NeoForge}")
Case "fabric-loader" 'eg. 0.14.14
FabricVersion = Entry.Value.ToString
Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion)
TargetVersion.Fabric = Entry.Value.ToString
Logger.Info($"整合包 Fabric 版本：{TargetVersion.Fabric}")
Case Else
'Case "quilt-loader" 'eg. 1.0.0
NotifyIncompatibleLoader(Entry.Name)
@@ -427,13 +423,11 @@ Retry:
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.5)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & "overrides",
McFolderSelected & "versions\" & InstanceName,
Task, 0.4)
McFolderSelected & "versions\" & InstanceName, Task)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & "client-overrides",
McFolderSelected & "versions\" & InstanceName,
Task, 0.1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
McFolderSelected & "versions\" & InstanceName, Task)
End Sub) With {.ProgressWeight = FileUtils.GetInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'获取下载文件列表
Dim FileList As New List(Of NetFile)
For Each File In If(Json("files"), {})
@@ -441,7 +435,7 @@ Retry:
If File("env") IsNot Nothing Then
Select Case File("env")("client").ToString
Case "optional"
If MyMsgBox("是否要下载可选文件 " & GetFileNameFromPath(File("path").ToString) & "？",
If MyMsgBox("是否要下载可选文件 " & PathUtils.GetLastPart(File("path").ToString) & "？",
"下载可选文件", "是", "否") = 2 Then
Continue For
End If
@@ -452,10 +446,12 @@ Retry:
'添加下载文件
Dim Urls = File("downloads").SelectMany(Function(t) ResourceVersion.ParseCurseForgeDownloadUrls(t.ToString)).ToList
Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
Urls = ResourceVersion.ParseModrinthTrackArguments(Urls,
ResourceVersion.DownloadReason.ModPack, TargetVersion.VanillaName, TargetVersion.ModLoaders).ToList 'Modrinth 来源追踪信息
Urls = Urls.Distinct.ToList()
Dim TargetPath As String = $"{McFolderSelected}versions\{InstanceName}\{File("path")}"
If Not Path.GetFullPath(TargetPath).StartsWithF($"{McFolderSelected}versions\{InstanceName}\", True) Then
MyMsgBox($"整合包的文件路径超出了版本文件夹，请向整合包作者反馈此问题！" & vbCrLf & "错误的文件：" & TargetPath, "文件路径校验失败", IsWarn:=True)
If Not Path.GetFullPath(TargetPath).StartsWithF(Path.GetFullPath($"{McFolderSelected}versions\{InstanceName}\")) Then
MyMsgBox($"整合包的文件路径超出了版本文件夹，请向整合包作者反馈此问题！{vbCrLf}目标：{Path.GetFullPath(TargetPath)}{vbCrLf}错误的文件：{TargetPath}", "文件路径校验失败", IsWarn:=True)
Throw New CancelledException
End If
FileList.Add(New NetFile(Urls, TargetPath,
@@ -469,10 +465,10 @@ Retry:
Dim Request As New McInstallRequest With {
.NewInstanceName = InstanceName,
.VersionFolder = $"{McFolderSelected}versions\{InstanceName}\",
.MinecraftName = MinecraftVersion,
.ForgeVersion = ForgeVersion,
.NeoForgeVersion = NeoForgeVersion,
.FabricVersion = FabricVersion
.MinecraftName = TargetVersion.VanillaName,
.ForgeVersion = TargetVersion.Forge,
.NeoForgeVersion = TargetVersion.NeoForge,
.FabricVersion = TargetVersion.Fabric
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
'构造总加载器
@@ -483,22 +479,22 @@ Retry:
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = $"{McFolderSelected}versions\{InstanceName}\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
If Logo IsNot Nothing AndAlso FileUtils.Exists(Logo) Then
FileUtils.Copy(Logo, VersionFolder & "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo：" & Logo)
Logger.Info($"已设置整合包 Logo：{Logo}")
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If File.Exists(Target) Then
Log("[ModPack] 删除原始整合包文件：" & Target)
File.Delete(Target)
If FileUtils.Exists(Target) Then
Logger.Info($"删除原始整合包文件：{Target}")
FileUtils.Delete(Target)
End If
Next
If File.Exists(FileAddress) AndAlso Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Log("[ModPack] 删除安装整合包文件：" & FileAddress)
File.Delete(FileAddress)
If FileUtils.Exists(FileAddress) AndAlso PathUtils.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Logger.Info($"删除安装整合包文件：{FileAddress}")
FileUtils.Delete(FileAddress)
End If
End Sub) With {.ProgressWeight = 0.1, .Show = False})
@@ -523,7 +519,7 @@ Retry:
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modpack.json").Open, Encoding.UTF8))
Json = GetJson(Archive.GetEntry(ArchiveBaseFolder & "modpack.json").Open().ReadString(Encoding.UTF8))
Catch ex As Exception
Throw New Exception("HMCL 整合包安装信息存在问题", ex)
End Try
@@ -541,9 +537,8 @@ Retry:
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & "minecraft",
McFolderSelected & "versions\" & InstanceName,
Task, 0.4)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
McFolderSelected & "versions\" & InstanceName, Task)
End Sub) With {.ProgressWeight = FileUtils.GetInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造游戏本体安装加载器
If Json("gameVersion") Is Nothing Then Throw New Exception("该 HMCL 整合包未提供游戏版本信息，无法安装！")
Dim Request As New McInstallRequest With {
@@ -577,13 +572,13 @@ Retry:
'读取 Json 文件
Dim PackJson As JObject, PackInstance As String
Try
PackJson = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "mmc-pack.json").Open, Encoding.UTF8))
PackInstance = ReadFile(Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open, Encoding.UTF8)
PackJson = GetJson(Archive.GetEntry(ArchiveBaseFolder & "mmc-pack.json").Open().ReadString(Encoding.UTF8))
PackInstance = Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open().ReadString(Encoding.UTF8)
Catch ex As Exception
Throw New Exception("MMC 整合包安装信息存在问题", ex)
End Try
'获取版本名
Dim InstanceName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
Dim InstanceName As String = If(PackInstance.RegexSeek("(?<=\nname\=)[^\n]+"), "")
Dim Validate As New ValidateFolderName(McFolderSelected & "versions")
If Validate.Validate(InstanceName) <> "" Then InstanceName = ""
If InstanceName = "" Then InstanceName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
@@ -597,15 +592,14 @@ Retry:
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.55)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & ".minecraft",
McFolderSelected & "versions\" & InstanceName,
Task, 0.4)
McFolderSelected & "versions\" & InstanceName, Task)
'读取 MMC 设置文件（#2655）
Try
Dim MmcSetupFile As String = InstallTemp & ArchiveBaseFolder & "instance.cfg"
If File.Exists(MmcSetupFile) Then
If FileUtils.Exists(MmcSetupFile) Then
'将其中的等号替换为冒号，以符合 ini 文件格式
Dim Lines As New List(Of String)
For Each Line In ReadFile(MmcSetupFile).Split(vbCrLf.ToCharArray, StringSplitOptions.RemoveEmptyEntries)
For Each Line In FileUtils.ReadAsLines(MmcSetupFile, True)
If Not Line.Contains("=") Then Continue For
Lines.Add(Line.BeforeFirst("=") & ":" & Line.AfterFirst("="))
Next
@@ -620,42 +614,42 @@ Retry:
Replace("$INST_DIR\", "{verpath}").Replace("$INST_DIR", "{verpath}").
Replace("$INST_ID", "{name}").Replace("$INST_NAME", "{name}")
WriteIni(SetupFile, "VersionAdvanceRun", PreLaunchCommand)
Log("[ModPack] 迁移 MultiMC 版本独立设置：启动前执行命令：" & PreLaunchCommand)
Logger.Info($"迁移 MultiMC 版本独立设置：启动前执行命令：{PreLaunchCommand}")
End If
End If
If ReadIni(MmcSetupFile, "JoinServerOnLaunch", False) Then
Dim ServerAddress As String = ReadIni(MmcSetupFile, "JoinServerOnLaunchAddress").Replace("\""", """")
WriteIni(SetupFile, "VersionServerEnter", ServerAddress)
Log("[ModPack] 迁移 MultiMC 版本独立设置：自动进入服务器：" & ServerAddress)
Logger.Info($"迁移 MultiMC 版本独立设置：自动进入服务器：{ServerAddress}")
End If
If ReadIni(MmcSetupFile, "IgnoreJavaCompatibility", False) Then
WriteIni(SetupFile, "VersionAdvanceJava", True)
Log("[ModPack] 迁移 MultiMC 版本独立设置：忽略 Java 兼容性警告")
Logger.Info("迁移 MultiMC 版本独立设置：忽略 Java 兼容性警告")
End If
Dim Logo As String = ReadIni(MmcSetupFile, "iconKey", "")
If Logo <> "" AndAlso File.Exists($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png") Then
If Logo <> "" AndAlso FileUtils.Exists($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png") Then
WriteIni(SetupFile, "LogoCustom", True)
WriteIni(SetupFile, "Logo", "PCL\Logo.png")
CopyFile($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png", $"{McFolderSelected}versions\{InstanceName}\PCL\Logo.png")
Log($"[ModPack] 迁移 MultiMC 版本独立设置：版本图标（{Logo}.png）")
FileUtils.Copy($"{InstallTemp}{ArchiveBaseFolder}{Logo}.png", $"{McFolderSelected}versions\{InstanceName}\PCL\Logo.png")
Logger.Info($"迁移 MultiMC 版本独立设置：版本图标（{Logo}.png）")
End If
'JVM 参数
Dim JvmArgs As String = ReadIni(MmcSetupFile, "JvmArgs", "")
If JvmArgs <> "" Then
If ReadIni(MmcSetupFile, "OverrideJavaArgs", False) Then
WriteIni(SetupFile, "VersionAdvanceJvm", JvmArgs)
Log("[ModPack] 迁移 MultiMC 版本独立设置：JVM 参数（覆盖）：" & JvmArgs)
Logger.Info($"迁移 MultiMC 版本独立设置：JVM 参数（覆盖）：{JvmArgs}")
Else
JvmArgs += " " & Settings.Get("LaunchAdvanceJvm")
JvmArgs += " " & Settings.Get(Of String)("LaunchAdvanceJvm")
WriteIni(SetupFile, "VersionAdvanceJvm", JvmArgs)
Log("[ModPack] 迁移 MultiMC 版本独立设置：JVM 参数（追加）：" & JvmArgs)
Logger.Info($"迁移 MultiMC 版本独立设置：JVM 参数（追加）：{JvmArgs}")
End If
End If
End If
Catch ex As Exception
Log(ex, $"读取 MMC 配置文件失败（{InstallTemp}{ArchiveBaseFolder}instance.cfg）")
Logger.Warn(ex, $"读取 MMC 配置文件失败（{InstallTemp}{ArchiveBaseFolder}instance.cfg）")
End Try
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
End Sub) With {.ProgressWeight = FileUtils.GetInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造版本安装请求
If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息，无法安装！")
Dim Request As New McInstallRequest With {.NewInstanceName = InstanceName, .VersionFolder = $"{McFolderSelected}versions\{InstanceName}\"}
@@ -674,7 +668,7 @@ Retry:
'Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
Case Else
If UID.StartsWithF("org.lwjgl") Then '#8210
Log("[ModPack] 已跳过 LWJGL 项：" & UID)
Logger.Info($"已跳过 LWJGL 项：{UID}")
Else
NotifyIncompatibleLoader(UID)
End If
@@ -710,7 +704,7 @@ Retry:
Dim Json As JObject
Try
Dim Entry = If(Archive.GetEntry(ArchiveBaseFolder & "mcbbs.packmeta"), Archive.GetEntry(ArchiveBaseFolder & "manifest.json"))
Json = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
Json = GetJson(Entry.Open().ReadString(Encoding.UTF8))
Catch ex As Exception
Throw New Exception("MCBBS 整合包安装信息存在问题", ex)
End Try
@@ -731,15 +725,14 @@ Retry:
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
CopyOverrideDirectory(
InstallTemp & ArchiveBaseFolder & "overrides",
McFolderSelected & "versions\" & InstanceName,
Task, 0.4)
McFolderSelected & "versions\" & InstanceName, Task)
'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
End Sub) With {.ProgressWeight = FileUtils.GetInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'构造加载器
If Json("addons") Is Nothing Then Throw New Exception("该 MCBBS 整合包未提供游戏版本附加信息，无法安装！")
Dim Addons As New Dictionary(Of String, String)
@@ -787,9 +780,9 @@ Retry:
Private Function InstallPackLauncherPack(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'获取解压路径
MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True)
Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）")
If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException
Dim TargetFolder As String = Dialogs.SelectFolder("选择安装目标（必须是一个空文件夹）", False).FirstOrDefault
If TargetFolder Is Nothing Then Throw New CancelledException
If Not DirectoryUtils.IsEmpty(TargetFolder) Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException
'解压
Dim Loader As New LoaderCombo(Of String)("解压压缩包", {
New LoaderTask(Of String, Integer)("解压压缩包",
@@ -799,42 +792,42 @@ Retry:
Thread.Sleep(400) '避免文件争用
'查找解压后的 exe 文件
Dim Launcher As String = Nothing
For Each ExeFile In Directory.GetFiles(TargetFolder, "*.exe", SearchOption.TopDirectoryOnly)
For Each ExeFile In DirectoryUtils.GetFiles(TargetFolder, True, "*.exe")
Dim Info = FileVersionInfo.GetVersionInfo(ExeFile)
Log($"[Modpack] 文件 {ExeFile} 的产品名标识为 {Info.ProductName}")
Logger.Info($"文件 {ExeFile} 的产品名标识为 {Info.ProductName}")
If Info.ProductName = "Plain Craft Launcher" Then
Launcher = ExeFile
Log($"[Modpack] 发现整合包附带的 PCL 启动器：{ExeFile}")
Logger.Info($"发现整合包附带的 PCL 启动器：{ExeFile}")
ElseIf (Info.ProductName.ContainsIgnoreCase("Launcher") OrElse Info.ProductName.Contains("启动")) AndAlso
Not Info.ProductName = "Plain Craft Launcher Admin Manager" Then
If Launcher Is Nothing Then
Launcher = ExeFile
Log($"[Modpack] 发现整合包附带的疑似第三方启动器：{ExeFile}")
Logger.Info($"发现整合包附带的疑似第三方启动器：{ExeFile}")
End If
End If
Next
Task.Progress = 0.95
'尝试使用附带的启动器打开
If Launcher IsNot Nothing Then
Log("[Modpack] 找到压缩包中附带的启动器：" & Launcher)
Logger.Info($"找到压缩包中附带的启动器：{Launcher}")
If MyMsgBox($"整合包里似乎自带了启动器，是否换用它继续安装？{vbCrLf}即将打开：{Launcher}", "换用整合包启动器？", "换用", "不换用") = 1 Then
StartProcess(Launcher, "--wait") '要求等待已有的 PCL 退出
Log("[Modpack] 为换用整合包中的启动器启动，强制结束程序")
Logger.Info("为换用整合包中的启动器启动，强制结束程序")
FrmMain.EndProgram(False)
Return
End If
Else
Log("[Modpack] 未找到压缩包中附带的启动器")
Logger.Info("未找到压缩包中附带的启动器")
End If
'加入文件夹列表
Dim InstanceName As String = GetFolderNameFromPath(TargetFolder)
Dim InstanceName As String = PathUtils.GetLastPart(TargetFolder)
DirectoryUtils.Create(TargetFolder & ".minecraft\")
PageSelectLeft.AddFolder(
TargetFolder & ".minecraft\" & ArchiveBaseFolder.Replace("/", "\").TrimStart("\"), '格式例如：包裹文件夹\.minecraft\（最短为空字符串）
InstanceName, False)
'调用 modpack 文件进行安装
Dim ModpackFile = Directory.GetFiles(TargetFolder, "modpack.*", SearchOption.AllDirectories).First
Log("[Modpack] 调用 modpack 文件继续安装：" & ModpackFile)
Dim ModpackFile = DirectoryUtils.GetFiles(TargetFolder, "modpack.*").First
Logger.Info($"调用 modpack 文件继续安装：{ModpackFile}")
ModpackInstall(ModpackFile)
End Sub)
})
@@ -859,20 +852,20 @@ Retry:
Next
If Match Is Nothing Then Throw New Exception("文件结构不匹配，这可能不是 Minecraft 客户端压缩包？") '没有匹配
Dim ArchiveBaseFolder As String = Match.Value.Replace("/", "\").TrimStart("\") '格式例如：包裹文件夹\.minecraft\（最短为空字符串）
Log("[ModPack] 检测到压缩包的 .minecraft 根目录：" & ArchiveBaseFolder & "，命中的版本名：" & Match.Groups(1).Value)
Logger.Info($"检测到压缩包的 .minecraft 根目录：{ArchiveBaseFolder}，命中的版本名：{Match.Groups(1).Value}")
'获取解压路径
MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True)
Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）")
If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException
Dim TargetFolder As String = Dialogs.SelectFolder("选择安装目标（必须是一个空文件夹）", False).FirstOrDefault
If TargetFolder Is Nothing Then Throw New CancelledException
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Red) : Throw New CancelledException
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException
If Not DirectoryUtils.IsEmpty(TargetFolder) Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException
'解压
Dim Loader As New LoaderCombo(Of String)("解压压缩包", {
New LoaderTask(Of String, Integer)("解压压缩包",
Sub(Task As LoaderTask(Of String, Integer))
ExtractModpackFiles(TargetFolder, FileAddress, Task, 0.95)
'加入文件夹列表
PageSelectLeft.AddFolder(TargetFolder & ArchiveBaseFolder, GetFolderNameFromPath(TargetFolder), False)
PageSelectLeft.AddFolder(TargetFolder & ArchiveBaseFolder, PathUtils.GetLastPart(TargetFolder), False)
Thread.Sleep(400) '避免文件争用
RunInUi(Sub() FrmMain.PageChange(FormMain.PageType.InstanceSelect))
End Sub)
Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb
+19 -18
View File
@@ -33,13 +33,13 @@
HasRunningMinecraft = False
FrmMain.BtnExtraShutdown.ShowRefresh()
'音乐播放
If Settings.Get("UiMusicStop") Then
RunInUi(Sub() If MusicResume() Then Log("[Music] 已根据设置，在结束后开始音乐播放"))
ElseIf Settings.Get("UiMusicStart") Then
RunInUi(Sub() If MusicPause() Then Log("[Music] 已根据设置，在结束后暂停音乐播放"))
If Settings.Get(Of Boolean)("UiMusicStop") Then
RunInUi(Sub() If MusicResume() Then Logger.Info("已根据设置，在结束后开始音乐播放"))
ElseIf Settings.Get(Of Boolean)("UiMusicStart") Then
RunInUi(Sub() If MusicPause() Then Logger.Info("已根据设置，在结束后暂停音乐播放"))
End If
'启动器可见性
Select Case Settings.Get("LaunchArgumentVisible")
Select Case Settings.Get(Of Integer)("LaunchArgumentVisible")
Case 2
'直接关闭
If TriggerLauncherShutdown Then
@@ -105,7 +105,7 @@
Loop
WatcherLog("Minecraft 日志监控已退出")
Catch ex As Exception
Log(ex, "Minecraft 日志监控主循环出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "Minecraft 日志监控主循环出错")
State = MinecraftState.Ended
End Try
End Sub, "Minecraft Watcher PID " & PID)
@@ -174,7 +174,7 @@
End If
End If
Catch ex As Exception
Log(ex, "输出 Minecraft 日志失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "输出 Minecraft 日志失败")
End Try
End Sub
Public LatestLog As New Queue(Of String)
@@ -186,6 +186,7 @@
'加入预存储
LatestLog.Enqueue(Text)
If LatestLog.Count >= 501 Then LatestLog.Dequeue()
Logger.Trace(Text)
'进度处理
If LogProgress < 1 Then
WatcherLog("日志 1/5：已出现日志输出")
@@ -265,7 +266,7 @@
MinecraftWindow = TryGetMinecraftWindow()
Catch ex As ComponentModel.Win32Exception
'拒绝访问（#1062）
Log(ex, "由于反作弊或安全软件拦截，PCL 无法操作游戏窗口", NotifyLevel.AllUsers)
Logger.Error(ex, "由于反作弊或安全软件拦截，PCL 无法操作游戏窗口", LogBehavior.Toast)
IsWindowFinished = True
End Try
If MinecraftWindow Is Nothing Then Return
@@ -277,7 +278,7 @@
WatcherLog($"Minecraft 窗口已加载：{MinecraftWindowName}（{MinecraftWindowHandle.ToInt64}）")
IsWindowFinished = True
'最大化
If Settings.Get("LaunchArgumentWindowType") = 4 Then
If Settings.Get(Of Integer)("LaunchArgumentWindowType") = 4 Then
RunInNewThread(
Sub()
Try
@@ -287,7 +288,7 @@
ShowWindow(WindowHandle, 3)
WatcherLog($"已最大化 Minecraft 窗口：{MinecraftWindowHandle.ToInt64}")
Catch ex As Exception
Log(ex, "最大化 Minecraft 窗口时出现错误")
Logger.Warn(ex, "最大化 Minecraft 窗口时出现错误")
End Try
End Sub, "MinecraftWindowMaximize")
End If
@@ -297,7 +298,7 @@
End If
IsWindowAppeared = True
Catch ex As Exception
Log(ex, "检查 Minecraft 窗口失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "检查 Minecraft 窗口失败")
End Try
End Sub
''' <summary>
@@ -305,10 +306,10 @@
''' Nothing 代表未找到。
''' </summary>
Private Function TryGetMinecraftWindow() As KeyValuePair(Of IntPtr, String)?
TryGetMinecraftWindow = Nothing
Dim Result = Nothing
EnumWindows(
Sub(hwnd As IntPtr, lParam As Integer)
If TryGetMinecraftWindow IsNot Nothing Then Return
If Result IsNot Nothing Then Return
'检查类名
Dim str As New StringBuilder(512)
GetClassName(hwnd, str, str.Capacity)
@@ -327,13 +328,13 @@
Try
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Return '需要是此后启动的进程
Catch ex As Exception
Log(ex, "枚举 Minecraft 窗口进程失败")
Logger.Warn(ex, "枚举 Minecraft 窗口进程失败")
Return
End Try
'返回
TryGetMinecraftWindow = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText)
Result = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText)
End Sub, 0)
Return TryGetMinecraftWindow
Return Result
End Function
Private Delegate Sub EnumWindowsSub(hwnd As IntPtr, lParam As Integer)
Private Declare Function EnumWindows Lib "user32" (hWnd As EnumWindowsSub, lParam As Integer) As Boolean
@@ -363,7 +364,7 @@
Analyzer.Output(False, New List(Of String) From
{Instance.PathVersion & Instance.Name & ".json", PathExeFolder & "PCL\Log1.txt", PathExeFolder & "PCL\LatestLaunch.bat"})
Catch ex As Exception
Log(ex, "崩溃分析失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "崩溃分析失败")
End Try
End Sub, "Crash Analyzer")
End Sub
@@ -376,7 +377,7 @@
If Not GameProcess.HasExited Then GameProcess.Kill()
WatcherLog("已强制结束 Minecraft 进程")
Catch ex As Exception
Log(ex, "强制结束 Minecraft 进程失败", NotifyLevel.AllUsers)
Logger.Error(ex, "强制结束 Minecraft 进程失败", LogBehavior.Toast)
End Try
End Sub
Plain Craft Launcher 2/Modules/ModEvent.vb
+16 -16
View File
@@ -175,7 +175,7 @@ Public Class CustomEvent
''' </summary>
Public Shared Sub Raise(Type As EventType, Arg As String)
If Type = EventType.None Then Return
Log($"[Control] 执行自定义事件：{Type}, {Arg}")
Logger.Info($"执行自定义事件：{Type}, {Arg}")
If Arg Is Nothing Then Arg = ""
Dim Args As String() = Arg.Split("|")
Try
@@ -196,7 +196,7 @@ Public Class CustomEvent
'确认实际路径
Dim ActualPaths = GetAbsoluteUrls(Args(0), Type)
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
Log($"[Control] 打开类自定义事件实际路径：{Location}，工作目录：{WorkingDir}")
Logger.Info($"打开类自定义事件实际路径：{Location}，工作目录：{WorkingDir}")
'执行
If Type = EventType.打开帮助 Then
PageOtherHelp.EnterHelpPage(Location)
@@ -210,7 +210,7 @@ Public Class CustomEvent
StartProcess(Info)
End If
Catch ex As Exception
Log(ex, "执行打开类自定义事件失败", NotifyLevel.MsgBox)
Logger.Error(ex, "执行打开类自定义事件失败", LogBehavior.Alert)
End Try
End Sub)
@@ -289,7 +289,7 @@ Public Class CustomEvent
Try
Select Case Args.Length
Case 1
PageOtherTest.StartCustomDownload(Args(0), GetFileNameFromPath(Args(0)))
PageOtherTest.StartCustomDownload(Args(0), PathUtils.GetLastPart(Args(0)))
Case 2
PageOtherTest.StartCustomDownload(Args(0), Args(1))
Case Else
@@ -328,7 +328,7 @@ Public Class CustomEvent
MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败")
End Select
Catch ex As Exception
Log(ex, $"事件执行失败（{Type}, {Arg}）", NotifyLevel.MsgBox)
Logger.Error(ex, $"事件执行失败（{Type}, {Arg}）", LogBehavior.Alert)
End Try
End Sub
@@ -346,7 +346,7 @@ Public Class CustomEvent
'获取文件名
Dim RawFileName As String
Try
RawFileName = GetFileNameFromPath(RelativeUrl)
RawFileName = PathUtils.GetLastPart(RelativeUrl)
If Not RawFileName.EndsWithF(".json", True) Then Throw New Exception("未指向 .json 后缀的文件")
Catch ex As Exception
Throw New Exception("联网帮助页面须指向一个帮助 JSON 文件，并在同路径下包含相应 XAML 文件！" & vbCrLf &
@@ -356,7 +356,7 @@ Public Class CustomEvent
End Try
'下载文件
Dim LocalTemp As String = RequestTaskTempFolder() & RawFileName
Log("[Event] 转换网络资源：" & RelativeUrl & " -> " & LocalTemp)
Logger.Info($"转换网络资源：{RelativeUrl} -> {LocalTemp}")
Try
NetDownloadByClient(RelativeUrl, LocalTemp)
NetDownloadByClient(RelativeUrl.Replace(".json", ".xaml"), LocalTemp.Replace(".json", ".xaml"))
@@ -377,25 +377,25 @@ Public Class CustomEvent
If RelativeUrl.Contains(":\") Then
'绝对路径
Location = RelativeUrl
Log("[Control] 自定义事件中由绝对路径" & Type & "：" & Location)
ElseIf File.Exists(PathExeFolder & "PCL\" & RelativeUrl) Then
Logger.Info($"自定义事件中由绝对路径{Type}：{Location}")
ElseIf FileUtils.Exists(PathExeFolder & "PCL\" & RelativeUrl) Then
'相对 PCL 文件夹的路径
Location = PathExeFolder & "PCL\" & RelativeUrl
Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & Type & "：" & Location)
ElseIf File.Exists(PathExeFolder & "PCL\Help\" & RelativeUrl) Then
Logger.Info($"自定义事件中由相对 PCL 文件夹的路径{Type}：{Location}")
ElseIf FileUtils.Exists(PathExeFolder & "PCL\Help\" & RelativeUrl) Then
'相对 PCL 本地帮助文件夹的路径
Location = PathExeFolder & "PCL\Help\" & RelativeUrl
WorkingDir = PathExeFolder & "PCL\Help\"
Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & Type & "：" & Location)
ElseIf Type = EventType.打开帮助 AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then
Logger.Info($"自定义事件中由相对 PCL 本地帮助文件夹的路径{Type}：{Location}")
ElseIf Type = EventType.打开帮助 AndAlso FileUtils.Exists(PathTemp & "Help\" & RelativeUrl) Then
'相对 PCL 自带帮助文件夹的路径
Location = PathTemp & "Help\" & RelativeUrl
WorkingDir = PathTemp & "Help\"
Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & Type & "：" & Location)
Logger.Info($"自定义事件中由相对 PCL 自带帮助文件夹的路径{Type}：{Location}")
ElseIf Type = EventType.打开文件 OrElse Type = EventType.执行命令 Then
'直接使用原有路径启动程序
Location = RelativeUrl
Log("[Control] 自定义事件中直接" & Type & "：" & Location)
Logger.Info($"自定义事件中直接{Type}：{Location}")
Else
'打开帮助，但是格式不对劲
Throw New FileNotFoundException("未找到 EventData 指向的本地 xaml 文件：" & RelativeUrl, RelativeUrl)
@@ -408,7 +408,7 @@ Public Class CustomEvent
''' 弹出安全确认弹窗。返回是否继续执行。
''' </summary>
Private Shared Function EventSafetyConfirm(Message As String) As Boolean
If Settings.Get("HintCustomCommand") Then Return True
If Settings.Get(Of Boolean)("HintCustomCommand") Then Return True
Select Case MyMsgBox(Message & vbCrLf & "请在确认没有安全隐患后再继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消")
Case 1
Return True
Plain Craft Launcher 2/Modules/ModMain.vb
+108 -59
View File
@@ -133,11 +133,11 @@ Public Module ModMain
End If
'结束处理
EndHint:
If CurrentHint.Log Then Log("[UI] 弹出提示：" & CurrentHint.Text)
If CurrentHint.Log Then Logger.Info($"弹出提示：{CurrentHint.Text}")
HintWaiting.RemoveAt(0)
Loop
Catch ex As Exception
Log(ex, "显示弹出提示失败", NotifyLevel.Silent)
Logger.Info(ex, "显示弹出提示失败")
End Try
End Sub
Private Sub HideAllHint()
@@ -256,7 +256,7 @@ EndHint:
MsgBox(Caption, MsgBoxStyle.OkOnly + If(IsWarn, MsgBoxStyle.Critical, MsgBoxStyle.Question), Title)
Converter.Result = 1
End If
Log("[Control] 主窗体加载完成前出现意料外的等待弹窗：" & Button1 & "," & Button2 & "," & Button3, NotifyLevel.DebugModeOnly)
Logger.Warn($"主窗体加载完成前出现意料外的等待弹窗：{Button1},{Button2},{Button3}")
Else
Try
FrmMain.DragStop()
@@ -267,7 +267,7 @@ EndHint:
ComponentDispatcher.PopModal()
End Try
End If
Log("[Control] 普通弹框返回：" & If(Converter.Result, "null"))
Logger.Info($"普通弹框返回：{If(Converter.Result, "null")}")
Return Converter.Result
Else
'不进行等待，直接返回
@@ -298,7 +298,7 @@ EndHint:
Finally
ComponentDispatcher.PopModal()
End Try
Log("[Control] 输入弹框返回：" & If(Converter.Result, "null"))
Logger.Info($"输入弹框返回：{If(Converter.Result, "null")}")
Return Converter.Result
End Function
''' <summary>
@@ -321,7 +321,7 @@ EndHint:
Finally
ComponentDispatcher.PopModal()
End Try
Log("[Control] 选择弹框返回：" & If(Converter.Result, "null"))
Logger.Info($"选择弹框返回：{If(Converter.Result, "null")}")
Return Converter.Result
End Function
@@ -354,7 +354,7 @@ EndHint:
If FrmMain.PanMsg.Visibility <> Visibility.Collapsed Then FrmMain.PanMsg.Visibility = Visibility.Collapsed
End If
Catch ex As Exception
Log(ex, "处理等待中的弹窗失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "处理等待中的弹窗失败")
End Try
End Sub
@@ -488,8 +488,8 @@ EndHint:
''' </summary>
Public Sub New(FilePath As String)
RawPath = FilePath
Dim JsonData As JObject = GetJson(ArgumentReplace(ReadFile(FilePath), AddressOf EscapeUtils.XmlEscape))
If JsonData Is Nothing Then Throw New FileNotFoundException("未找到帮助文件：" & FilePath, FilePath)
If Not FileUtils.Exists(FilePath) Then Throw New FileNotFoundException("未找到帮助文件：" & FilePath, FilePath)
Dim JsonData As JObject = GetJson(ArgumentReplace(FileUtils.ReadAsString(FilePath), AddressOf EscapeUtils.XmlEscape))
'加载常规信息
If JsonData("Title") IsNot Nothing Then
Title = JsonData("Title")
@@ -508,13 +508,13 @@ EndHint:
Next
'加载事件信息
If If(JsonData("IsEvent"), False) Then
EventType = [Enum].Parse(GetType(CustomEvent.EventType), JsonData("EventType").ToString)
EventType = JsonData("EventType").ToObject(Of CustomEvent.EventType)
EventData = If(JsonData("EventData"), "")
IsEvent = True
Else
Dim XamlAddress As String = FilePath.Lower.Replace(".json", ".xaml")
If File.Exists(XamlAddress) Then
XamlContent = ReadFile(XamlAddress)
If FileUtils.Exists(XamlAddress) Then
XamlContent = FileUtils.ReadAsString(XamlAddress)
IsEvent = False
Else
Throw New FileNotFoundException("未找到帮助条目 .json 对应的 .xaml 文件（" & XamlAddress & "）")
@@ -577,42 +577,42 @@ EndHint:
Try
Dim IgnoreList As New List(Of String)
'读取自定义文件
If Directory.Exists(PathExeFolder & "PCL\Help\") Then
For Each File In EnumerateFiles(PathExeFolder & "PCL\Help\")
Select Case File.Extension.Lower
Case ".helpignore"
If DirectoryUtils.Exists(PathExeFolder & "PCL\Help\") Then
For Each File In DirectoryUtils.GetFiles(PathExeFolder & "PCL\Help\")
Select Case PathUtils.GetExtension(File)
Case "helpignore"
'加载忽略列表
Log("[Help] 发现 .helpignore 文件：" & File.FullName)
For Each Line In ReadFile(File.FullName).Split(vbCrLf.ToCharArray)
Logger.Info($"发现 .helpignore 文件：{File}")
For Each Line In FileUtils.ReadAsLines(File, True)
Dim RealString As String = Line.BeforeFirst("#").Trim
If String.IsNullOrWhiteSpace(RealString) Then Continue For
IgnoreList.Add(RealString)
If ModeDebug Then Log("[Help] > " & RealString)
Logger.Trace($"> {RealString}")
Next
Case ".json"
FileList.Add(File.FullName)
Case "json"
FileList.Add(File)
End Select
Next
End If
Log("[Help] 已扫描 PCL 文件夹下的帮助文件，目前总计 " & FileList.Count & " 条")
Logger.Info($"已扫描 PCL 文件夹下的帮助文件，目前总计 {FileList.Count} 条")
'读取自带文件
For Each File In EnumerateFiles(PathTemp & "Help")
For Each File In DirectoryUtils.GetFiles(PathTemp & "Help")
'跳过非 json 文件与以 . 开头的文件夹
If File.Extension.Lower <> ".json" OrElse File.Directory.FullName.Replace(PathTemp & "Help", "").Contains("\.") Then Continue For
If PathUtils.RemoveLastPart(File).Replace(PathTemp & "Help", "").Contains("\.") OrElse PathUtils.GetExtension(File) <> "json" Then Continue For
'检查忽略列表
Dim RealPath As String = File.FullName.Replace(PathTemp & "Help\", "")
Dim RealPath As String = File.Replace(PathTemp & "Help\", "")
For Each Ignore In IgnoreList
If RegexCheck(RealPath, Ignore) Then
If ModeDebug Then Log("[Help] 已忽略 " & RealPath & "：" & Ignore)
If RealPath.RegexCheck(Ignore) Then
Logger.Trace($"已忽略 {RealPath}：{Ignore}")
GoTo NextFile
End If
Next
FileList.Add(File.FullName)
FileList.Add(File)
NextFile:
Next
Log("[Help] 已扫描缓存文件夹下的帮助文件，目前总计 " & FileList.Count & " 条")
Logger.Info($"已扫描缓存文件夹下的帮助文件，目前总计 {FileList.Count} 条")
Catch ex As Exception
Log(ex, "检查帮助文件夹失败", NotifyLevel.MsgBox)
Logger.Error(ex, "检查帮助文件夹失败", LogBehavior.Alert)
End Try
If Loader.IsInterrupted Then Return
@@ -622,9 +622,9 @@ NextFile:
Try
Dim Entry As New HelpEntry(FilePath)
Dict.Add(Entry)
If ModeDebug Then Log("[Help] 已加载的帮助条目：" & Entry.Title & " ← " & FilePath)
Logger.Trace($"已加载的帮助条目：{Entry.Title} ← {FilePath}")
Catch ex As Exception
Log(ex, "初始化帮助条目失败（" & FilePath & "）", NotifyLevel.MsgBox)
Logger.Error(ex, $"初始化帮助条目失败（{FilePath}）", LogBehavior.Alert)
End Try
Next
@@ -634,7 +634,7 @@ NextFile:
Loader.Output = Dict
Catch ex As Exception
Log(ex, "帮助列表初始化失败")
Logger.Warn(ex, "帮助列表初始化失败")
Throw
End Try
End SyncLock
@@ -643,13 +643,12 @@ NextFile:
''' 尝试解压内置帮助文件。
''' </summary>
Public Sub HelpTryExtract()
If Settings.Get("SystemHelpVersion") <> VersionCode OrElse Not File.Exists(PathTemp & "Help\启动器\备份设置.xaml") Then
DeleteDirectory(PathTemp & "Help")
DirectoryUtils.Create(PathTemp & "Help")
FileUtils.Write(PathTemp & "Cache\Help.zip", GetResources("Help"))
ExtractCompressedFile(PathTemp & "Cache\Help.zip", PathTemp & "Help")
If Settings.Get(Of Integer)("SystemHelpVersion") <> VersionCode OrElse Not FileUtils.Exists(PathTemp & "Help\启动器\备份设置.xaml") Then
DirectoryUtils.Delete(PathTemp & "Help")
ExtractResources(PathTemp & "Cache\Help.zip", "Help")
FileUtils.ExtractToDirectory(PathTemp & "Cache\Help.zip", PathTemp & "Help")
Settings.Set("SystemHelpVersion", VersionCode)
Log("[Help] 已解压内置帮助文件，目前状态：" & File.Exists(PathTemp & "Help\启动器\备份设置.xaml"), NotifyLevel.DebugModeOnly)
Logger.Warn($"已解压内置帮助文件，目前状态：{FileUtils.Exists(PathTemp & "Help\启动器\备份设置.xaml")}")
End If
End Sub
@@ -663,7 +662,7 @@ NextFile:
If _IsAprilEnabled Is Nothing Then
_IsAprilEnabled =
Date.Now.Month = 4 AndAlso Date.Now.Day = 1 AndAlso
Settings.Get("AprilDoneYear") <> Date.Now.Year '成功后同年内则不再触发
Settings.Get(Of Integer)("AprilDoneYear") <> Date.Now.Year '成功后同年内则不再触发
End If
Return _IsAprilEnabled.Value
End Get
@@ -774,7 +773,7 @@ NextFile:
End If
Catch ex As Exception
Log(ex, "愚人节移动出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "愚人节移动出错")
End Try
End Sub
@@ -790,7 +789,7 @@ NextFile:
PostMessage(Handle, 400 * 16 + 2, 0, 0)
SetForegroundWindow(Handle) '不在这里放不行，神秘 WinAPI，建议别动
Catch ex As Exception
Log(ex, "设置窗口置顶失败", NotifyLevel.AllUsers)
Logger.Error(ex, "设置窗口置顶失败", LogBehavior.Toast)
End Try
End Sub
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ClassName As String, WindowName As String) As IntPtr
@@ -808,19 +807,19 @@ NextFile:
Using ReadOnlyKey = My.Computer.Registry.CurrentUser.OpenSubKey(REG_KEY, False)
If ReadOnlyKey IsNot Nothing Then
If REG_VALUE = ReadOnlyKey.GetValue(Executeable)?.ToString() Then
Log($"[System] 无需调整显卡设置：{Executeable}")
Logger.Info($"无需调整显卡设置：{Executeable}")
Return
End If
Else
'创建父级键
Log($"[System] 需要创建显卡设置的父级键")
Logger.Info($"需要创建显卡设置的父级键")
My.Computer.Registry.CurrentUser.CreateSubKey(REG_KEY)
End If
End Using
'写入新设置
Using WriteKey = My.Computer.Registry.CurrentUser.OpenSubKey(REG_KEY, True)
WriteKey.SetValue(Executeable, REG_VALUE)
Log($"[System] 已调整显卡设置：{Executeable}")
Logger.Info($"已调整显卡设置：{Executeable}")
End Using
End Sub
@@ -829,12 +828,16 @@ NextFile:
''' </summary>
Public Function ArgumentReplace(Text As String, Optional EscapeHandler As Func(Of String, String) = Nothing, Optional ReplaceTime As Boolean = True) As String
If Text Is Nothing OrElse Not Text.Contains("{") Then Return Text
'预处理
'预处理（注意，文件夹必须以 \ 结尾）
Static Replacer As Func(Of String, String) =
Function(s As String) As String
If s Is Nothing Then Return ""
If EscapeHandler Is Nothing Then Return s
If s.Contains(":\") Then s = FileUtils.ShortenPath(s)
If s.Contains(":\") Then
Dim IsFolder = s.EndsWithF("\") OrElse s.EndsWithF("/")
s = PathUtils.ToShortPath(s)
If IsFolder Then s = PathUtils.AddSlashSuffix(s)
End If
Return EscapeHandler(s)
End Function
'基础
@@ -844,10 +847,10 @@ NextFile:
Text = Text.Replace("{pcl_build_type}", Replacer(BuildType.ToString))
Text = Text.Replace("{pcl_branch}", Replacer(VersionBranchMain))
Text = Text.Replace("{identify}", Replacer(Identify))
Text = Text.Replace("{path}", Replacer(PathExeFolder))
Text = Text.Replace("{path}", Replacer(PathUtils.CurrentFolder))
Text = Text.Replace("{path_with_name}", Replacer(PathExe))
Text = Text.Replace("{path_temp}", Replacer(PathTemp))
Text = Text.ReplaceOnDemand("{pcl_md5}", Function() Replacer(GetFileMD5(PathExe)))
Text = Text.Replace("{pcl_md5}", Function() Replacer(HashUtils.ComputeFromFile(PathExe, HashUtils.HashMethod.Md5)))
'时间
If ReplaceTime Then '在窗口标题中，时间会被后续动态替换，所以此时不应该替换
Text = Text.Replace("{date}", Replacer(Date.Now.ToString("yyyy'/'M'/'d")))
@@ -915,12 +918,12 @@ NextFile:
IsTaskTempCleared = True
IsTaskTempClearing = True
Try
Log("[System] 开始清理任务缓存文件夹")
DeleteDirectory($"{OsDrive}ProgramData\PCL\TaskTemp\")
DeleteDirectory($"{PathTemp}TaskTemp\")
Log("[System] 已清理任务缓存文件夹")
Logger.Info("开始清理任务缓存文件夹")
DirectoryUtils.Delete($"{OsDrive}ProgramData\PCL\TaskTemp\")
DirectoryUtils.Delete($"{PathTemp}TaskTemp\")
Logger.Info("已清理任务缓存文件夹")
Catch ex As Exception
Log(ex, "清理任务缓存文件夹失败")
Logger.Warn(ex, "清理任务缓存文件夹失败")
Finally
IsTaskTempClearing = False
End Try
@@ -955,6 +958,52 @@ NextFile:
Return ResultFolder
End Function
#End Region
#Region "反馈与遥测"
'反馈
Public Sub Feedback(Optional ShowMsgbox As Boolean = True, Optional ForceOpenLog As Boolean = False)
On Error Resume Next
FeedbackInfo()
If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug，请点击 打开文件夹 按钮，并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关，请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then
OpenExplorer(PathExeFolder & "PCL\Log1.txt")
End If
OpenWebsite("https://github.com/Meloong-Git/PCL/issues/")
End Sub
''' <summary>
''' 在日志中输出系统诊断信息。
''' </summary>
Public Sub FeedbackInfo()
On Error Resume Next
Logger.Info($"诊断信息：{vbCrLf}" &
"操作系统：" & My.Computer.Info.OSFullName & "（32 位：" & Is32BitSystem & "）" & vbCrLf &
"剩余内存：" & Int(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024) & " M / " & Int(My.Computer.Info.TotalPhysicalMemory / 1024 / 1024) & " M" & vbCrLf &
"DPI：" & DPI & "（" & Math.Round(DPI / 96, 2) * 100 & "%）" & vbCrLf &
"MC 文件夹：" & If(McFolderSelected, "Nothing") & vbCrLf &
"文件位置：" & PathExeFolder)
End Sub
'遥测
Public Sub Telemetry([Event] As String, ParamArray Datas As String())
If BuildType = BuildTypes.Debug Then Return '开发版不上传遥测
If Not Settings.Get(Of Boolean)("SystemSystemTelemetry") Then Return '用户关闭了遥测
If Not ClsBaseUrl.StartsWithF("http") Then Return '开源版没有设置遥测地址
RunInNewThread(
Sub()
Try
Logger.Info($"匿名数据上报：{[Event]}")
Dim Url As String = $"{ClsBaseUrl}&Event={EscapeUtils.UrlEscape([Event])}"
For i = 0 To Datas.Length - 1 Step 2
Url &= "&" & EscapeUtils.UrlEscape(Datas(i)) & "=" & EscapeUtils.UrlEscape(Datas(i + 1).ReplaceLineEndings(vbLf, mergeMultiple:=True))
Next
NetRequestByClient(Url, MakeLog:=False)
Catch ex As Exception
Logger.Warn(ex, "匿名数据上报失败")
End Try
End Sub, "Telemetry", ThreadPriority.Lowest)
End Sub
#End Region
Public DragControl = Nothing
@@ -970,7 +1019,7 @@ NextFile:
If ThemeDontClick = 2 Then ThemeRefresh()
#End Region
Catch ex As Exception
Log(ex, "短程主时钟执行异常", NotifyLevel.Critical)
Logger.Error(ex, "短程主时钟执行异常", LogBehavior.AlertThenCrash)
End Try
Timer4Count += 1
If Timer4Count = 4 Then
@@ -980,7 +1029,7 @@ NextFile:
If ThemeNow = 12 Then ThemeRefresh()
#End Region
Catch ex As Exception
Log(ex, "中程主时钟执行异常", NotifyLevel.DebugModeOnly)
Logger.Warn(ex, "中程主时钟执行异常")
End Try
End If
Timer150Count += 1
@@ -999,7 +1048,7 @@ NextFile:
End Sub)
#End Region
Catch ex As Exception
Log(ex, "长程主时钟执行异常", NotifyLevel.Critical)
Logger.Error(ex, "长程主时钟执行异常", LogBehavior.AlertThenCrash)
End Try
End If
End Sub
@@ -1012,7 +1061,7 @@ NextFile:
Thread.Sleep(50 * 0.98)
Loop
Catch ex As Exception
Log(ex, "程序主时钟出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "程序主时钟出错")
End Try
End Sub, "Timer Main")
If Not IsAprilEnabled Then Return
@@ -1028,7 +1077,7 @@ NextFile:
Thread.Sleep(1)
Loop
Catch ex As Exception
Log(ex, "愚人节主时钟出错", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "愚人节主时钟出错")
End Try
End Sub, "Timer Main Fool")
End Sub
Plain Craft Launcher 2/Modules/ModMusic.vb
+30 -29
View File
@@ -24,22 +24,21 @@ Public Module ModMusic
If MusicAllList Is Nothing Then
MusicAllList = New List(Of String)
DirectoryUtils.Create(PathExeFolder & "PCL\Musics\")
For Each File In EnumerateFiles(PathExeFolder & "PCL\Musics\")
For Each File In DirectoryUtils.GetFiles(PathExeFolder & "PCL\Musics\")
'文件夹可能会被加入 .ini 文件夹配置文件、一些乱七八糟的 .jpg 文件啥的
Dim Ext As String = File.Extension.Lower
If {".ini", ".jpg", ".txt", ".cfg", ".lrc", ".db", ".png"}.Contains(Ext) Then Continue For
MusicAllList.Add(File.FullName)
If {"ini", "jpg", "txt", "cfg", "lrc", "db", "png"}.Contains(PathUtils.GetExtension(File)) Then Continue For
MusicAllList.Add(File)
Next
End If
'打乱顺序播放
MusicWaitingList = If(Settings.Get("UiMusicRandom"), New List(Of String)(MusicAllList).Shuffle().ToList, New List(Of String)(MusicAllList))
MusicWaitingList = If(Settings.Get(Of Boolean)("UiMusicRandom"), New List(Of String)(MusicAllList).Shuffle().ToList, New List(Of String)(MusicAllList))
If PreventFirst IsNot Nothing AndAlso MusicWaitingList.FirstOrDefault = PreventFirst Then
'若需要避免成为第一项的为第一项，则将它放在最后
MusicWaitingList.RemoveAt(0)
MusicWaitingList.Add(PreventFirst)
End If
Catch ex As Exception
Log(ex, "初始化音乐列表失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "初始化音乐列表失败")
End Try
End Sub
''' <summary>
@@ -47,16 +46,18 @@ Public Module ModMusic
''' 如果没有，可能会返回 Nothing。
''' </summary>
Private Function DequeueNextMusicAddress() As String
Dim Result As String
'初始化，确保存在音乐
If MusicAllList Is Nothing OrElse Not MusicAllList.Any() OrElse Not MusicWaitingList.Any() Then MusicListInit(False)
'出列下一个音乐，如果出列结束则生成新列表
If MusicWaitingList.Any() Then
DequeueNextMusicAddress = MusicWaitingList(0)
Result = MusicWaitingList(0)
MusicWaitingList.RemoveAt(0)
Else
DequeueNextMusicAddress = Nothing
Result = Nothing
End If
If Not MusicWaitingList.Any() Then MusicListInit(False, DequeueNextMusicAddress)
If Not MusicWaitingList.Any() Then MusicListInit(False, Result)
Return Result
End Function
#End Region
@@ -81,7 +82,7 @@ Public Module ModMusic
If MusicState = MusicStates.Pause Then
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
FrmMain.BtnExtraMusic.LogoScale = 0.8
ToolTipText = "已暂停：" & Path.GetFileNameWithoutExtension(MusicCurrent)
ToolTipText = "已暂停：" & PathUtils.GetFileNameWithoutExtension(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键恢复播放，右键播放下一曲。"
Else
@@ -90,7 +91,7 @@ Public Module ModMusic
Else
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
FrmMain.BtnExtraMusic.LogoScale = 1
ToolTipText = "正在播放：" & Path.GetFileNameWithoutExtension(MusicCurrent)
ToolTipText = "正在播放：" & PathUtils.GetFileNameWithoutExtension(MusicCurrent)
If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键暂停，右键播放下一曲。"
Else
@@ -103,7 +104,7 @@ Public Module ModMusic
If FrmSetupUI IsNot Nothing Then FrmSetupUI.MusicRefreshUI()
Catch ex As Exception
Log(ex, "刷新背景音乐 UI 失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "刷新背景音乐 UI 失败")
End Try
End Sub)
End Sub
@@ -121,7 +122,7 @@ Public Module ModMusic
Case MusicStates.Play
MusicPause()
Case Else
Log("[Music] 音乐目前为停止状态，已强制尝试开始播放", NotifyLevel.DebugModeOnly)
Logger.Warn("音乐目前为停止状态，已强制尝试开始播放")
MusicRefreshPlay(False)
End Select
End If
@@ -133,14 +134,14 @@ Public Module ModMusic
Public Sub MusicControlNext()
If MusicAllList.IsSingle Then
MusicStartPlay(MusicCurrent)
Hint("重新播放：" & GetFileNameFromPath(MusicCurrent), HintType.Green)
Hint("重新播放：" & PathUtils.GetLastPart(MusicCurrent), HintType.Green)
Else
Dim Address As String = DequeueNextMusicAddress()
If Address Is Nothing Then
Hint("没有可以播放的音乐！", HintType.Red)
Else
MusicStartPlay(Address)
Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Green)
Hint("正在播放：" & PathUtils.GetLastPart(Address), HintType.Green)
End If
End If
MusicRefreshUI()
@@ -196,7 +197,7 @@ Public Module ModMusic
Else
Try
MusicStartPlay(Address, IsFirstLoad)
If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Green, False)
If ShowHint Then Hint("背景音乐已刷新：" & PathUtils.GetLastPart(Address), HintType.Green, False)
Catch
End Try
End If
@@ -204,7 +205,7 @@ Public Module ModMusic
MusicRefreshUI()
Catch ex As Exception
Log(ex, "刷新背景音乐播放失败", NotifyLevel.MsgBoxAndFeedback)
Logger.Error(ex, "刷新背景音乐播放失败")
End Try
End Sub
''' <summary>
@@ -212,7 +213,7 @@ Public Module ModMusic
''' </summary>
Private Sub MusicStartPlay(Address As String, Optional IsFirstLoad As Boolean = False)
If Address Is Nothing Then Return
Log("[Music] 播放开始：" & Address)
Logger.Info($"播放开始：{Address}")
MusicCurrent = Address
RunInNewThread(Sub() MusicLoop(IsFirstLoad), "Music", ThreadPriority.BelowNormal)
End Sub
@@ -226,13 +227,13 @@ Public Module ModMusic
If MusicState = MusicStates.Play Then
RunInThread(
Sub()
Log("[Music] 已暂停播放")
Logger.Info("已暂停播放")
MusicNAudio?.Pause()
MusicRefreshUI()
End Sub)
Return True
Else
Log($"[Music] 无需暂停播放，当前状态为 {MusicState}")
Logger.Info($"无需暂停播放，当前状态为 {MusicState}")
Return False
End If
End Function
@@ -241,12 +242,12 @@ Public Module ModMusic
''' </summary>
Public Function MusicResume() As Boolean
If MusicState = MusicStates.Play OrElse Not MusicAllList.Any() Then
Log($"[Music] 无需继续播放，当前状态为 {MusicState}")
Logger.Info($"无需继续播放，当前状态为 {MusicState}")
Return False
Else
RunInThread(
Sub()
Log("[Music] 已恢复播放")
Logger.Info("已恢复播放")
Try
MusicNAudio?.Play()
Catch 'https://github.com/Meloong-Git/PCL/pull/5415#issuecomment-2751135223
@@ -285,20 +286,20 @@ Public Module ModMusic
Try
Reader = New AudioFileReader(MusicCurrent)
Catch ex As Exception
Log(ex, "使用 AudioFileReader 加载音频文件失败，换用 MediaFoundationReader 重试", NotifyLevel.DevelopOnly)
Logger.Warn(ex, "使用 AudioFileReader 加载音频文件失败，换用 MediaFoundationReader 重试")
Reader = New MediaFoundationReader(MusicCurrent)
End Try
CurrentWave.Init(Reader)
CurrentWave.Play()
'第一次打开的暂停
If IsFirstLoad AndAlso Not Settings.Get("UiMusicAuto") Then CurrentWave.Pause()
If IsFirstLoad AndAlso Not Settings.Get(Of Boolean)("UiMusicAuto") Then CurrentWave.Pause()
MusicRefreshUI()
'停止条件：播放完毕或变化
Dim PreviousVolume = 0
While CurrentWave.Equals(MusicNAudio) AndAlso Not CurrentWave.PlaybackState = PlaybackState.Stopped
If Settings.Get("UiMusicVolume") <> PreviousVolume Then
If Settings.Get(Of Integer)("UiMusicVolume") <> PreviousVolume Then
'更新音量
PreviousVolume = Settings.Get("UiMusicVolume")
PreviousVolume = Settings.Get(Of Integer)("UiMusicVolume")
#Disable Warning BC40008 '类型或成员已过时
CurrentWave.Volume = PreviousVolume / 1000
#Enable Warning BC40008 '类型或成员已过时
@@ -311,7 +312,7 @@ Public Module ModMusic
'当前音乐已播放结束，继续下一曲
If CurrentWave.PlaybackState = PlaybackState.Stopped AndAlso MusicAllList.Any Then MusicStartPlay(DequeueNextMusicAddress)
Catch ex As Exception
Log(ex, "播放音乐出现内部错误（" & MusicCurrent & "）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"播放音乐出现内部错误（{MusicCurrent}）")
If TypeOf ex Is NAudio.MmException AndAlso ex.Message.Contains("AlreadyAllocated") Then
Hint("你的音频设备正被其他程序占用。请在关闭占用的程序后重启 PCL，才能恢复音乐播放功能！", HintType.Red)
Thread.Sleep(1000000000)
@@ -322,9 +323,9 @@ Public Module ModMusic
End If
If Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) OrElse
ex.Message.Contains("0xC00D36C4") Then '#5096：不支持给定的 URL 的字节流类型。 (异常来自 HRESULT:0xC00D36C4)
Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Red)
Hint("播放音乐失败（" & PathUtils.GetLastPart(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Red)
Else
Log(ex, "播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）", NotifyLevel.AllUsers)
Logger.Error(ex, $"播放音乐失败（{PathUtils.GetLastPart(MusicCurrent)}）", LogBehavior.Toast)
End If
'将播放错误的音乐从列表中移除
MusicAllList.Remove(MusicCurrent)
Plain Craft Launcher 2/Modules/ModSecret.vb
+5 -5
View File
@@ -150,7 +150,7 @@ Friend Module ModSecret
Application.Current.Resources("ColorObjectBg1") = CType(ColorBg1, Color)
ThemeRefreshMain()
Catch ex As Exception
Log(ex, "刷新主题颜色失败", NotifyLevel.AllUsers)
Logger.Warn(ex, "刷新主题颜色失败", NotifyLevel.AllUsers)
End Try
End Sub
Public Sub ThemeRefreshMain()
@@ -166,7 +166,7 @@ Friend Module ModSecret
FrmMain.PanTitle.Background = Brush
FrmMain.PanTitle.Background.Freeze()
'主页面背景
If Settings.Get("UiBackgroundColorful") Then
If Settings.Get(Of Boolean)("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 - 15, ColorSat * 0.8, 91)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.8, 91)})
@@ -219,16 +219,16 @@ Friend Module ModSecret
''' </summary>
Public ServerConfig As JObject
Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 配置更新", Sub() Log("[Server] 该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) With
Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 配置更新", Sub() Logger.Info("该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) With
{.ReloadTimeout = 1000 * 60 * 60} '超时 1 小时
#End Region
#Region "赞助等级"
Public ReadOnly Property DonationRank As DonationRanks
Public ReadOnly Property CurrentRank As DonationRank
Get
Return DonationRanks.None
Return DonationRank.None
End Get
End Property
Plain Craft Launcher 2/Modules/Resource/ResourceFile.vb → Plain Craft Launcher 2/Modules/Resource/LocalResourceFile.vb
+25 -26
View File
@@ -1,7 +1,7 @@
''' <summary>
''' 本地的社区资源文件。
''' </summary>
Public Class ResourceFile
Public Class LocalResourceFile
#Region "文件信息"
@@ -13,7 +13,7 @@ Public Class ResourceFile
Me.File = FileInfo
End Sub
Public Sub New(FullName As String)
Me.New(New FileInfo(FullName))
Me.New(FileUtils.GetInfo(FullName))
End Sub
''' <summary>
@@ -48,7 +48,7 @@ Public Class ResourceFile
''' <summary>
''' 在初始化结束之后，任何信息被后续更新时触发此事件。
''' </summary>
Public Event OnUpdate(sender As ResourceFile)
Public Event OnUpdate(sender As LocalResourceFile)
''' <summary>
''' 可读名称。
@@ -57,7 +57,7 @@ Public Class ResourceFile
Public Property Display As String
Get
If _Display Is Nothing Then _Display = ProjectVersion?.Display
If _Display Is Nothing Then _Display = Path.GetFileNameWithoutExtension(File.FullName)
If _Display Is Nothing Then _Display = PathUtils.GetFileNameWithoutExtension(File.FullName)
Return _Display
End Get
Set(value As String)
@@ -97,7 +97,7 @@ Public Class ResourceFile
Return _Version
End Get
Set(value As String)
If _Version IsNot Nothing AndAlso RegexCheck(_Version, "[0-9.\-]+") Then Return
If _Version IsNot Nothing AndAlso _Version.RegexCheck("[0-9.\-]+") Then Return
If value IsNot Nothing AndAlso value.ContainsIgnoreCase("version") Then value = "version" '需要修改的标识
_Version = value
End Set
@@ -118,16 +118,15 @@ Public Class ResourceFile
Dim Jar As ZipArchive = Nothing
Try
'基础可用性检查
If File.FullName.Length < 2 Then Throw New FileNotFoundException("错误的 Mod 文件路径（" & If(File.FullName, "null") & "）")
If Not IO.File.Exists(File.FullName) Then Throw New FileNotFoundException("未找到 Mod 文件（" & File.FullName & "）")
If Not FileUtils.Exists(File.FullName) Then Throw New FileNotFoundException("未找到 Mod 文件（" & File.FullName & "）")
'打开 Jar 文件
Jar = New ZipArchive(New FileStream(File.FullName, FileMode.Open, FileAccess.Read, FileShare.Read))
Jar = FileUtils.OpenZip(File.FullName)
'信息获取
LoadMetadataFromJar(Jar)
Catch ex As UnauthorizedAccessException
Log(ex, $"Mod 文件由于无权限无法打开（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"Mod 文件由于无权限无法打开（{File.FullName}）")
Catch ex As Exception
Log(ex, $"Mod 文件无法打开（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"Mod 文件无法打开（{File.FullName}）")
Finally
If Jar IsNot Nothing Then Jar.Dispose()
End Try
@@ -140,7 +139,7 @@ Public Class ResourceFile
Dim InfoEntry As ZipArchiveEntry = Jar.GetEntry("mcmod.info")
Dim InfoString As String = Nothing
If InfoEntry IsNot Nothing Then
InfoString = ReadFile(InfoEntry.Open())
InfoString = InfoEntry.Open().ReadString()
If InfoString.Length < 15 Then InfoString = Nothing
End If
If InfoString Is Nothing Then Exit Try
@@ -157,7 +156,7 @@ Public Class ResourceFile
Description = InfoObject("description")
Version = InfoObject("version")
Catch ex As Exception
Log(ex, $"读取 mcmod.info 时出现未知错误（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"读取 mcmod.info 时出现未知错误（{File.FullName}）")
End Try
#End Region
#Region "尝试使用 fabric.mod.json"
@@ -166,7 +165,7 @@ Public Class ResourceFile
Dim FabricEntry As ZipArchiveEntry = Jar.GetEntry("fabric.mod.json")
Dim FabricText As String = Nothing
If FabricEntry IsNot Nothing Then
FabricText = ReadFile(FabricEntry.Open(), Encoding.UTF8)
FabricText = FabricEntry.Open().ReadString(Encoding.UTF8)
If Not FabricText.Contains("schemaVersion") Then FabricText = Nothing
End If
If FabricText Is Nothing Then Exit Try
@@ -179,7 +178,7 @@ GotFabric:
'加载成功
GoTo Finished
Catch ex As Exception
Log(ex, "读取 fabric.mod.json 时出现未知错误（" & File.FullName & "）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"读取 fabric.mod.json 时出现未知错误（{File.FullName}）")
End Try
#End Region
#Region "尝试使用 mods.toml"
@@ -188,13 +187,13 @@ GotFabric:
Dim TomlEntry As ZipArchiveEntry = Jar.GetEntry("META-INF/mods.toml")
Dim TomlText As String = Nothing
If TomlEntry IsNot Nothing Then
TomlText = ReadFile(TomlEntry.Open())
TomlText = TomlEntry.Open().ReadString()
If TomlText.Length < 15 Then TomlText = Nothing
End If
If TomlText Is Nothing Then Exit Try
'文件标准化：统一换行符为 vbLf，去除注释、头尾的空格、空行
Dim Lines As New List(Of String)
For Each Line In TomlText.ReplaceLineEndings(vbLf).Split(vbLf) '统一换行符
For Each Line In TomlText.SplitLines(True)
If Line.StartsWithF("#") Then '去除注释
Continue For
ElseIf Line.Contains("#") Then
@@ -268,7 +267,7 @@ GotFabric:
'加载成功
GoTo Finished
Catch ex As Exception
Log(ex, $"读取 mods.toml 时出现未知错误（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"读取 mods.toml 时出现未知错误（{File.FullName}）")
End Try
#End Region
#Region "尝试使用 fml_cache_annotation.json"
@@ -277,7 +276,7 @@ GotFabric:
Dim FmlEntry As ZipArchiveEntry = Jar.GetEntry("META-INF/fml_cache_annotation.json")
Dim FmlText As String = Nothing
If FmlEntry IsNot Nothing Then
FmlText = ReadFile(FmlEntry.Open(), Encoding.UTF8)
FmlText = FmlEntry.Open().ReadString(Encoding.UTF8)
If Not FmlText.Contains("Lnet/minecraftforge/fml/common/Mod;") Then FmlText = Nothing
End If
If FmlText Is Nothing Then Exit Try
@@ -305,7 +304,7 @@ Got:
'加载成功
GoTo Finished
Catch ex As Exception
Log(ex, $"读取 fml_cache_annotation.json 时出现未知错误（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn(ex, $"读取 fml_cache_annotation.json 时出现未知错误（{File.FullName}）")
End Try
#End Region
Return '没能成功获取任何信息
@@ -316,7 +315,7 @@ Finished:
Try
Dim MetaEntry As ZipArchiveEntry = Jar.GetEntry("META-INF/MANIFEST.MF")
If MetaEntry IsNot Nothing Then
Dim MetaString As String = ReadFile(MetaEntry.Open()).Replace(" :", ":").Replace(": ", ":")
Dim MetaString As String = MetaEntry.Open().ReadString().Replace(" :", ":").Replace(": ", ":")
If MetaString.Contains("Implementation-Version:") Then
MetaString = MetaString.Substring(MetaString.IndexOfF("Implementation-Version:") + "Implementation-Version:".Count)
MetaString = MetaString.Substring(0, MetaString.IndexOfAny(vbCrLf.ToCharArray)).Trim
@@ -324,7 +323,7 @@ Finished:
End If
End If
Catch ex As Exception
Log($"获取 META-INF 中的版本信息失败（{File.FullName}）", NotifyLevel.DevelopOnly)
Logger.Warn($"获取 META-INF 中的版本信息失败（{File.FullName}）")
Version = Nothing
End Try
End If
@@ -408,7 +407,7 @@ Finished:
''' </summary>
Public ReadOnly Property HasUpdate As Boolean
Get
Return Not Settings.Get("UiHiddenFunctionModUpdate") AndAlso Not Settings.Get("VersionAdvanceDisableModUpdate", Instance:=PageInstanceLeft.Instance) AndAlso UpdateFile IsNot Nothing
Return Not Settings.Get(Of Boolean)("UiHiddenFunctionModUpdate") AndAlso Not Settings.Get(Of Boolean)("VersionAdvanceDisableModUpdate", Instance:=PageInstanceLeft.Instance) AndAlso UpdateFile IsNot Nothing
End Get
End Property
@@ -421,13 +420,13 @@ Finished:
'读取缓存
Dim CacheKey As String = GetHash($"{EnabledFullName}-{File.LastWriteTime.ToLongTimeString}-{File.Length}-C")
Dim Cached As String = ReadIni(PathTemp & "Cache\ModHash.ini", CacheKey)
If Cached <> "" AndAlso RegexCheck(Cached, "^\d+$") Then '#5062
If Cached <> "" AndAlso Cached.RegexCheck("^\d+$") Then '#5062
_CurseForgeHash = Cached
Return _CurseForgeHash
End If
'读取文件
Dim data As New List(Of Byte)
For Each b As Byte In ReadFileBytes(File.FullName)
For Each b As Byte In FileUtils.ReadAsBytes(File.FullName)
If b = 9 OrElse b = 10 OrElse b = 13 OrElse b = 32 Then Continue For
data.Add(b)
Next
@@ -481,7 +480,7 @@ Finished:
Return _ModrinthHash
End If
'计算 SHA1
_ModrinthHash = GetFileSHA1(File.FullName)
_ModrinthHash = HashUtils.ComputeFromFile(File.FullName, HashUtils.HashMethod.Sha1)
'写入缓存
WriteIni(PathTemp & "Cache\ModHash.ini", CacheKey, _ModrinthHash)
End If
@@ -498,7 +497,7 @@ Finished:
Return File.FullName
End Function
Public Overrides Function Equals(obj As Object) As Boolean
Dim Target = TryCast(obj, ResourceFile)
Dim Target = TryCast(obj, LocalResourceFile)
Return Target IsNot Nothing AndAlso File.FullName = Target.File.FullName
End Function
Plain Craft Launcher 2/Modules/Resource/ResourceFileLoader.vb → Plain Craft Launcher 2/Modules/Resource/LocalResourceLoaders.vb
+102 -105
View File
@@ -1,15 +1,14 @@
Public Module ResourceFileLoader
Private Const ResourceFileCacheVersion As Integer = 16
Public Module LocalResourceLoaders
'加载 Mod 列表
Public McModLoader As New LoaderTask(Of String, List(Of ResourceFile))("Mod List Loader", AddressOf McModLoad)
Private Sub McModLoad(Loader As LoaderTask(Of String, List(Of ResourceFile)))
Public LocalResourceLoader As New LoaderTask(Of String, List(Of LocalResourceFile))("LocalResourceLoader", AddressOf LocalResourceFileLoad)
Private Sub LocalResourceFileLoad(Loader As LoaderTask(Of String, List(Of LocalResourceFile)))
Try
RunInUiWait(Sub() If FrmInstanceMod IsNot Nothing Then FrmInstanceMod.Load.ShowProgress = False)
'等待 Mod 更新完成
If PageInstanceMod.UpdatingInstanceModFolders.Contains(Loader.Input) Then
Log($"[Mod] 等待 Mod 更新完成后才能继续加载 Mod 列表：" & Loader.Input)
Logger.Info($"等待 Mod 更新完成后才能继续加载 Mod 列表：{Loader.Input}")
Try
RunInUiWait(Sub() If FrmInstanceMod IsNot Nothing Then FrmInstanceMod.Load.Text = "正在更新 Mod")
Do Until Not PageInstanceMod.UpdatingInstanceModFolders.Contains(Loader.Input)
@@ -23,15 +22,15 @@
End If
'获取 Mod 文件夹下的可用文件列表
Dim ModFileList As New List(Of FileInfo)
If Directory.Exists(Loader.Input) Then
Dim ModFileList As New List(Of String)
If DirectoryUtils.Exists(Loader.Input) Then
Dim RawName As String = Loader.Input.Lower
For Each File As FileInfo In EnumerateFiles(Loader.Input)
If File.DirectoryName.Lower & "\" <> RawName Then
For Each File In DirectoryUtils.GetFiles(Loader.Input)
If File.BeforeLast("\").Lower & "\" <> RawName Then
'仅当 Forge 1.13- 且文件夹名与版本号相同时，才加载该子文件夹下的 Mod
If Not (PageInstanceLeft.Instance IsNot Nothing AndAlso PageInstanceLeft.Instance.Version.HasForge AndAlso
PageInstanceLeft.Instance.Version.Vanilla.Major < 13 AndAlso
File.Directory.Name = $"1.{PageInstanceLeft.Instance.Version.Vanilla.Major}.{PageInstanceLeft.Instance.Version.Vanilla.Build}") Then
PathUtils.GetLastPart(PathUtils.RemoveLastPart(File)) = $"1.{PageInstanceLeft.Instance.Version.Vanilla.Major}.{PageInstanceLeft.Instance.Version.Vanilla.Build}") Then
Continue For
End If
End If
@@ -44,7 +43,7 @@
FullName.EndsWithF(".jar.old", True) OrElse FullName.EndsWithF(".zip.old", True) OrElse FullName.EndsWithF(".litemod.old", True) Then Return True
Return False
End Function
If IsModFile(File.FullName) Then ModFileList.Add(File)
If IsModFile(File) Then ModFileList.Add(File)
Next
End If
@@ -52,29 +51,29 @@
Dim CachePath As String = PathTemp & "Cache\LocalMod.json"
Dim Cache As New JObject
Try
Dim CacheContent As String = ReadFile(CachePath)
Dim CacheContent As String = FileUtils.TryReadAsString(CachePath)
If Not String.IsNullOrWhiteSpace(CacheContent) Then
Cache = GetJson(CacheContent)
If Not Cache.ContainsKey("version") OrElse Cache("version").ToObject(Of Integer) <> ResourceFileCacheVersion Then
Log($"[Mod] 本地 Mod 信息缓存版本已过期，将弃用这些缓存信息", NotifyLevel.DebugModeOnly)
If Not Cache.ContainsKey("version") OrElse Cache("version").ToObject(Of Integer) <> Versions.LOCAL_MOD_CACHE_VERSION Then
Logger.Warn($"本地 Mod 信息缓存版本已过期，将弃用这些缓存信息")
Cache = New JObject
End If
End If
Catch ex As Exception
Log(ex, "读取本地 Mod 信息缓存失败，已重置")
Logger.Warn(ex, "读取本地 Mod 信息缓存失败，已重置")
Cache = New JObject
End Try
Cache("version") = ResourceFileCacheVersion
Cache("version") = Versions.LOCAL_MOD_CACHE_VERSION
'加载 Mod 列表
Dim ModList As New List(Of ResourceFile)
For Each ModFile As FileInfo In ModFileList
Dim ModList As New List(Of LocalResourceFile)
For Each ModFile In ModFileList
If Loader.IsInterrupted Then Return
Dim ModEntry As New ResourceFile(ModFile)
Dim DumpMod As ResourceFile = ModList.FirstOrDefault(Function(m) m.EnabledName = ModEntry.EnabledName) '存在两个文件，名称相同，但一个启用一个禁用
Dim ModEntry As New LocalResourceFile(ModFile)
Dim DumpMod As LocalResourceFile = ModList.FirstOrDefault(Function(m) m.EnabledName = ModEntry.EnabledName) '存在两个文件，名称相同，但一个启用一个禁用
If DumpMod IsNot Nothing Then
Dim DisabledMod As ResourceFile = If(DumpMod.IsEnabled, ModEntry, DumpMod)
Log($"[Mod] 重复的 Mod 文件：{DumpMod.File.Name} 与 {ModEntry.File.Name}，已忽略 {DisabledMod.File.Name}", NotifyLevel.DebugModeOnly)
Dim DisabledMod As LocalResourceFile = If(DumpMod.IsEnabled, ModEntry, DumpMod)
Logger.Warn($"重复的 Mod 文件：{DumpMod.File.Name} 与 {ModEntry.File.Name}，已忽略 {DisabledMod.File.Name}")
If DisabledMod Is ModEntry Then
Continue For
Else
@@ -83,7 +82,7 @@
End If
ModList.Add(ModEntry)
Next
Log($"[Mod] 共发现 {ModList.Count} 个 Mod")
Logger.Info($"共发现 {ModList.Count} 个 Mod")
'排序
ModList = ModList.OrderBy(Function(m) m.File.Name).ToList
@@ -94,33 +93,24 @@
'开始联网加载
'TODO: 添加信息获取中提示
McModDetailLoader.Start(New KeyValuePair(Of List(Of ResourceFile), JObject)(ModList, Cache), IsForceRestart:=True)
LocalResourceOnlineLoader.Start((ModList, Cache, PageInstanceLeft.Instance.Version), IsForceRestart:=True)
Catch ex As Exception
Log(ex, "Mod 列表加载失败", NotifyLevel.DebugModeOnly)
Logger.Warn(ex, "Mod 列表加载失败")
Throw
End Try
End Sub
'联网加载 Mod 详情
Public McModDetailLoader As New LoaderTask(Of KeyValuePair(Of List(Of ResourceFile), JObject), Integer)("Mod List Detail Loader", AddressOf McModDetailLoad)
Private Sub McModDetailLoad(Loader As LoaderTask(Of KeyValuePair(Of List(Of ResourceFile), JObject), Integer))
Dim Mods As New List(Of ResourceFile)
Dim Cache As JObject = Loader.Input.Value
Static GetTargetModLoaders As Func(Of List(Of ModLoaderTypes)) =
Function() As List(Of ModLoaderTypes)
Dim Loaders As New List(Of ModLoaderTypes)
If PageInstanceLeft.Instance.Version.HasForge Then Loaders.Add(ModLoaderTypes.Forge)
If PageInstanceLeft.Instance.Version.HasNeoForge Then Loaders.Add(ModLoaderTypes.NeoForge)
If PageInstanceLeft.Instance.Version.HasFabric Then Loaders.Add(ModLoaderTypes.Fabric)
If PageInstanceLeft.Instance.Version.HasLiteLoader Then Loaders.Add(ModLoaderTypes.LiteLoader)
If Not Loaders.Any() Then Loaders.AddRange({ModLoaderTypes.Forge, ModLoaderTypes.NeoForge, ModLoaderTypes.Fabric, ModLoaderTypes.LiteLoader, ModLoaderTypes.Quilt})
Return Loaders
End Function
Public LocalResourceOnlineLoader As New LoaderTask(Of (ModList As List(Of LocalResourceFile), Cache As JObject, Target As McVersion), Integer)("LocalResourceOnlineLoader", AddressOf LocalResourceOnlineLoad)
Private Sub LocalResourceOnlineLoad(Loader As LoaderTask(Of (ModList As List(Of LocalResourceFile), Cache As JObject, Target As McVersion), Integer))
Dim Mods As New List(Of LocalResourceFile)
Dim Cache As JObject = Loader.Input.Cache
Dim ModLoaders = Loader.Input.Target.ModLoaders
'读取缓存，获取需要更新的 Mod 列表
For Each ModEntry As ResourceFile In Loader.Input.Key
For Each ModEntry As LocalResourceFile In Loader.Input.ModList
If Loader.IsInterrupted Then Return
Dim CacheKey = ModEntry.ModrinthHash & PageInstanceLeft.Instance.Version.VanillaName & GetTargetModLoaders().Join("")
Dim CacheKey = ModEntry.ModrinthHash & Loader.Input.Target.VanillaName & ModLoaders
If Cache.ContainsKey(CacheKey) Then
ModEntry.FromJson(Cache(CacheKey))
'如果缓存中的信息在 6 小时以内更新过，则无需重新获取
@@ -128,18 +118,17 @@
End If
Mods.Add(ModEntry)
Next
Log($"[Mod] 有 {Mods.Where(Function(m) m.Project Is Nothing).Count} 个 Mod 需要联网获取信息，{Mods.Where(Function(m) m.Project IsNot Nothing).Count} 个 Mod 需要更新信息")
Logger.Info($"有 {Mods.Where(Function(m) m.Project Is Nothing).Count} 个 Mod 需要联网获取信息，{Mods.Where(Function(m) m.Project IsNot Nothing).Count} 个 Mod 需要更新信息")
If Not Mods.Any Then
Loader.Input.Key.Where(Function(m) m.Version Is Nothing).ForAll(Sub(m) m.LoadMetadataFromJar()) '从 JAR 中获取缺失的版本信息（下面有另一个分支）
Loader.Input.ModList.Where(Function(m) m.Version Is Nothing).ForAll(Sub(m) m.LoadMetadataFromJar()) '从 JAR 中获取缺失的版本信息（下面有另一个分支）
Return
End If
'获取作为检查目标的加载器和版本
'此处不应向下扩展检查的 MC 小版本，例如 Mod 在更新 1.16.5 后，对早期的 1.16.2 版本发布了修补补丁，这会导致 PCL 将 1.16.5 版本的 Mod 降级到 1.16.2
Dim TargetMcVersion As McVersion = PageInstanceLeft.Instance.Version
Dim ModLoaders = GetTargetModLoaders()
Dim TargetMcVersion As McVersion = Loader.Input.Target
Dim VanillaVersion = TargetMcVersion.VanillaName
'开始网络获取
Log($"[Mod] 目标加载器：{ModLoaders.Join("/")}，版本：{VanillaVersion}")
Logger.Info($"目标加载器：{ModLoaders}，版本：{VanillaVersion}")
Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False
Dim CurrentTaskThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息
@@ -150,16 +139,16 @@
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
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 的对应信息")
Logger.Info($"从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
If ModrinthVersion.Count = 0 Then Return
Dim ModrinthMapping As New Dictionary(Of String, List(Of ResourceFile))
Dim ModrinthMapping As New Dictionary(Of String, List(Of LocalResourceFile))
For Each Entry In Mods
If Not ModrinthVersion.ContainsKey(Entry.ModrinthHash) Then Continue For
If ModrinthVersion(Entry.ModrinthHash)("files")(0)("hashes")("sha1") <> Entry.ModrinthHash Then Continue For
Dim ProjectId = ModrinthVersion(Entry.ModrinthHash)("project_id").ToString
If ResourceProject.Cache.ContainsKey(ProjectId) AndAlso Entry.Project Is Nothing Then Entry.Project = ResourceProject.Cache(ProjectId) '读取已加载的缓存，加快结果出现速度
If Not ModrinthMapping.ContainsKey(ProjectId) Then ModrinthMapping(ProjectId) = New List(Of ResourceFile)
If Not ModrinthMapping.ContainsKey(ProjectId) Then ModrinthMapping(ProjectId) = New List(Of LocalResourceFile)
ModrinthMapping(ProjectId).Add(Entry)
'记录对应的 ProjectVersion
Dim File = ResourceVersion.FromPlatformJson(ModrinthVersion(Entry.ModrinthHash), ResourceTypes.Mod)
@@ -170,7 +159,7 @@
End If
Next
If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
Logger.Info($"需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3：获取工程信息
If Not ModrinthMapping.Any() Then Return
Dim ModrinthProject As JArray = DlModRequest(
@@ -181,16 +170,20 @@
Entry.Project = Project
Next
Next
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息，继续获取更新信息")
Logger.Info($"已从 Modrinth 获取本地 Mod 信息，继续获取更新信息")
'步骤 4：获取更新信息
If ModLoaders = ModLoaders.None Then
Logger.Warn("该 Minecraft 版本没有可用的 Mod 加载器，不获取 Mod 更新信息")
Return
End If
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(""",""").Lower}""],""game_versions"": [""{VanillaVersion}""]}}", "application/json")
""loaders"": [""{ModLoaders.Flags.Join(""",""").Lower}""],""game_versions"": [""{VanillaVersion}""]}}", "application/json")
For Each Entry In Mods
If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.ProjectVersion Is Nothing Then Continue For
Dim UpdateFile = ResourceVersion.FromPlatformJson(ModrinthUpdate(Entry.ModrinthHash), ResourceTypes.Mod)
If Not UpdateFile.DownloadAvailable Then Continue For
If ModeDebug Then Log($"[Mod] 本地文件 {Entry.ProjectVersion.FileName} 在 Modrinth 上的最新版为 {UpdateFile.FileName}")
Logger.Trace(Function() $"本地文件 {Entry.ProjectVersion.FileName} 在 Modrinth 上的最新版为 {UpdateFile.FileName}")
If Entry.ProjectVersion.ReleaseDate >= UpdateFile.ReleaseDate OrElse Entry.ProjectVersion.Hash = UpdateFile.Hash Then Continue For
'设置更新日志与更新文件
If Entry.UpdateFile IsNot Nothing AndAlso UpdateFile.Hash = Entry.UpdateFile.Hash Then '合并
@@ -202,9 +195,9 @@
Entry.UpdateFile = UpdateFile
End If
Next
Log($"[Mod] 从 Modrinth 获取本地 Mod 信息结束")
Logger.Info($"从 Modrinth 获取本地 Mod 信息结束")
Catch ex As Exception
Log(ex, "从 Modrinth 获取本地 Mod 信息失败")
Logger.Warn(ex, "从 Modrinth 获取本地 Mod 信息失败")
IsFailed = True
Finally
EndedThreadCount += 1
@@ -215,90 +208,92 @@
Sub()
Try
'步骤 1：获取 Hash 与对应的工程 ID
Dim CurseForgeHashes As New List(Of UInteger)
Dim Hashes As New List(Of UInteger)
For Each Entry In Mods
CurseForgeHashes.Add(Entry.CurseForgeHash)
Hashes.Add(Entry.CurseForgeHash)
If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return
Next
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 的对应关系
$"{{""fingerprints"": [{Hashes.Join(",")}]}}", "application/json")("data")("exactMatches")
Logger.Info($"从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
If Not CurseForgeRaw.Any() Then Return
Dim CurseForgeMapping As New Dictionary(Of Integer, List(Of ResourceFile))
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
Dim ProjectIdToLocalFiles As New Dictionary(Of Integer, List(Of LocalResourceFile))
For Each Project In CurseForgeRaw
Dim ProjectId = Project("id").ToString
Dim Hash As UInteger = Project("file")("fileFingerprint")
For Each Entry In Mods
If Entry.CurseForgeHash <> Hash Then Continue For
If ResourceProject.Cache.ContainsKey(ProjectId) AndAlso Entry.Project Is Nothing Then Entry.Project = ResourceProject.Cache(ProjectId) '读取已加载的缓存，加快结果出现速度
If Not CurseForgeMapping.ContainsKey(ProjectId) Then CurseForgeMapping(ProjectId) = New List(Of ResourceFile)
CurseForgeMapping(ProjectId).Add(Entry)
ProjectIdToLocalFiles.AddIntoValueCollection(ProjectId, Entry)
'记录对应的 ProjectVersion
Dim File = ResourceVersion.FromPlatformJson(Project("file"), ResourceTypes.Mod)
If Entry.ProjectVersion Is Nothing OrElse Entry.ProjectVersion.ReleaseDate < File.ReleaseDate Then Entry.ProjectVersion = File
Next
Next
If Loader.IsInterruptedWithThread(CurrentTaskThread) Then Return
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
Logger.Info($"需要从 CurseForge 获取 {ProjectIdToLocalFiles.Count} 个本地 Mod 的工程信息")
If Not ProjectIdToLocalFiles.Any() Then Return
'步骤 3：获取工程信息
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 ResourceFile)) 'FileId -> 本地 Mod 文件列表
$"{{""modIds"": [{ProjectIdToLocalFiles.Keys.Join(",")}]}}", "application/json")("data")
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of LocalResourceFile)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject
If ProjectJson("isAvailable") IsNot Nothing AndAlso Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
'设置 Entry 中的工程信息
Dim Project As New ResourceProject(ProjectJson)
For Each Entry In CurseForgeMapping(Project.Id) '倒查防止 CurseForge 返回的内容有漏
If Entry.Project IsNot Nothing AndAlso Entry.Project.Platform = ResourcePlatforms.Modrinth Then
Entry.Project = Entry.Project '再次触发修改事件
Continue For
Dim TargetLoaders As ModLoaders = ModLoaders.None
For Each LocalFile In ProjectIdToLocalFiles(Project.Id) '倒查防止 CurseForge 返回的内容有漏
If LocalFile.Project?.Platform = ResourcePlatforms.Modrinth Then
LocalFile.Project = LocalFile.Project '再次触发修改事件
Else
LocalFile.Project = Project
TargetLoaders = TargetLoaders Or LocalFile.Project.ModLoaders
End If
Entry.Project = Project
Next
TargetLoaders = TargetLoaders And ModLoaders '与目标 MC 版本的加载器取交集
'查找或许版本更新的文件列表
If ModLoaders.IsSingle Then
Dim NewestVersion As String = Nothing
Dim NewestFileIds As New List(Of Integer)
For Each IndexEntry In ProjectJson("latestFilesIndexes")
If IndexEntry("modLoader") Is Nothing OrElse ModLoaders.Single <> IndexEntry("modLoader").ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
Dim IndexVersion As String = IndexEntry("gameVersion")
If IndexVersion <> VanillaVersion Then Continue For 'MC 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的，所以只需取第一个；如果需要检查多个 releaseType 下的文件，将 > -1 改为 = 1，但这应当并不会获取到更新的文件
If NewestVersion IsNot Nothing AndAlso CompareVersion(NewestVersion, IndexVersion) > -1 Then Continue For '只保留最新 MC 版本
If NewestVersion <> IndexVersion Then
NewestVersion = IndexVersion
NewestFileIds.Clear()
End If
NewestFileIds.Add(IndexEntry("fileId").ToObject(Of Integer))
Next
For Each FileId In NewestFileIds
If Not UpdateFileIds.ContainsKey(FileId) Then UpdateFileIds(FileId) = New List(Of ResourceFile)
UpdateFileIds(FileId).AddRange(CurseForgeMapping(Project.Id))
FileIdToProjectSlug(FileId) = Project.Slug
Next
End If
If ModLoaders = ModLoaders.None Then Continue For '无法判断 MC 版本使用的加载器，跳过更新检查
Dim LatestFiles = ProjectJson("latestFilesIndexes").Where(
Function(Entry)
'Mod Loader 匹配
If Entry("modLoader") Is Nothing Then Return False
Dim EntryLoader As ModLoaders = Resource.FromCurseForgeModLoaderType(Entry("modLoader").ToObject(Of Integer))
If Not TargetLoaders.HasFlag(EntryLoader) Then Return False
'MC 版本匹配
Dim EntryVersion As String = Entry("gameVersion")
Return EntryVersion IsNot Nothing AndAlso EntryVersion = VanillaVersion
End Function).
MaxByAll(Function(Entry) Entry("gameVersion").ToString, New VersionComparer) '只保留最新的 MC 版本
For Each Entry In LatestFiles
Dim FileId = Entry("fileId").ToObject(Of Integer)
If Not UpdateFileIds.ContainsKey(FileId) Then UpdateFileIds(FileId) = New List(Of LocalResourceFile)
UpdateFileIds(FileId).AddRange(ProjectIdToLocalFiles(Project.Id))
FileIdToProjectSlug(FileId) = Project.Slug
Next
Next
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息，需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
'步骤 4：获取更新文件信息
Logger.Info($"已从 CurseForge 获取本地 Mod 信息，需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
If Not UpdateFileIds.Any() Then Return
'步骤 4：获取更新文件信息
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 ResourceFile, ResourceVersion)
Dim UpdateFiles As New Dictionary(Of LocalResourceFile, ResourceVersion)
For Each FileJson In CurseForgeFiles
Dim File = ResourceVersion.FromPlatformJson(FileJson, ResourceTypes.Mod)
If Not File.DownloadAvailable Then Continue For
For Each Entry As ResourceFile In UpdateFileIds(File.Id)
For Each Entry As LocalResourceFile In UpdateFileIds(File.Id)
If UpdateFiles.ContainsKey(Entry) AndAlso UpdateFiles(Entry).ReleaseDate >= File.ReleaseDate Then Continue For
UpdateFiles(Entry) = File
Next
Next
For Each Pair In UpdateFiles
Dim Entry As ResourceFile = Pair.Key
Dim Entry As LocalResourceFile = Pair.Key
Dim UpdateFile As ResourceVersion = Pair.Value
If ModeDebug Then Log($"[Mod] 本地文件 {Entry.ProjectVersion.FileName} 在 CurseForge 上的最新版为 {UpdateFile.FileName}")
Logger.Trace(Function() $"本地文件 {Entry.ProjectVersion.FileName} 在 CurseForge 上的最新版为 {UpdateFile.FileName}")
If Entry.ProjectVersion.ReleaseDate >= UpdateFile.ReleaseDate OrElse Entry.ProjectVersion.Hash = UpdateFile.Hash Then Continue For
'设置更新日志与更新文件
If Entry.UpdateFile IsNot Nothing AndAlso UpdateFile.Hash = Entry.UpdateFile.Hash Then '合并
@@ -309,16 +304,17 @@
Entry.UpdateFile = UpdateFile
End If
Next
Log($"[Mod] 从 CurseForge 获取 Mod 更新信息结束")
Logger.Info($"从 CurseForge 获取 Mod 更新信息结束")
Catch ex As Exception
Log(ex, "从 CurseForge 获取本地 Mod 信息失败")
Logger.Warn(ex, "从 CurseForge 获取本地 Mod 信息失败")
IsFailed = True
Finally
EndedThreadCount += 1
End Try
End Sub, "Mod List Detail Loader CurseForge")
'从 JAR 中获取缺失的版本信息（上面有另一个分支）
Loader.Input.Key.Where(Function(m) m.Version Is Nothing).ForAll(Sub(m) m.LoadMetadataFromJar())
Loader.Input.ModList.Where(Function(m) m.Version Is Nothing).ForAll(Sub(m) m.LoadMetadataFromJar())
'等待线程结束
Do Until EndedThreadCount = 2
Thread.Sleep(10)
@@ -326,11 +322,12 @@
Loop
'保存缓存
Mods = Mods.Where(Function(m) m.Project IsNot Nothing).ToList()
Log($"[Mod] 联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
Logger.Info($"联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Return
If Loader.IsInterrupted Then Return
For Each Entry In Mods
Entry.OnlineDataLoaded = Not IsFailed
Cache(Entry.ModrinthHash & VanillaVersion & ModLoaders.Join("")) = Entry.ToJson()
Cache(Entry.ModrinthHash & VanillaVersion & ModLoaders) = Entry.ToJson()
Next
FileUtils.Write(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
'刷新边栏
@@ -342,4 +339,4 @@
End If
End Sub
End Module
End Module
Plain Craft Launcher 2/Modules/Resource/ResourceProject.vb
+30 -43
View File
@@ -52,9 +52,9 @@ Public Class ResourceProject
''' </summary>
Public ReadOnly DownloadCount As Integer
''' <summary>
''' 支持的 Mod 加载器列表。可能为空。
''' 所有支持的 Mod 加载器。可能为 <see cref="ModLoaders.None"/>。
''' </summary>
Public ReadOnly Loaders As List(Of ModLoaderTypes)
Public ReadOnly ModLoaders As ModLoaders = ModLoaders.None
''' <summary>
''' 描述性标签的内容。已转换为中文。
''' </summary>
@@ -133,11 +133,7 @@ Public Class ResourceProject
Website = Data("Website")
LastUpdate = Data("LastUpdate")
DownloadCount = Data("DownloadCount")
If Data.ContainsKey("ModLoaders") Then
Loaders = CType(Data("ModLoaders"), JArray).Select(Function(t) CType(t.ToObject(Of Integer), ModLoaderTypes)).ToList
Else
Loaders = New List(Of ModLoaderTypes)
End If
If Data.ContainsKey("ModLoaders") Then ModLoaders = Data("ModLoaders").ToObject(Of Integer)
Tags = CType(Data("Tags"), JArray).Select(Function(t) t.ToString).ToList
If Data.ContainsKey("LogoUrl") Then LogoUrl = Data("LogoUrl")
If Data.ContainsKey("Drops") Then
@@ -181,12 +177,12 @@ Public Class ResourceProject
Types = ResourceTypes.DataPack
End If
'FileIndexes / VanillaMajorVersions / ModLoaders
Loaders = New List(Of ModLoaderTypes)
ModLoaders = ModLoaders.None
Dim Files As New List(Of KeyValuePair(Of Integer, List(Of String))) 'FileId, GameVersions
For Each File In If(Data("latestFiles"), New JArray)
Dim NewFile = ResourceVersion.FromPlatformJson(File, Types)
If Not NewFile.DownloadAvailable Then Continue For
Loaders.AddRange(NewFile.Loaders)
ModLoaders = ModLoaders Or NewFile.ModLoaders
Dim GameVersions = File("gameVersions").ToObject(Of List(Of String))
If Not GameVersions.Any(Function(v) McVersion.IsFormatFit(v)) Then Continue For
Files.Add(New KeyValuePair(Of Integer, List(Of String))(File("id"), GameVersions))
@@ -198,7 +194,6 @@ Public Class ResourceProject
CurseForgeFileIds = Files.Select(Function(f) f.Key).Distinct.ToList
Drops = Files.SelectMany(Function(f) f.Value).
Select(Function(v) McVersion.VersionToDrop(v)).Where(Function(v) v <> 209).Distinct.OrderByDescending(Function(v) v).ToList
Loaders = Loaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
'Tags
Tags = New List(Of String)
For Each Category In If(Data("categories"), New JArray). '镜像源 API 可能丢失此字段 (4267#issuecomment-2254590831)
@@ -303,24 +298,17 @@ Public Class ResourceProject
End Select
'Tags & ModLoaders
Tags = New List(Of String)
Loaders = New List(Of ModLoaderTypes)
If Data.ContainsKey("loaders") Then
For Each Category In Data("loaders").Select(Function(t) t.ToString)
Select Case Category
Case "forge" : Loaders.Add(ModLoaderTypes.Forge)
Case "fabric" : Loaders.Add(ModLoaderTypes.Fabric)
Case "quilt" : Loaders.Add(ModLoaderTypes.Quilt)
Case "neoforge" : Loaders.Add(ModLoaderTypes.NeoForge)
End Select
ModLoaders = ModLoaders.None
For Each Category In If(Data("loaders")?.Select(Function(t) t.ToString), {}).Concat(Data("categories").Select(Function(t) t.ToString))
For Each Loader In EnumUtils.GetAllFlags(Of ModLoaders)()
If Category = Loader.ToString.Lower Then
ModLoaders = ModLoaders Or Loader
Exit For
End If
Next
End If
Next
For Each Category In Data("categories").Select(Function(t) t.ToString)
Select Case Category
'加载器
Case "forge" : Loaders.Add(ModLoaderTypes.Forge)
Case "fabric" : Loaders.Add(ModLoaderTypes.Fabric)
Case "quilt" : Loaders.Add(ModLoaderTypes.Quilt)
Case "neoforge" : Loaders.Add(ModLoaderTypes.NeoForge)
Case "datapack" : Types = ResourceTypes.DataPack
'共用
Case "technology" : Tags.Add("科技")
@@ -388,12 +376,11 @@ Public Class ResourceProject
Case "vanilla" : Tags.Add("原版可用")
End Select
Next
If Types = ResourceTypes.DataPack AndAlso Loaders.Any Then Types = ResourceTypes.DataPack Or ResourceTypes.Mod
If Types = ResourceTypes.DataPack AndAlso ModLoaders <> ModLoaders.None Then Types = ResourceTypes.DataPack Or ResourceTypes.Mod
#End Region
End If
If Not Tags.Any() Then Tags.Add("其他")
Tags.Sort()
Loaders.Sort()
End If
'保存缓存
Cache(Id) = Me
@@ -454,7 +441,7 @@ Public Class ResourceProject
Json("Website") = Website
Json("LastUpdate") = LastUpdate
Json("DownloadCount") = DownloadCount
If Loaders IsNot Nothing AndAlso Loaders.Any Then Json("ModLoaders") = New JArray(Loaders.Select(Function(m) CInt(m)))
If ModLoaders <> ModLoaders.None Then Json("ModLoaders") = ModLoaders
Json("Tags") = New JArray(Tags)
If LogoUrl IsNot Nothing Then Json("LogoUrl") = LogoUrl
If Drops.Any Then Json("Drops") = New JArray(Drops)
@@ -514,13 +501,13 @@ Public Class ResourceProject
End If
'获取 Mod 加载器描述
Dim ModLoaderDescriptionFull As String, ModLoaderDescriptionPart As String
Dim ModLoadersForDesc As New List(Of ModLoaderTypes)(Loaders)
If Settings.Get("ToolDownloadIgnoreQuilt") Then ModLoadersForDesc.Remove(ModLoaderTypes.Quilt)
Dim ModLoadersForDesc = ModLoaders.Flags().ToList()
If Settings.Get(Of Boolean)("ToolDownloadIgnoreQuilt") Then ModLoadersForDesc.Remove(ModLoaders.Quilt)
Select Case ModLoadersForDesc.Count
Case 0
If Loaders.IsSingle Then
ModLoaderDescriptionFull = "仅 " & Loaders.Single.ToString
ModLoaderDescriptionPart = Loaders.Single.ToString
If ModLoadersForDesc.IsSingle Then
ModLoaderDescriptionFull = "仅 " & ModLoadersForDesc.Single.ToString
ModLoaderDescriptionPart = ModLoadersForDesc.Single.ToString
Else
ModLoaderDescriptionFull = "未知"
ModLoaderDescriptionPart = ""
@@ -530,10 +517,10 @@ Public Class ResourceProject
ModLoaderDescriptionPart = ModLoadersForDesc.Single.ToString
Case Else
Dim NewestDrop As Integer = If(Drops.Any, Drops.First, 9999)
If Loaders.Contains(ModLoaderTypes.Forge) AndAlso
(NewestDrop < 140 OrElse Loaders.Contains(ModLoaderTypes.Fabric)) AndAlso
(NewestDrop < 200 OrElse Loaders.Contains(ModLoaderTypes.NeoForge)) AndAlso
(NewestDrop < 140 OrElse Loaders.Contains(ModLoaderTypes.Quilt) OrElse Settings.Get("ToolDownloadIgnoreQuilt")) Then
If ModLoadersForDesc.Contains(ModLoaders.Forge) AndAlso
(NewestDrop < 140 OrElse ModLoadersForDesc.Contains(ModLoaders.Fabric)) AndAlso
(NewestDrop < 200 OrElse ModLoadersForDesc.Contains(ModLoaders.NeoForge)) AndAlso
(NewestDrop < 140 OrElse ModLoadersForDesc.Contains(ModLoaders.Quilt) OrElse Settings.Get(Of Boolean)("ToolDownloadIgnoreQuilt")) Then
ModLoaderDescriptionFull = "任意"
ModLoaderDescriptionPart = ""
Else
@@ -596,7 +583,7 @@ Public Class ResourceProject
If TranslatedName = RawName Then
'没有中文翻译
'将所有名称分段
Dim NameLists = TranslatedName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, StringSplitOptions.RemoveEmptyEntries).
Dim NameLists = TranslatedName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, True).
Select(Function(s) s.Trim(" /\".ToCharArray)).Where(Function(w) Not String.IsNullOrEmpty(w))
If NameLists.IsSingle Then GoTo NoSubtitle
'查找其中的缩写、Forge/Fabric 等版本标记
@@ -608,7 +595,7 @@ Public Class ResourceProject
'缩写
SubtitleList.Add(Name)
ElseIf {"neoforge", "forge", "fabric", "quilt"}.Any(Function(l) LowerName.Contains(l)) AndAlso
Not RegexCheck(LowerName.Replace("neoforge", "").Replace("forge", "").Replace("fabric", "").Replace("quilt", ""), "[a-z]+") Then '去掉关键词后没有其他字母
Not LowerName.Replace("neoforge", "").Replace("forge", "").Replace("fabric", "").Replace("quilt", "").RegexCheck("[a-z]+") Then '去掉关键词后没有其他字母
'Forge/Fabric 等版本标记
SubtitleList.Add(Name)
Else
@@ -631,7 +618,7 @@ Public Class ResourceProject
If Suffix <> "" Then EnglishName = EnglishName.Replace(" - " & Suffix, "")
EnglishName = EnglishName.Replace(Title, "").Trim("("c, ")"c, " "c)
'中段的额外信息截取
SubtitleList = EnglishName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, StringSplitOptions.RemoveEmptyEntries).
SubtitleList = EnglishName.Split({" | ", " - ", "(", ")", "[", "]", "{", "}"}, True).
Select(Function(s) s.Trim(" /".ToCharArray)).Where(Function(w) Not String.IsNullOrEmpty(w)).ToList
If SubtitleList.Count > 1 AndAlso
Not SubtitleList.Any(Function(s) s.Lower.Contains("forge") OrElse s.Lower.Contains("fabric") OrElse s.Lower.Contains("quilt")) AndAlso '不是标注 XX 版
@@ -690,16 +677,16 @@ NoSubtitle:
'来自不同的网站
If Platform = Project.Platform Then Return False
'Mod 加载器一致
If Loaders.Count <> Project.Loaders.Count OrElse Loaders.Except(Project.Loaders).Any() Then Return False
If ModLoaders <> Project.ModLoaders Then Return False
'若不为光影，则要求 MC 版本一致
If Types <> ResourceTypes.Shader AndAlso (Drops.Count <> Project.Drops.Count OrElse Drops.Except(Project.Drops).Any()) Then Return False
If Types <> ResourceTypes.Shader AndAlso Drops.Ordered.SequenceEqual(Project.Drops.Ordered) Then Return False
'最近更新时间差距在一周以内
If Math.Abs((LastUpdate - Project.LastUpdate).TotalDays) > 7 Then Return False
'MCMOD 翻译名 / 原名 / 描述文本 / Slug 的英文部分相同
If TranslatedName = Project.TranslatedName OrElse
RawName = Project.RawName OrElse Description = Project.Description OrElse
GetRaw(Slug) = GetRaw(Project.Slug) Then
Log($"[Resource] 将 {RawName} ({Slug}) 与 {Project.RawName} ({Project.Slug}) 认定为相似工程")
Logger.Info($"将 {RawName} ({Slug}) 与 {Project.RawName} ({Project.Slug}) 认定为相似工程")
'如果只有一个有 DatabaseEntry，设置给另外一个
If WikiEntry Is Nothing AndAlso Project.WikiEntry IsNot Nothing Then WikiEntry = Project.WikiEntry
If WikiEntry IsNot Nothing AndAlso Project.WikiEntry Is Nothing Then Project.WikiEntry = WikiEntry
Plain Craft Launcher 2/Modules/Resource/ResourceSearcher.vb
+39 -34
View File
@@ -40,8 +40,10 @@
Public Tag As String = ""
''' <summary>
''' 筛选 Mod 加载器类别。
''' <see cref="ModLoaders.None"/> 代表不筛选。
''' 对于 Modrinth 请求，支持多个枚举值。
''' </summary>
Public ModLoader As ModLoaderTypes = ModLoaderTypes.Any
Public ModLoaders As ModLoaders = ModLoaders.None
''' <summary>
''' 筛选 MC 版本。
''' </summary>
@@ -82,7 +84,7 @@
Address += "&classId=12"
End Select
If Tag <> "" Then Address += "&categoryId=" & Tag.BeforeFirst("/")
If ModLoader <> ModLoaderTypes.Any AndAlso Not IgnoreModLoaderFilter Then Address += "&modLoaderType=" & CType(ModLoader, Integer)
If ModLoaders <> ModLoaders.None AndAlso Not IgnoreModLoaderFilter Then Address += "&modLoaderType=" & Resource.ToCurseForgeModLoaderType(ModLoaders.Flags.First)
If Not String.IsNullOrEmpty(GameVersion) Then Address += "&gameVersion=" & GameVersion
If Not String.IsNullOrEmpty(SearchText) Then Address += "&searchFilter=" & EscapeUtils.UrlEscape(SearchText)
If Storage.CurseForgeOffset > 0 Then Address += "&index=" & Storage.CurseForgeOffset
@@ -97,11 +99,13 @@
Dim Address As String = $"https://api.modrinth.com/v2/search?limit={RESULT_PAGE_SIZE}&index=relevance"
If Not String.IsNullOrEmpty(SearchText) Then Address += "&query=" & EscapeUtils.UrlEscape(SearchText)
If Storage.ModrinthOffset > 0 Then Address += "&offset=" & Storage.ModrinthOffset
'facets=[["categories:'game-mechanics'"],["categories:'forge'"],["versions:1.19.3"],["project_type:mod"]]
'facets=[["categories:'game-mechanics'"],["categories:'forge',categories:'fabric'"],["versions:1.19.3"],["project_type:mod"]]
Dim Facets As New List(Of String)
Facets.Add($"[""project_type:{Type.ToString.Lower}""]")
If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.AfterLast("/")}'""]")
If ModLoader <> ModLoaderTypes.Any AndAlso Not IgnoreModLoaderFilter Then Facets.Add($"[""categories:'{GetStringFromEnum(ModLoader).Lower}'""]")
If ModLoaders <> ModLoaders.None AndAlso Not IgnoreModLoaderFilter Then
Facets.Add($"[""categories:'{ModLoaders.Flags.Select(Function(f) f.ToString.Lower).Join("',categories:'")}'""]")
End If
If Not String.IsNullOrEmpty(GameVersion) Then Facets.Add($"[""versions:'{GameVersion}'""]")
Address += "&facets=[" & String.Join(",", Facets) & "]"
Return Address
@@ -112,7 +116,7 @@
Dim request = TryCast(obj, SearchRequest)
Return request IsNot Nothing AndAlso
Type = request.Type AndAlso TargetResultCount = request.TargetResultCount AndAlso
Tag = request.Tag AndAlso ModLoader = request.ModLoader AndAlso Sources = request.Sources AndAlso
Tag = request.Tag AndAlso ModLoaders = request.ModLoaders AndAlso Sources = request.Sources AndAlso
GameVersion = request.GameVersion AndAlso SearchText = request.SearchText
End Function
Public Shared Operator =(left As SearchRequest, right As SearchRequest) As Boolean
@@ -122,7 +126,7 @@
Return Not left = right
End Operator
Public Overrides Function GetHashCode() As Integer
Return (Type, Tag, ModLoader, GameVersion, SearchText, Sources).GetHashCode()
Return (Type, Tag, ModLoaders, GameVersion, SearchText, Sources).GetHashCode()
End Function
End Class
@@ -164,19 +168,19 @@
#Region "前置检查"
If Storage.Results.Count >= Request.TargetResultCount Then
Log($"[Resource] 已有 {Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理")
Logger.Info($"已有 {Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理")
Return
ElseIf Not Request.CanContinue Then
If Not Storage.Results.Any() Then
Throw New Exception("没有符合条件的结果")
Else
Log($"[Resource] 已有 {Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理")
Logger.Info($"已有 {Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理")
Return
End If
End If
'拒绝 1.13- Quilt（这个版本根本没有 Quilt）
If Request.ModLoader = ModLoaderTypes.Quilt AndAlso CompareVersion(If(Request.GameVersion, "1.15"), "1.14") = -1 Then
If Request.ModLoaders = ModLoaders.Quilt AndAlso CompareVersion(If(Request.GameVersion, "1.15"), "1.14") = -1 Then
Throw New Exception("Quilt 不支持 Minecraft " & Request.GameVersion)
End If
@@ -186,10 +190,10 @@
Dim RawSearchText As String = If(Request.SearchText, "").Trim
RawSearchText = RawSearchText.Lower
Log("[Resource] 工程列表搜索原始文本：" & RawSearchText)
Logger.Info($"工程列表搜索原始文本：{RawSearchText}")
Dim IsChineseSearch As Boolean =
RegexCheck(RawSearchText, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawSearchText) AndAlso
RawSearchText.RegexCheck("[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawSearchText) AndAlso
(Request.Type = ResourceTypes.Mod OrElse Request.Type = ResourceTypes.DataPack) '目前仅对 Mod 和数据包进行中文搜索，注意整合包的名称可能已经有中文了
Dim CurseForgeAltSearchText As String = Nothing, ModrinthAltSearchText As String = Nothing, ModrinthSlugs As New List(Of String) '从中文转为英文的替代搜索内容
If IsChineseSearch Then
@@ -231,7 +235,7 @@
Function(Entry) New SearchEntry(Of WikiEntry) With {
.Item = Entry,
.SearchSource = New List(Of SearchSource) From {
New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1), '部分 Mod 有别名
New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split("/"c, True), 1), '部分 Mod 有别名
New SearchSource(Entry.ChineseName.AfterFirst(" (") & Entry.CurseForgeSlug, 0.5)}
}).ToList
Dim CurseForgeSearchResults = Search(CurseForgeSearchEntries, RawSearchText, 100, 0.25)
@@ -244,7 +248,7 @@
MaxBy(Function(s) s.Item.Popularity) '然后从中选择最受欢迎的那一个
'后处理
CurseForgeAltSearchText = ExtractWords(CurseForgeTarget, ResourcePlatforms.CurseForge).Join(" ")
Log("[Resource] 中文搜索关键词（CurseForge）：" & CurseForgeAltSearchText, NotifyLevel.DebugModeOnly)
Logger.Warn($"中文搜索关键词（CurseForge）：{CurseForgeAltSearchText}")
End If
End If
'Modrinth
@@ -255,7 +259,7 @@
Function(Entry) New SearchEntry(Of WikiEntry) With {
.Item = Entry,
.SearchSource = New List(Of SearchSource) From {
New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1), '部分 Mod 有别名
New SearchSource(Entry.ChineseName.BeforeFirst(" (").Split("/"c, True), 1), '部分 Mod 有别名
New SearchSource(Entry.ChineseName.AfterFirst(" (") & Entry.ModrinthSlug, 0.5)}
}).ToList
Dim ModrinthSearchResults = Search(ModrinthSearchEntries, RawSearchText, 100, 0.25)
@@ -270,7 +274,7 @@
Next
Next
ModrinthAltSearchText = WordWeights.MaxBy(Function(w) w.Value).Key
Log("[Resource] 中文搜索关键词（Modrinth）：" & ModrinthAltSearchText, NotifyLevel.DebugModeOnly)
Logger.Warn($"中文搜索关键词（Modrinth）：{ModrinthAltSearchText}")
'直接请求工程
ModrinthSlugs = ModrinthSearchResults.Take(100).Select(Function(r) r.Item.ModrinthSlug).ToList
End If
@@ -295,7 +299,7 @@ NextPage:
'在 1.14-，部分老 Mod 没有设置支持的加载器，因此添加 Forge 筛选就会出现遗漏
'所以，在发起请求时不筛选加载器，然后在返回的结果中自行筛除不是 Forge 的 Mod
Dim IgnoreModLoaderFilter = Request.ModLoader = ModLoaderTypes.Forge AndAlso McVersion.VersionToDrop(Request.GameVersion) < 140
Dim IgnoreModLoaderFilter = Request.ModLoaders = ModLoaders.Forge AndAlso McVersion.VersionToDrop(Request.GameVersion) < 140
Try
'CurseForge 搜索
@@ -307,21 +311,22 @@ NextPage:
Try
'获取工程列表
Dim CurseForgeUrl As String = Request.GetCurseForgeAddress(If(CurseForgeAltSearchText, RawSearchText), IgnoreModLoaderFilter)
Log("[Resource] 开始 CurseForge 搜索：" & CurseForgeUrl)
Logger.Info($"开始 CurseForge 搜索：{CurseForgeUrl}")
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl)
Dim ProjectList As New List(Of ResourceProject)
For Each JsonEntry As JObject In RequestResult("data")
Dim Project As New ResourceProject(JsonEntry)
If Request.Type = ResourceTypes.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包
If Request.Type <> ResourceTypes.Any AndAlso Not Project.Types.HasFlag(Request.Type) Then Continue For '过滤分区不匹配的搜索结果（#8265）
ProjectList.Add(Project)
Next
'更新结果
ProjectList.ForEach(Sub(p) RawResults.Add(p))
Storage.CurseForgeOffset += RequestResult("data").Count
Storage.CurseForgeTotal = RequestResult("pagination")("totalCount").ToObject(Of Integer)
Log($"[Resource] 从 CurseForge 搜索到了 {ProjectList.Count} 个工程（总计已获取 {Storage.CurseForgeOffset} 个，共 {Storage.CurseForgeTotal} 个）")
Logger.Info($"从 CurseForge 搜索到了 {ProjectList.Count} 个工程（总计已获取 {Storage.CurseForgeOffset} 个，共 {Storage.CurseForgeTotal} 个）")
Catch ex As Exception
Log(ex, "CurseForge 搜索失败")
Logger.Warn(ex, "CurseForge 搜索失败")
Storage.CurseForgeTotal = -1
Errors.Add((ex, ResourcePlatforms.CurseForge))
End Try
@@ -337,7 +342,7 @@ NextPage:
Sub()
Try
Dim ModrinthUrl As String = Request.GetModrinthAddress(If(ModrinthAltSearchText, RawSearchText), IgnoreModLoaderFilter)
Log("[Resource] 开始 Modrinth 搜索：" & ModrinthUrl)
Logger.Info($"开始 Modrinth 搜索：{ModrinthUrl}")
Dim RequestResult As JObject = DlModRequest(ModrinthUrl)
Dim ProjectList As New List(Of ResourceProject)
For Each JsonEntry As JObject In RequestResult("hits")
@@ -347,9 +352,9 @@ NextPage:
ProjectList.ForEach(Sub(p) RawResults.Add(p))
Storage.ModrinthOffset += RequestResult("hits").Count
Storage.ModrinthTotal = RequestResult("total_hits").ToObject(Of Integer)
Log($"[Resource] 从 Modrinth 搜索到了 {ProjectList.Count} 个工程（总计已获取 {Storage.ModrinthOffset} 个，共 {Storage.ModrinthTotal} 个）")
Logger.Info($"从 Modrinth 搜索到了 {ProjectList.Count} 个工程（总计已获取 {Storage.ModrinthOffset} 个，共 {Storage.ModrinthTotal} 个）")
Catch ex As Exception
Log(ex, "Modrinth 搜索失败")
Logger.Warn(ex, "Modrinth 搜索失败")
Storage.ModrinthTotal = -1
Errors.Add((ex, ResourcePlatforms.Modrinth))
End Try
@@ -365,7 +370,7 @@ NextPage:
Sub()
Try
Dim ModrinthUrl As String = $"https://api.modrinth.com/v2/projects?ids=[""{ModrinthSlugs.Join(""",""")}""]"
Log("[Resource] 开始 Modrinth 直接获取：" & ModrinthUrl)
Logger.Info($"开始 Modrinth 直接获取：{ModrinthUrl}")
Dim ProjectList As New List(Of ResourceProject)
For Each JsonEntry As JObject In DlModRequest(ModrinthUrl)
Dim Project As New ResourceProject(JsonEntry)
@@ -373,18 +378,18 @@ NextPage:
If Request.Type <> ResourceTypes.Any AndAlso Not Project.Types.HasFlag(Request.Type) Then Continue For
If Not String.IsNullOrEmpty(Request.Tag) AndAlso
Not JsonEntry("categories").Any(Function(c) c.ToString = Request.Tag.AfterLast("/")) Then Continue For 'Project.Tags 已经转换成中文了，只能从 json 判
If Request.ModLoader <> ModLoaderTypes.Any AndAlso Not IgnoreModLoaderFilter AndAlso
Not Project.Loaders.Any(Function(m) m = Request.ModLoader) Then Continue For
If Request.ModLoaders <> ModLoaders.None AndAlso Not IgnoreModLoaderFilter AndAlso
Not Project.ModLoaders.Flags.Intersect(Request.ModLoaders.Flags).Any() Then Continue For
If Not String.IsNullOrEmpty(Request.GameVersion) AndAlso
Not Project.UnsafeGameVersions.Any(Function(d) d = Request.GameVersion) Then Continue For
ProjectList.Add(Project)
Next
'更新结果
ProjectList.ForEach(Sub(p) RawResults.Add(p))
Log($"[Resource] 从 Modrinth 直接获取到了 {ProjectList.Count} 个工程")
Logger.Info($"从 Modrinth 直接获取到了 {ProjectList.Count} 个工程")
ModrinthSlugs.Clear() '防止重试/加载下一页时重复获取
Catch ex As Exception
Log(ex, "Modrinth 直接获取失败")
Logger.Warn(ex, "Modrinth 直接获取失败")
Errors.Add((ex, ResourcePlatforms.Modrinth))
End Try
If Task.Progress < 0.75 Then Task.Progress += 0.25 '可能重复加载多页，所以不能直接给够
@@ -397,9 +402,9 @@ NextPage:
If Task.IsInterrupted Then Return '会自动触发 Finally 以清理线程
Next
'筛除不是 Forge 的 Mod
'仅保留兼容 Forge 的 Mod，或老版本中没有标注任何 Mod Loader 的 Mod
If IgnoreModLoaderFilter Then
RawResults = RawResults.Where(Function(p) Not p.Loaders.Any() OrElse p.Loaders.Contains(ModLoaderTypes.Forge)).ToList
RawResults.KeepIf(Function(p) p.ModLoaders = ModLoaders.None OrElse p.ModLoaders.HasFlag(ModLoaders.Forge))
End If
'确保存在结果
@@ -446,19 +451,19 @@ NextPage:
Not Storage.Results.Any(Function(b) r.IsLike(b))).ToList
'加入列表
RealResults.AddRange(RawResults)
Log($"[Resource] 去重、筛选后累计新增结果 {RealResults.Count} 个（目前已有结果 {Storage.Results.Count} 个）")
Logger.Info($"去重、筛选后累计新增结果 {RealResults.Count} 个（目前已有结果 {Storage.Results.Count} 个）")
#End Region
#Region "检查结果数量，如果不足且可继续，会继续加载下一页"
If RealResults.Count + Storage.Results.Count < Request.TargetResultCount Then
Log($"[Resource] 总结果数需求最少 {Request.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
Logger.Info($"总结果数需求最少 {Request.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
If Request.CanContinue AndAlso Not Errors.Any Then '如果有某个源失败则不再重试，这时候重试可能导致无限循环
Log("[Resource] 将继续尝试加载下一页")
Logger.Info("将继续尝试加载下一页")
GoTo NextPage
Else
Log("[Resource] 无法继续加载，将强制结束")
Logger.Info("无法继续加载，将强制结束")
End If
End If
@@ -493,7 +498,7 @@ NextPage:
Scores(Result) = If(Result.WikiId > 0, 0.2, 0) +
Math.Log10(Math.Max(Result.DownloadCount, 1) * GetDownloadCountMult(Result)) / 9
SearchEntries.Add(New SearchEntry(Of ResourceProject) With {.Item = Result, .SearchSource = New List(Of SearchSource) From {
New SearchSource(If(IsChineseSearch, Result.TranslatedName, Result.RawName).Split({"/"c}, StringSplitOptions.RemoveEmptyEntries), 1),
New SearchSource(If(IsChineseSearch, Result.TranslatedName, Result.RawName).Split("/"c, True), 1),
New SearchSource(Result.Description, 0.05)}})
Next
Dim SearchResult = Search(SearchEntries, RawSearchText, 10000, -1)
Plain Craft Launcher 2/Modules/Resource/ResourceVersion.vb
+48 -26
View File
@@ -36,10 +36,9 @@ Public Class ResourceVersion
''' </summary>
Public Version As String
''' <summary>
''' 支持的 Mod 加载器列表。
''' 可能为空列表，不为 Nothing。
''' 所有支持的 Mod 加载器列表。可能为 <see cref="ModLoaders.None"/>。
''' </summary>
Public Loaders As List(Of ModLoaderTypes)
Public ModLoaders As ModLoaders = ModLoaders.None
''' <summary>
''' 支持的游戏版本列表。类型包括："26.1.5"，"26.1"，"26.1 预览版"，"1.18.5"，"1.18"，"1.18 预览版"，"21w15a"，"未知版本"。
''' </summary>
@@ -158,11 +157,10 @@ Public Class ResourceVersion
.GameVersions = New List(Of String) From {"未知版本"}
End If
'ModLoaders
.Loaders = New List(Of ModLoaderTypes)
If RawVersions.Contains("forge") Then .Loaders.Add(ModLoaderTypes.Forge)
If RawVersions.Contains("fabric") Then .Loaders.Add(ModLoaderTypes.Fabric)
If RawVersions.Contains("quilt") Then .Loaders.Add(ModLoaderTypes.Quilt)
If RawVersions.Contains("neoforge") Then .Loaders.Add(ModLoaderTypes.NeoForge)
.ModLoaders = ModLoaders.None
For Each Loader In EnumUtils.GetAllFlags(Of ModLoaders)()
If RawVersions.Contains(Loader.ToString.Lower) Then .ModLoaders = .ModLoaders Or Loader
Next
#End Region
Else
#Region "Modrinth"
@@ -183,14 +181,13 @@ Public Class ResourceVersion
'Loaders
'结果可能混杂着 Mod、数据包和服务端插件
Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList
.Loaders = New List(Of ModLoaderTypes)
.ModLoaders = ModLoaders.None
If .ResourceType.HasFlag(ResourceTypes.Mod) OrElse .ResourceType.HasFlag(ResourceTypes.DataPack) Then
If RawLoaders.Intersect({"bukkit", "folia", "paper", "purpur", "spigot"}).Any() Then .ResourceType = ResourceTypes.Plugin 'Veinminer Enchantment 同时支持服务端与 Fabric
If RawLoaders.Contains("datapack") Then .ResourceType = ResourceTypes.DataPack
If RawLoaders.Contains("forge") Then .Loaders.Add(ModLoaderTypes.Forge) : .ResourceType = ResourceTypes.Mod
If RawLoaders.Contains("neoforge") Then .Loaders.Add(ModLoaderTypes.NeoForge) : .ResourceType = ResourceTypes.Mod
If RawLoaders.Contains("fabric") Then .Loaders.Add(ModLoaderTypes.Fabric) : .ResourceType = ResourceTypes.Mod
If RawLoaders.Contains("quilt") Then .Loaders.Add(ModLoaderTypes.Quilt) : .ResourceType = ResourceTypes.Mod
For Each Loader As ModLoaders In EnumUtils.GetAllFlags(Of ModLoaders)()
If RawLoaders.Contains(Loader.ToString.Lower) Then .ModLoaders = .ModLoaders Or Loader : .ResourceType = ResourceTypes.Mod
Next
Else
'使用传入的类别，不作修改（#8377）
End If
@@ -212,8 +209,8 @@ Public Class ResourceVersion
ElseIf .GameVersions.Count > 1 Then
.GameVersions = .GameVersions.SortByComparison(AddressOf CompareVersionGE).ToList
If .ResourceType = ResourceTypes.ModPack Then .GameVersions = New List(Of String) From { .GameVersions(0)} '整合包理应只 “支持” 一个版本
ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]")) Then
.GameVersions = RawVersions.Where(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]")).ToList
ElseIf RawVersions.Any(Function(v) v.RegexCheck("[0-9]{2}w[0-9]{2}[a-z]")) Then
.GameVersions = RawVersions.Where(Function(v) v.RegexCheck("[0-9]{2}w[0-9]{2}[a-z]")).ToList
Else
.GameVersions = New List(Of String) From {"未知版本"}
End If
@@ -230,7 +227,7 @@ Public Class ResourceVersion
Dim TargetProject = ResourceProject.FromProjectId(ProjectId, Platform)
'获取项目对象的文件列表
If Not ProjectFilesCache.ContainsKey(ProjectId) Then
Log("[Resource] 开始获取项目版本列表：" & ProjectId)
Logger.Info($"开始获取项目版本列表：{ProjectId}")
Dim ResultJsonArray As JArray = Nothing
If Platform = ResourcePlatforms.CurseForge Then
For RetryCount As Integer = 0 To 2
@@ -247,10 +244,10 @@ Public Class ResourceVersion
ResultJsonArray = ResultJson("data")
Exit For
ElseIf RetryCount < 2 Then
Log($"[Resource] CurseForge 返回的资源版本列表存在缺失，即将进行第 {RetryCount + 1} 次重试", NotifyLevel.DebugModeOnly) '#6224
Log($"[Resource] 返回的原始内容如下：{vbCrLf}{ResultJson}")
Logger.Warn($"CurseForge 返回的资源版本列表存在缺失，即将进行第 {RetryCount + 1} 次重试") '#6224
Logger.Info($"返回的原始内容如下：{vbCrLf}{ResultJson}")
Else
Log($"[Resource] CurseForge 返回的资源版本列表存在缺失，返回的原始内容如下：{vbCrLf}{ResultJson}")
Logger.Info($"CurseForge 返回的资源版本列表存在缺失，返回的原始内容如下：{vbCrLf}{ResultJson}")
Throw New Exception("CurseForge 返回的资源版本列表存在缺失")
End If
Next
@@ -266,7 +263,7 @@ Public Class ResourceVersion
'加载前置信息
Dim Dependencies As List(Of String) = Result.SelectMany(Function(f) f.RawDependencies).Distinct().ToList
If Dependencies.Any Then
Log($"[Resource] 项目 {ProjectId} 中需要加载的前置：{Dependencies.Join("，")}")
Logger.Info($"项目 {ProjectId} 中需要加载的前置：{Dependencies.Join("，")}")
For Each DependencyProject In ResourceProject.FromProjectIds(Dependencies, TargetProject.Platform)
For Each File In Result
If File.RawDependencies.Contains(DependencyProject.Id) AndAlso DependencyProject.Id <> ProjectId AndAlso Not File.Dependencies.Contains(DependencyProject.Id) Then
@@ -290,16 +287,16 @@ Public Class ResourceVersion
Public Shared Function FromCacheJson(Data As JObject) As ResourceVersion
Dim Result As New ResourceVersion
With Result
.ResourceType = CType(Data("ResourceType").ToObject(Of Integer), ResourceTypes)
.ResourceType = Data("ResourceType").ToObject(Of ResourceTypes)
.Id = Data("Id").ToString
.Display = Data("DisplayName").ToString
If Data.ContainsKey("Version") Then .Version = Data("Version").ToString
.ReleaseDate = Data("ReleaseDate").ToObject(Of Date)
.DownloadCount = Data("DownloadCount").ToObject(Of Integer)
.ReleaseType = CType(Data("ReleaseType").ToObject(Of Integer), ReleaseTypes)
.ReleaseType = Data("ReleaseType").ToObject(Of ReleaseTypes)
If Data.ContainsKey("FileName") Then .FileName = Data("FileName").ToString
If Data.ContainsKey("DownloadUrls") Then .DownloadUrls = Data("DownloadUrls").ToObject(Of List(Of String))
If Data.ContainsKey("ModLoaders") Then .Loaders = Data("ModLoaders").ToObject(Of List(Of ModLoaderTypes))
If Data.ContainsKey("ModLoaders") Then .ModLoaders = Data("ModLoaders").ToObject(Of ModLoaders)
If Data.ContainsKey("Size") Then .Size = Data("Size").ToObject(Of Integer)
If Data.ContainsKey("Hash") Then .Hash = Data("Hash").ToString
If Data.ContainsKey("GameVersions") Then .GameVersions = Data("GameVersions").ToObject(Of List(Of String))
@@ -320,7 +317,7 @@ Public Class ResourceVersion
.Add("DisplayName", Display)
.Add("ReleaseDate", ReleaseDate)
.Add("DownloadCount", DownloadCount)
.Add("ModLoaders", New JArray(Loaders.Select(Function(m) CInt(m))))
.Add("ModLoaders", ModLoaders)
.Add("GameVersions", New JArray(GameVersions))
.Add("ReleaseType", CInt(ReleaseType))
If FileName IsNot Nothing Then .Add("FileName", FileName)
@@ -383,10 +380,35 @@ Public Class ResourceVersion
''' 获取下载信息。
''' </summary>
''' <param name="LocalFileOrFolder">目标本地文件夹，或完整的文件路径。会自动判断类型。</param>
Public Function ToNetFile(LocalFileOrFolder As String) As NetFile
Return New NetFile(DownloadUrls, LocalFileOrFolder & If(LocalFileOrFolder.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash, ActualSize:=Size), SimulateBrowserHeaders:=True)
Public Function ToNetFile(LocalFileOrFolder As String,
Optional TrackDownloadReason As DownloadReason? = Nothing, Optional TrackGameVersion As String = Nothing, Optional TrackLoader As ModLoaders = ModLoaders.None) As NetFile
Return New NetFile(
ParseModrinthTrackArguments(DownloadUrls, TrackDownloadReason, TrackGameVersion, TrackLoader),
LocalFileOrFolder & If(LocalFileOrFolder.EndsWithF("\"), FileName, ""),
New FileChecker(Hash:=Hash, ActualSize:=Size),
SimulateBrowserHeaders:=True)
End Function
''' <summary>
''' 添加 Modrinth 追踪参数。
''' </summary>
Public Shared Iterator Function ParseModrinthTrackArguments(Urls As List(Of String), Optional TrackDownloadReason As DownloadReason? = Nothing, Optional TrackGameVersion As String = Nothing, Optional TrackLoader As ModLoaders = ModLoaders.None) As IEnumerable(Of String)
Dim Arguments As New Dictionary(Of String, String)
If TrackDownloadReason IsNot Nothing Then Arguments.Add("mr_download_reason", TrackDownloadReason.ToString.Lower)
If TrackGameVersion IsNot Nothing Then Arguments.Add("mr_game_version", TrackGameVersion)
If TrackLoader.Flags.Any Then Arguments.Add("mr_loader", TrackLoader.Flags.First.ToString.Lower)
Dim Argument = Arguments.Select(Function(a) $"{a.Key}={a.Value}").Join("&")
For Each Url In Urls
If Not Url.ContainsIgnoreCase("cdn.modrinth.com/") Then Yield Url
Yield $"{Url}{If(Url.Contains("?"), "&", "?")}{Argument}"
Next
End Function
Public Enum DownloadReason
Standalone
Dependency
ModPack
Update
End Enum
''' <summary>
''' 重新整理 CurseForge 的下载地址。
''' </summary>
Public Shared Function ParseCurseForgeDownloadUrls(Url As String) As List(Of String)
Plain Craft Launcher 2/Modules/Resource/WikiEntry.vb
+14 -15
View File
@@ -42,33 +42,32 @@ Public Class WikiEntry
If Cache IsNot Nothing Then Return Cache
'实际加载
Cache = New List(Of WikiEntry)
Dim Data As String
Using Archive As New ZipArchive(New MemoryStream(GetResources("ModData")), ZipArchiveMode.Read)
Data = ReadFile(Archive.GetEntry("moddata.txt").Open(), Encoding.UTF8)
End Using
Dim i As Integer = 0
For Each Line In Data.ReplaceLineEndings(vbLf).Split(vbLf)
Dim DataLines As List(Of String) = DirectCast(My.Resources.ResourceManager.GetObject("ModData"), String).SplitLines().ToList()
Dim Ranks = DataLines.Last.Split("|")
DataLines.RemoveAt(DataLines.Count - 1)
For Each Line In DataLines
i += 1
If Line = "" Then Continue For
For Each EntryData As String In Line.Split("¨")
Dim Entry = New WikiEntry
Dim Splited = EntryData.Split("|")
Entry.Popularity = Val(Splited(0))
If Splited(1).StartsWithF("@") Then
If Splited(0).StartsWithF("@") Then
Entry.CurseForgeSlug = Nothing
Entry.ModrinthSlug = Splited(1).Replace("@", "")
ElseIf Splited(1).EndsWithF("@") Then
Entry.CurseForgeSlug = Splited(1).TrimEnd("@")
Entry.ModrinthSlug = Splited(0).Replace("@", "")
ElseIf Splited(0).EndsWithF("@") Then
Entry.CurseForgeSlug = Splited(0).TrimEnd("@")
Entry.ModrinthSlug = Entry.CurseForgeSlug
ElseIf Splited(1).Contains("@") Then
Entry.CurseForgeSlug = Splited(1).Split("@")(0)
Entry.ModrinthSlug = Splited(1).Split("@")(1)
ElseIf Splited(0).Contains("@") Then
Entry.CurseForgeSlug = Splited(0).Split("@")(0)
Entry.ModrinthSlug = Splited(0).Split("@")(1)
Else
Entry.CurseForgeSlug = Splited(1)
Entry.CurseForgeSlug = Splited(0)
Entry.ModrinthSlug = Nothing
End If
Entry.Id = i
If Splited.Count >= 3 Then
Entry.Popularity = Val(Ranks(i - 1))
If Splited.Count >= 2 Then
Entry.ChineseName = Splited.Last
If Entry.ChineseName.Contains("*") Then '处理 *
Entry.ChineseName = Entry.ChineseName.Replace("*",