This commit is contained in:
龙腾猫跃
2024-05-25 17:42:12 +08:00
parent 0bdef8648f
commit e1268cefdb
34 changed files with 768 additions and 526 deletions
@@ -213,6 +213,7 @@ Public Class Application
Dim MsJson As JObject = GetJson(Setup.Get("LoginMsJson"))
MsJson.Remove(sender.Tag)
Setup.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None))
If FrmLoginMs.ComboAccounts.SelectedItem Is sender.Parent Then FrmLoginMs.ComboAccounts.SelectedIndex = 0
FrmLoginMs.ComboAccounts.Items.Remove(sender.Parent)
Case McLoginType.Legacy
'离线
+24 -6
View File
@@ -13,8 +13,26 @@
MainBorder.Child = value
End Set
End Property
Public MainTextBlock As TextBlock
Public MainSwap As Shapes.Path
Private _MainTextBlock As TextBlock
Public Property MainTextBlock As TextBlock
Get
Init() '当父级触发 Loaded 时,本卡片可能尚未触发 Loaded(该事件从父级向子级调用),因此这会是 null。手动触发以确保控件已加载。
Return _MainTextBlock
End Get
Set(value As TextBlock)
_MainTextBlock = value
End Set
End Property
Private _MainSwap As Shapes.Path
Public Property MainSwap As Shapes.Path
Get
Init()
Return _MainSwap
End Get
Set(value As Shapes.Path)
_MainSwap = value
End Set
End Property
'属性
Public Uuid As Integer = GetUuid()
@@ -24,7 +42,7 @@
End Get
Set(value As String)
SetValue(TitleProperty, value)
If MainTextBlock IsNot Nothing Then MainTextBlock.Text = value
If _MainTextBlock IsNot Nothing Then MainTextBlock.Text = value
End Set
End Property
Public Shared ReadOnly TitleProperty As DependencyProperty = DependencyProperty.Register("Title", GetType(String), GetType(MyCard), New PropertyMetadata(""))
@@ -40,10 +58,11 @@
Children.Add(MainGrid)
End Sub
Private IsLoad As Boolean = False
Private Sub MyCard_Loaded() Handles Me.Loaded
Private Sub Init() Handles Me.Loaded
If IsLoad Then Exit Sub
IsLoad = True
'初次加载限定
If Not Title = "" AndAlso IsNothing(MainTextBlock) Then
If Title <> "" AndAlso MainTextBlock Is Nothing Then
MainTextBlock = New TextBlock With {.HorizontalAlignment = HorizontalAlignment.Left, .VerticalAlignment = VerticalAlignment.Top, .Margin = New Thickness(15, 12, 0, 0), .FontWeight = FontWeights.Bold, .FontSize = 13, .IsHitTestVisible = False}
MainTextBlock.SetResourceReference(TextBlock.ForegroundProperty, "ColorBrush1")
MainTextBlock.SetBinding(TextBlock.TextProperty, New Binding("Title") With {.Source = Me, .Mode = BindingMode.OneWay})
@@ -55,7 +74,6 @@
MainSwap.SetResourceReference(Shapes.Path.FillProperty, "ColorBrush1")
MainGrid.Children.Add(MainSwap)
End If
IsLoad = True
'改变默认的折叠
If IsSwaped AndAlso SwapControl IsNot Nothing Then
MainSwap.RenderTransform = New RotateTransform(If(SwapLogoRight, 270, 0))
@@ -656,9 +656,9 @@
SetResourceReference(ForegroundProperty, "ColorBrush1")
End If
ColumnPaddingRight.Width = New GridLength(MinPaddingRight)
If EventType = "打开帮助" Then
If EventType = "打开帮助" AndAlso Not (Title <> "" AndAlso Info <> "") Then '#3266
Try
Dim NewElem = New HelpEntry(GetEventAbsoluteUrls(EventData, EventType)(0)).SetToListItem(Me)
Dim Unused = New HelpEntry(GetEventAbsoluteUrls(EventData, EventType)(0)).SetToListItem(Me)
Catch ex As Exception
Log(ex, "设置帮助 MyListItem 失败", LogLevel.Msgbox)
End Try
+19 -8
View File
@@ -108,13 +108,19 @@ Public Class FormMain
'3:BUG+ IMP* FEAT-
'2:BUG* IMP-
'1:BUG-
If LastVersion < 325 Then 'Snapshot 2.7.4
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "会自动隐藏明显不可用的自动安装选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化正版登录流程和 MC 性能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复正版登录时弹出脚本错误提示的 Bug"))
FeatureCount += 17
BugCount += 19
End If
If LastVersion < 324 Then 'Snapshot 2.7.3
FeatureCount += 4
BugCount += 3
End If
If LastVersion < 322 Then 'Snapshot 2.7.2
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "添加 启动游戏前进行内存优化 设置"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 MC 性能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复安装 OptiFine 有概率失败的 Bug"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复启动 Fabric 1.20.5+ 时无法正确选择 Java 的 Bug"))
FeatureCount += 18
@@ -376,7 +382,8 @@ Public Class FormMain
AaOpacity(Me, Setup.Get("UiLauncherTransparent") / 1000 + 0.4, 250, 100),
AaDouble(Sub(i) TransformPos.Y += i, -TransformPos.Y, 600, 100, New AniEaseOutBack(AniEasePower.Weak)),
AaDouble(Sub(i) TransformRotate.Angle += i, -TransformRotate.Angle, 500, 100, New AniEaseOutBack(AniEasePower.Weak)),
AaCode(Sub()
AaCode(
Sub()
PanBack.RenderTransform = Nothing
IsWindowLoadFinished = True
Log($"[System] DPI:{DPI},系统版本:{OsVersion},PCL 位置:{PathWithName}")
@@ -386,7 +393,8 @@ Public Class FormMain
AniStart()
TimerMainStart()
'加载池
RunInNewThread(Sub()
RunInNewThread(
Sub()
'EULA 提示
If Not Setup.Get("SystemEula") Then
Select Case MyMsgBox("在使用 PCL 前,请同意 PCL 的用户协议与免责声明。", "协议授权", "同意", "拒绝", "查看用户协议与免责声明",
@@ -521,7 +529,8 @@ Public Class FormMain
If SendWarning AndAlso HasDownloadingTask() Then
If MyMsgBox("还有下载任务尚未完成,是否确定退出?", "提示", "确定", "取消") = 1 Then
'强行结束下载任务
RunInNewThread(Sub()
RunInNewThread(
Sub()
Log("[System] 正在强行停止任务")
For Each Task As LoaderBase In LoaderTaskbar.ToArray
Task.Abort()
@@ -542,13 +551,15 @@ Public Class FormMain
PanBack.RenderTransform = New TransformGroup() With {.Children = New TransformCollection({TransformRotate, TransformPos, TransformScale})}
AniStart({
AaOpacity(Me, -Opacity, 140, 40, New AniEaseOutFluent(AniEasePower.Weak)),
AaDouble(Sub(i)
AaDouble(
Sub(i)
TransformScale.ScaleX += i
TransformScale.ScaleY += i
End Sub, 0.88 - TransformScale.ScaleX, 180),
AaDouble(Sub(i) TransformPos.Y += i, 20 - TransformPos.Y, 180, 0, New AniEaseOutFluent(AniEasePower.Weak)),
AaDouble(Sub(i) TransformRotate.Angle += i, 0.6 - TransformRotate.Angle, 180, 0, New AniEaseInoutFluent(AniEasePower.Weak)),
AaCode(Sub()
AaCode(
Sub()
IsHitTestVisible = False
Top = -10000
ShowInTaskbar = False
@@ -800,14 +811,14 @@ Public Class FormMain
If FilePathList.Count > 1 Then
'必须要求全部为 jar 文件
For Each File In FilePathList
If Not {"jar", "litemod", "disabled", "old"}.Contains(File.Split(".").Last.ToLower) Then
If Not {"jar", "litemod", "disabled", "old"}.Contains(File.After(".").ToLower) Then
Hint("一次请只拖入一个文件!", HintType.Critical)
Exit Sub
End If
Next
End If
'自定义主页
Dim Extension As String = FilePath.Split(".").Last.ToLower
Dim Extension As String = FilePath.After(".").ToLower
If Extension = "xaml" Then
Log("[System] 文件后缀为 XAML,作为自定义主页加载")
If File.Exists(Path & "PCL\Custom.xaml") Then
+64 -4
View File
@@ -11,12 +11,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.7.3" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.7.3." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.7.4" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.7.4." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 323 'Release
#Else
Public Const VersionCode As Integer = 324 'Snapshot
Public Const VersionCode As Integer = 325 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -1451,7 +1451,8 @@ Re:
Try
Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
Catch ex As Exception
Throw New Exception("格式化 json 对象失败:" & If(If(Data, "").Length > 10000, Data.Substring(0, 100) & "...", Data))
Dim Length As Integer = If(Data, "").Length
Throw New Exception("格式化 json 对象失败:" & If(Length > 10000, Data.Substring(0, 100) & $"...(全长 {Length} 个字符)..." & Right(Data, 100), Data))
End Try
End Function
@@ -1544,6 +1545,51 @@ Re:
Return Input.All(Function(c) AscW(c) < 128)
End Function
''' <summary>
''' 获取在子字符串之前的部分。
''' 会裁切尽可能多的内容,但如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function Before(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.IndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(0, Pos)
Else
Return Str
End If
End Function
''' <summary>
''' 获取在子字符串之后的部分。
''' 会裁切尽可能多的内容,但如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function After(Str As String, Text As String, Optional IgnoreCase As Boolean = False) As String
Dim Pos As Integer = If(String.IsNullOrEmpty(Text), -1, Str.LastIndexOfF(Text, IgnoreCase))
If Pos >= 0 Then
Return Str.Substring(Pos + Text.Length)
Else
Return Str
End If
End Function
''' <summary>
''' 获取处于两个子字符串之间的部分。
''' 会裁切尽可能多的内容:匹配开始使用 LastIndexOf,匹配结束使用 IndexOf,但如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function Between(Str As String, Before As String, After As String, Optional IgnoreCase As Boolean = False) As String
Dim StartPos As Integer = If(String.IsNullOrEmpty(Before), -1, Str.LastIndexOfF(Before, IgnoreCase))
If StartPos >= 0 Then
StartPos += Before.Length
Else
StartPos = 0
End If
Dim EndPos As Integer = If(String.IsNullOrEmpty(After), -1, Str.IndexOfF(After, StartPos, IgnoreCase))
If EndPos >= 0 Then
Return Str.Substring(StartPos, EndPos - StartPos)
ElseIf StartPos > 0 Then
Return Str.Substring(StartPos)
Else
Return Str
End If
End Function
''' <summary>
''' 高速的 StartsWith。
''' </summary>
@@ -1573,12 +1619,26 @@ Re:
Return Str.IndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 高速的 IndexOf。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function IndexOfF(Str As String, SubStr As String, StartIndex As Integer, Optional IgnoreCase As Boolean = False) As Integer
Return Str.IndexOf(SubStr, StartIndex, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 高速的 LastIndexOf。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function LastIndexOfF(Str As String, SubStr As String, Optional IgnoreCase As Boolean = False) As Integer
Return Str.LastIndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 高速的 LastIndexOf。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function LastIndexOfF(Str As String, SubStr As String, StartIndex As Integer, Optional IgnoreCase As Boolean = False) As Integer
Return Str.LastIndexOf(SubStr, StartIndex, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 输入 And 字符不会报错的 Val。
@@ -266,7 +266,7 @@
Public Output As OutputType = Nothing
'获取输入
Public Function StartGetInput(Optional Input As InputType = Nothing, Optional InputDelegate As Func(Of Object) = Nothing) As InputType
Public Function StartGetInput(Optional Input As InputType = Nothing, Optional InputDelegate As Func(Of Object) = Nothing) As InputType 'InputDelegate 参数存在匿名调用
If InputDelegate Is Nothing Then InputDelegate = Me.InputDelegate
Dim NewInput As InputType = Nothing '若 InputType 不能为 Nothing,则会导致 Input Is Nothing 永远失败,因此需要额外判断
If (Input Is Nothing OrElse (NewInput IsNot Nothing AndAlso Input.Equals(NewInput))) AndAlso InputDelegate IsNot Nothing Then
+12 -4
View File
@@ -781,7 +781,7 @@ RequestFinished:
''' <summary>
''' 为不需要分割的小文件进行临时存储。
''' </summary>
Private SmailFileCache As List(Of Byte)
Private SmailFileCache As Queue(Of Byte)
''' <summary>
''' 文件的已下载大小。
@@ -1101,7 +1101,7 @@ NotSupportRange:
'创建缓存文件
If IsNoSplit Then
Info.Temp = Nothing
SmailFileCache = New List(Of Byte)
SmailFileCache = New Queue(Of Byte)
Else
Info.Temp = PathTemp & "Download\" & Uuid & "_" & Info.Uuid & "_" & RandomInteger(0, 999999) & ".tmp"
ResultStream = New FileStream(Info.Temp, FileMode.Create, FileAccess.Write, FileShare.Read)
@@ -1152,9 +1152,15 @@ NotSupportRange:
Info.DownloadDone += RealDataCount
If IsNoSplit Then
If HttpData.Count = RealDataCount Then
SmailFileCache.AddRange(HttpData)
'SmailFileCache.AddRange(HttpData)
For Each B In HttpData
SmailFileCache.Enqueue(B)
Next
Else
SmailFileCache.AddRange(HttpData.ToList.GetRange(0, RealDataCount))
'SmailFileCache.AddRange(HttpData.ToList.GetRange(0, RealDataCount))
For i = 0 To RealDataCount - 1
SmailFileCache.Enqueue(HttpData(i))
Next
End If
Else
ResultStream.Write(HttpData, 0, RealDataCount)
@@ -1456,7 +1462,9 @@ Retry:
Public Overrides Property Progress As Double
Get
If State >= LoadState.Finished Then Return 1
SyncLock FilesLock
If Not Files.Any() Then Return 0 '必须返回 0,否则在获取列表的时候会错觉已经下载完了
End SyncLock
Return _Progress
End Get
Set(value As Double)
@@ -149,7 +149,7 @@ Public Class ValidateExcept
End Sub
Public Overrides Function Validate(Str As String) As String
For Each Ch As String In Excepts
If Str.IndexOfF(Ch, StringComparison.OrdinalIgnoreCase) >= 0 Then
If Str.IndexOfF(Ch, True) >= 0 Then
If IsNothing(ErrorMessage) Then ErrorMessage = ""
Return ErrorMessage.Replace("%", Ch)
End If
@@ -265,7 +265,7 @@
Next
CurseForgeFileIds = Files.Select(Function(f) f.Key).Distinct.ToList
GameVersions = Files.SelectMany(Function(f) f.Value).Where(Function(v) v.StartsWithF("1.")).
Select(Function(v) CInt(Val(v.Split(".")(1).Split("-").First))).Where(Function(v) v > 0).
Select(Function(v) CInt(Val(v.Split(".")(1).Before("-")))).Where(Function(v) v > 0).
Distinct.OrderByDescending(Function(v) v).ToList
ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
'Type
@@ -342,7 +342,7 @@
'搜索结果的键为 versions,获取特定工程的键为 game_versions
GameVersions = If(CType(If(Data("game_versions"), Data("versions")), JArray), New JArray).
Select(Function(v) v.ToString).Where(Function(v) v.StartsWithF("1.")).
Select(Of Integer)(Function(v) Val(v.Split(".")(1).Split("-").First)).Where(Function(v) v > 0).
Select(Of Integer)(Function(v) Val(v.Split(".")(1).Before("-"))).Where(Function(v) v > 0).
Distinct.OrderByDescending(Function(v) v).ToList
'Type
Select Case Data("project_type").ToString
@@ -576,9 +576,9 @@
'有中文翻译
'尝试将文本分为三段:Title (EnglishName) - Suffix
'检查时注意 Carpet:它没有中文译名,但有 Suffix
Title = TranslatedName.Split(" (").First.Split(" - ").First
Title = TranslatedName.Before(" (").Before(" - ")
Dim Suffix As String = ""
If TranslatedName.Split(")").Last.Contains(" - ") Then Suffix = TranslatedName.Split(")").Last.Split(" - ").Last
If TranslatedName.After(")").Contains(" - ") Then Suffix = TranslatedName.After(")").After(" - ")
Dim EnglishName As String = TranslatedName
If Suffix <> "" Then EnglishName = EnglishName.Replace(" - " & Suffix, "")
EnglishName = EnglishName.Replace(Title, "").Trim("("c, ")"c, " "c)
@@ -751,7 +751,7 @@ NoSubtitle:
Case CompType.ResourcePack
'FUTURE: Res
End Select
Address += "&categoryId=" & If(Tag = "", "0", Tag.Split("/").First)
Address += "&categoryId=" & If(Tag = "", "0", Tag.Before("/"))
If ModLoader <> CompModLoaderType.Any Then Address += "&modLoaderType=" & CType(ModLoader, Integer)
If Not String.IsNullOrEmpty(GameVersion) Then Address += "&gameVersion=" & GameVersion
If Not String.IsNullOrEmpty(SearchText) Then Address += "&searchFilter=" & Net.WebUtility.UrlEncode(SearchText)
@@ -772,7 +772,7 @@ NoSubtitle:
'facets=[["categories:'game-mechanics'"],["categories:'forge'"],["versions:1.19.3"],["project_type:mod"]]
Dim Facets As New List(Of String)
Facets.Add($"[""project_type:{GetStringFromEnum(Type).ToLower}""]")
If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.Split("/").Last}'""]")
If Not String.IsNullOrEmpty(Tag) Then Facets.Add($"[""categories:'{Tag.After("/")}'""]")
If ModLoader <> CompModLoaderType.Any Then Facets.Add($"[""categories:'{GetStringFromEnum(ModLoader).ToLower}'""]")
If Not String.IsNullOrEmpty(GameVersion) Then Facets.Add($"[""versions:'{GameVersion}'""]")
Address += "&facets=[" & String.Join(",", Facets) & "]"
@@ -880,7 +880,7 @@ NoSubtitle:
If Not SearchResults(i).AbsoluteRight AndAlso i >= Math.Min(2, SearchResults.Count - 1) Then Exit For '把 3 个结果拼合以提高准确度
If SearchResults(i).Item.CurseForgeSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.CurseForgeSlug.Replace("-", " ").Replace("/", " ") & " "
If SearchResults(i).Item.ModrinthSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.ModrinthSlug.Replace("-", " ").Replace("/", " ") & " "
SearchResult += SearchResults(i).Item.ChineseName.Split(" (").Last.TrimEnd(") ").Split(" - ").First.
SearchResult += SearchResults(i).Item.ChineseName.After(" (").TrimEnd(") ").Before(" - ").
Replace(":", "").Replace("(", "").Replace(")", "").ToLower.Replace("/", " ") & " "
Next
Log("[Comp] 中文搜索原始关键词:" & SearchResult, LogLevel.Developer)
@@ -1133,7 +1133,7 @@ Retry:
'描述性信息
''' <summary>
''' 文件描述名(并非文件名,是自定义的字段)。
''' 文件描述名(并非文件名,是自定义的字段)。对很多 Mod,这会给出 Mod 版本号。
''' </summary>
Public DisplayName As String
''' <summary>
@@ -1305,7 +1305,7 @@ Retry:
'GameVersions
Dim RawVersions As List(Of String) = Data("game_versions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.") OrElse v.StartsWithF("b1.")).
Select(Function(v) If(v.Contains("-"), v.Split("-").First & " 快照", If(v.StartsWithF("b1."), "远古版本", v))).ToList
Select(Function(v) If(v.Contains("-"), v.Before("-") & " 快照", If(v.StartsWithF("b1."), "远古版本", v))).ToList
If GameVersions.Count > 1 Then
GameVersions = Sort(GameVersions, AddressOf VersionSortBoolean).ToList
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
@@ -1403,7 +1403,7 @@ Retry:
'辅助函数
Public Overrides Function ToString() As String
Return $"{Id}: {DisplayName}"
Return $"{Id}: {FileName}"
End Function
End Class
@@ -312,16 +312,30 @@ Extracted:
End Function
''' <summary>
''' 输出字符串的前后某些行,并统一行尾为 vbLf (\r)、删除空行。
''' 输出字符串的前后某些行,并统一行尾为 vbLf (正则 \n)、删除空行和重复行。
''' </summary>
Private Function GetHeadTailLines(Raw As String(), HeadLines As Integer, TailLines As Integer) As String
If Raw.Length <= HeadLines + TailLines Then Return Join(Raw, vbLf)
If Raw.Length <= HeadLines + TailLines Then Return Join(Raw.Distinct, vbLf)
Dim Lines As New List(Of String)
Dim RealHeadLines As Integer = 0, ViewedLines As Integer
For ViewedLines = 0 To Raw.Length - 1
If Lines.Contains(Raw(ViewedLines)) Then Continue For
RealHeadLines += 1
Lines.Add(Raw(ViewedLines))
If RealHeadLines >= HeadLines Then Exit For
Next
Dim RealTailLines = 0
For i = Raw.Length - 1 To ViewedLines Step -1
If Lines.Contains(Raw(i)) Then Continue For
RealTailLines += 1
Lines.Insert(RealHeadLines, Raw(i))
If RealTailLines >= TailLines Then Exit For
Next
Dim Result As New StringBuilder
For i = 0 To Raw.Count - 1
If i < HeadLines OrElse Raw.Count - i < TailLines Then
If Raw(i) = "" Then Continue For
Result.Append(Raw(i) & vbLf)
End If
For Each Line In Lines
If Line = "" Then Continue For
Result.Append(Line)
Result.Append(vbLf)
Next
Return Result.ToString
End Function
@@ -353,6 +367,7 @@ Extracted:
光影或资源包导致OpenGL1282错误
文件或内容校验失败
确定Mod导致游戏崩溃
怀疑Mod导致游戏崩溃
Mod配置文件导致游戏崩溃
ModMixin失败
Mod加载器报错
@@ -398,23 +413,21 @@ Extracted:
'崩溃日志
If LogCrash IsNot Nothing Then
Log("[Crash] 开始进行崩溃日志堆栈分析")
Dim StackLogs As String = LogCrash.Split("System Details").First
Keywords.AddRange(AnalyzeStackKeyword(StackLogs))
Keywords.AddRange(AnalyzeStackKeyword(LogCrash.Before("System Details")))
End If
'Minecraft 日志
If LogMc IsNot Nothing Then
Dim Fatals = RegexSearch(LogMc, "/FATAL] [\w\W]+?(?=[\n]+\[)")
Dim Fatals As List(Of String) = RegexSearch(LogMc, "/FATAL] .+?(?=[\n]+\[)")
If LogMc.Contains("Unreported exception thrown!") Then Fatals.Add(LogMc.Between("Unreported exception thrown!", "at oolloo.jlw.Wrapper"))
Log("[Crash] 开始进行 Minecraft 日志堆栈分析,发现 " & Fatals.Count & " 个报错项")
If Fatals.Any Then
For Each Fatal In Fatals
Keywords.AddRange(AnalyzeStackKeyword(Fatal))
Next
End If
End If
'虚拟机日志
If LogHs IsNot Nothing Then
Log("[Crash] 开始进行虚拟机堆栈分析")
Dim StackLogs As String = LogHs.Split("Registers:").First.Split("T H R E A D").Last
Dim StackLogs As String = LogHs.Between("T H R E A D", "Registers:")
Keywords.AddRange(AnalyzeStackKeyword(StackLogs))
End If
'Mod 名称分析
@@ -502,7 +515,7 @@ Done:
If LogMc.Contains("Extracted mod jars found, loading will NOT continue") Then AppendReason(CrashReason.Mod文件被解压)
If LogMc.Contains("java.lang.ClassNotFoundException: org.spongepowered.asm.launch.MixinTweaker") Then AppendReason(CrashReason.MixinBootstrap缺失)
If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
If LogMc.Contains("java.lang.OutOfMemoryError") Then AppendReason(CrashReason.内存不足)
If LogMc.Contains("java.lang.OutOfMemoryError") OrElse LogMc.Contains("an out of memory error") Then AppendReason(CrashReason.内存不足)
If LogMc.Contains("java.lang.RuntimeException: Shaders Mod detected. Please remove it, OptiFine has built-in support for shaders.") Then AppendReason(CrashReason.ShadersMod与Optifine同时安装)
If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容)
If LogMc.Contains("1282: Invalid operation") Then AppendReason(CrashReason.光影或资源包导致OpenGL1282错误)
@@ -530,6 +543,7 @@ Done:
'Mod 重复安装
If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]{1}:[^\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))
'Mod 缺少前置
If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then
@@ -556,10 +570,10 @@ 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不兼容)
'Mod 导致的崩溃
If LogCrash.Contains("-- MOD ") Then
Dim LogLeft = LogCrash.Split("-- MOD").Last
If LogLeft.Contains("Failure message: MISSING") Then
If LogCrash.Between("-- MOD ", "Failure message:").ContainsF(".jar", True) Then
AppendReason(CrashReason.确定Mod导致游戏崩溃, If(RegexSeek(LogCrash, "(?<=Mod File: ).+"), "").TrimEnd((vbCrLf & " ").ToCharArray))
Else
AppendReason(CrashReason.Mod加载器报错, If(RegexSeek(LogCrash, "(?<=Failure message: )[\w\W]+?(?=\tMod)"), "").Replace(vbTab, " ").TrimEnd((vbCrLf & " ").ToCharArray))
@@ -584,19 +598,9 @@ Done:
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法,这样做可能会解决你的问题:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法,这样做可能会解决你的问题:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
End If
End Sub
''' <summary>
''' 进行精准日志匹配。匹配优先级低于堆栈分析的崩溃。
''' </summary>
Private Sub AnalyzeCrit3()
'游戏日志分析
If LogMc IsNot Nothing Then
'Mixin 崩溃
If LogMc.Contains("Mixin prepare failed ") OrElse LogMc.Contains("Mixin apply failed ") OrElse LogMc.Contains("MixinApplyError") OrElse
LogMc.Contains("mixin.injection.throwables.") OrElse LogMc.Contains(".mixins.json] FAILED during )") Then
LogMc.Contains("mixin.injection.throwables.") OrElse LogMc.Contains(".json] FAILED during )") Then
Dim ModId As String = RegexSeek(LogMc, "(?<=in )[^./ ]+(?=.mixins.json.+failed injection check)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=in mixins.)[^./ ]+(?=.json.+failed injection check)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= failed .+ in )[^./ ]+(?=.mixins.json)")
@@ -614,6 +618,24 @@ Done:
'在 #3104 的情况下,这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败
If LogMc.Contains("due to errors, provided by ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
End If
End If
'崩溃报告分析
If LogCrash IsNot Nothing Then
If LogCrash.Contains("Suspected Mod") Then
Dim Suspects = RegexSearch(LogCrash.Between("Suspected Mod", "Stacktrace"), "(?<=\n\t[^(\t]+\()[^)\n]+")
If Suspects.Any Then AppendReason(CrashReason.怀疑Mod导致游戏崩溃, TryAnalyzeModName(Suspects))
End If
End If
End Sub
''' <summary>
''' 进行精准日志匹配。匹配优先级低于堆栈分析的崩溃。
''' </summary>
Private Sub AnalyzeCrit3()
'游戏日志分析
If LogMc IsNot Nothing Then
'极短的程序输出
If Not (LogMc.Contains("at net.") OrElse LogMc.Contains("INFO]")) AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing AndAlso LogMc.Length < 100 Then
AppendReason(CrashReason.极短的程序输出, LogMc)
@@ -634,9 +656,13 @@ Done:
''' 从堆栈中提取 Mod ID 关键字。若失败则返回空列表。
''' </summary>
Private Function AnalyzeStackKeyword(ErrorStack As String) As List(Of String)
ErrorStack = vbLf & If(ErrorStack, "") & vbLf
'进行正则匹配
Dim StackSearchResults As List(Of String) = RegexSearch(If(ErrorStack, "") & vbCrLf, "(?<=\n[^{]+)[a-zA-Z]+\w+\.[a-zA-Z]+[\w\.]+(?=\.[\w\.$]+\.)")
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 = StackSearchResults.Distinct.ToList
'检查堆栈开头
Dim PossibleStacks As New List(Of String)
@@ -649,7 +675,7 @@ Done:
"MojangTricksIntelDriversForPerformance_javaw"}
If Stack.StartsWithF(IgnoreStack) Then GoTo NextStack
Next
PossibleStacks.Add(Stack.Trim) '.Split("$").First)
PossibleStacks.Add(Stack.Trim)
NextStack:
Next
PossibleStacks = PossibleStacks.Distinct.ToList
@@ -666,13 +692,13 @@ NextStack:
For i = 0 To Math.Min(3, Splited.Count - 1) '最多取前 4 节
Dim Word As String = Splited(i)
If Word.Length <= 2 OrElse Word.StartsWithF("func_") Then Continue For
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top",
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi",
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty",
"gitlab", "common", "server", "config", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe",
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules",
"fastutil", "optifine", "internal", "platform", "override",
"listeners", "scheduler", "minecraft", "transformers", "universal", "multipart", "minecraftforge", "blockentity"
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top", "mcp",
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi", "impl", "data", "pool", "task",
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world",
"gitlab", "common", "server", "config", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events",
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
"fastutil", "optifine", "internal", "platform", "override", "fabricmc",
"injection", "listeners", "scheduler", "minecraft", "transformer", "transformers", "universal", "multipart", "minecraftforge", "blockentity", "spongepowered", "electronwill"
}.Contains(Word.ToLower) Then Continue For
PossibleWords.Add(Word.Trim)
Next
@@ -712,7 +738,7 @@ NextStack:
Details = Details.Replace("Fabric Mods", "¨")
Log("[Crash] 崩溃报告中检测到 Fabric Mod 信息格式")
End If
Details = Details.Split("¨").Last
Details = Details.After("¨")
'[Forge] 获取所有包含 .jar 的行
'[Fabric] 获取所有包含 Mod 信息的行
@@ -795,13 +821,20 @@ NextStack:
End If
End Function
''' <summary>
''' 尝试获取 Mod 名称,若失败则返回原关键字。
''' 尝试从关键字获取 Mod 名称,若失败则返回原关键字。
''' </summary>
Private Function TryAnalyzeModName(Keywords As String) As List(Of String)
Dim RawList As New List(Of String) From {If(Keywords, "")}
If String.IsNullOrEmpty(Keywords) Then Return RawList
Private Function TryAnalyzeModName(Keyword As String) As List(Of String)
Dim RawList As New List(Of String) From {If(Keyword, "")}
If String.IsNullOrEmpty(Keyword) Then Return RawList
Return If(AnalyzeModName(RawList), RawList)
End Function
''' <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)
End Function
'4:根据原因输出信息
Private OutputFiles As New List(Of String)
@@ -814,7 +847,7 @@ NextStack:
Dim ShowLog As Action =
Sub()
If File.Exists(DirectFile.Value.Key) Then
ShellOnly(DirectFile.Value.Key)
ShellOnly("notepad", DirectFile.Value.Key)
Else
Dim FilePath As String = PathTemp & "Crash.txt"
WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf))
@@ -911,39 +944,39 @@ NextStack:
End If
Case CrashReason.堆栈分析发现关键字
If Additional.Count = 1 Then
Results.Add("你的游戏遇到了一些问题,这可能是某些 Mod 所引起的,PCL 找到了一个可疑的关键词:" & Additional.First & "。\n\n如果你知道它对应的 Mod,那么有可能就是它引起的错误,你也可以查看错误报告获取详情。\h")
Results.Add("你的游戏遇到了一些问题,PCL 为此找到了一个可疑的关键词:" & Additional.First & "。\n\n如果你知道某个关键词对应的 Mod,那么有可能就是它引起的错误,你也可以查看错误报告获取详情。\h")
Else
Results.Add("你的游戏遇到了一些问题,这可能是某些 Mod 所引起的,PCL 找到了以下可疑的关键词:\n - " & Join(Additional, ", ") & "\n\n如果你知道这些关键词对应的 Mod,那么有可能就是它引起的错误,你也可以查看错误报告获取详情。\h")
Results.Add("你的游戏遇到了一些问题,PCL 为此找到了以下可疑的关键词:\n - " & Join(Additional, ", ") & "\n\n如果你知道某个关键词对应的 Mod,那么有可能就是它引起的错误,你也可以查看错误报告获取详情。\h")
End If
Case CrashReason.堆栈分析发现Mod名称
Case CrashReason.堆栈分析发现Mod名称, CrashReason.怀疑Mod导致游戏崩溃
If Additional.Count = 1 Then
Results.Add("名为 " & Additional.First & " 的 Mod 可能导致了游戏出错。\n\e\h")
Results.Add("PCL 怀疑名为 " & Additional.First & " 的 Mod 导致了游戏出错,但不能完全确定。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("可能是以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n\e\h")
Results.Add("PCL 怀疑以下 Mod 导致了游戏出错,但不能完全确定:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.确定Mod导致游戏崩溃
If Additional.Count = 1 Then
Results.Add("名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错。\n\e\h")
Results.Add("名为 " & Additional.First & " 的 Mod 导致了游戏出错。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n\e\h")
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.ModMixin失败
If Additional.Count = 1 Then
Results.Add("名称或 ID 为 " & Additional.First & " 的 Mod 注入失败,导致游戏出错。\n这一般代表着该 Mod 存在 Bug,或与当前环境不兼容。\n\e\h")
Results.Add("名为 " & Additional.First & " 的 Mod 注入失败,导致游戏出错。\n这一般代表着它与其他 Mod 或当前环境不兼容,或是它存在 Bug。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n这一般代表着这些 Mod 存在 Bug,或与当前环境不兼容。\n\e\h")
Results.Add("以下 Mod 导致了游戏出错:\n - " & Join(Additional, "\n - ") & "\n这一般代表着它们与其他 Mod 或当前环境不兼容,或是它存在 Bug。\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.Mod配置文件导致游戏崩溃
If Additional(1) Is Nothing Then
Results.Add("名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错。\n\e\h")
Results.Add("名为 " & Additional.First & " 的 Mod 导致了游戏出错。\n\e\h")
Else
Results.Add("名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错:\n其配置文件 " & Additional(1) & " 存在异常,无法读取。")
Results.Add("名为 " & Additional.First & " 的 Mod 导致了游戏出错:\n其配置文件 " & Additional(1) & " 存在异常,无法读取。")
End If
Case CrashReason.Mod初始化失败
If Additional.Count = 1 Then
Results.Add("名为 " & Additional.First & " 的 Mod 初始化失败,导致游戏无法继续加载。\n\e\h")
Results.Add("名为 " & Additional.First & " 的 Mod 初始化失败,导致游戏无法继续加载。\n你可以尝试禁用此 Mod,然后观察游戏是否还会崩溃。\n\e\h")
Else
Results.Add("以下 Mod 初始化失败,导致游戏无法继续加载:\n - " & Join(Additional, "\n - ") & "\n\e\h")
Results.Add("以下 Mod 初始化失败,导致游戏无法继续加载:\n - " & Join(Additional, "\n - ") & "\n\n你可以尝试依次禁用上述 Mod,然后观察游戏是否还会崩溃。\n\e\h")
End If
Case CrashReason.特定方块导致崩溃
If Additional.Count = 1 Then
@@ -1028,8 +1061,6 @@ NextStack:
End Select
Next
'整理多个原因
IsHandAnalyze = False
Return Join(Results, "\n\n此外,").
Replace("\n", vbCrLf).
Replace("\h", "").
@@ -1039,7 +1070,7 @@ NextStack:
If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "",
vbCrLf & "如果要寻求帮助,请向他人发送错误报告文件,而不是发送这个窗口的截图。" &
If(If(PageSetupSystem.IsLauncherNewest(), True), "",
vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新到最新版可能会修复这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。"))
vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。"))
End Function
End Class
@@ -1,5 +1,5 @@
Public Module ModJava
Public JavaListCacheVersion As Integer = 5
Public JavaListCacheVersion As Integer = 6
''' <summary>
''' 目前所有可用的 Java。
@@ -131,7 +131,9 @@
Version = New Version(1, Version.Major, Version.Build, Version.Revision)
End If
Is64Bit = Output.Contains("64-bit")
If Version.Minor <= 4 OrElse Version.Minor >= 25 Then Throw New Exception("分析详细信息失败,获取的版本为 " & Version.ToString)
If Version.Minor <= 4 OrElse Version.Minor >= 25 Then Throw New ApplicationException("分析详细信息失败,获取的版本为 " & Version.ToString)
'基于 #3649,在 64 位系统上禁用 32 位 Java
If Not Is64Bit AndAlso Not Is32BitSystem Then Throw New Exception("该 Java 为 32 位版本,请安装 64 位的 Java")
'基于 #2249 发现 JRE 17 似乎也导致了 Forge 安装失败,干脆禁用更多版本的 JRE
If IsJre AndAlso VersionCode >= 16 Then Throw New Exception("由于高版本 JRE 对游戏的兼容性很差,因此不再允许使用。你可以使用对应版本的 JDK,而非 JRE!")
Catch ex As ApplicationException
@@ -197,10 +199,15 @@
Setup.Set("LaunchArgumentJavaAll", "[]")
End Try
End Sub
''' <summary>
''' 防止多个需要 Java 的部分同时要求下载 Java(#3797)。
''' </summary>
Public JavaLock As New Object
''' <summary>
''' 根据要求返回最适合的 Java,若找不到则返回 Nothing。
''' 最小与最大版本在与输入相同时也会通过。
''' 必须在工作线程调用。
''' 必须在工作线程调用,且必须包括 SyncLock JavaLock。
''' </summary>
Public Function JavaSelect(CancelException As String, Optional MinVersion As Version = Nothing, Optional MaxVersion As Version = Nothing,
Optional RelatedVersion As McVersion = Nothing) As JavaEntry
@@ -460,8 +467,8 @@ NoUserJava:
If Not Left.IsJre AndAlso Right.IsJre Then Return False
'4. Java 大版本
If Left.VersionCode <> Right.VersionCode Then
' Java 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21...
Dim Weight = {0, 1, 2, 3, 4, 5, 6, 14, 30, 10, 12, 15, 13, 9, 8, 7, 11, 31, 29, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28}
' Java 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23...
Dim Weight = {0, 1, 2, 3, 4, 5, 6, 14, 30, 10, 12, 15, 13, 9, 8, 7, 11, 31, 29, 16, 17, 28, 27, 26, 25, 24, 23, 22, 21, 20, 19, 18}
Return Weight.ElementAtOrDefault(Left.VersionCode) >= Weight.ElementAtOrDefault(Right.VersionCode)
End If
'5. 最次级版本号更接近 51
@@ -601,7 +608,8 @@ NoUserJava:
'启动检查线程
Dim CheckThreads As New List(Of Thread)
For Each Entry In JavaEntries
Dim CheckThread As New Thread(Sub()
Dim CheckThread As New Thread(
Sub()
Try
Entry.Check()
If ModeDebug Then Log("[Java] - " & Entry.ToString)
@@ -358,7 +358,7 @@ NextInner:
Case McLoginType.Ms
If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
Case McLoginType.Legacy
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Split("¨")(0)
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Before("¨")
Case McLoginType.Nide
If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
Case McLoginType.Auth
@@ -368,7 +368,7 @@ NextInner:
If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName")
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Split("¨")(0)
If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Before("¨")
Return Nothing
End Function
''' <summary>
@@ -524,7 +524,10 @@ Relogin:
Dim AccessToken As String = MsLoginStep5(Tokens)
Data.Progress = 0.8
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim Result = MsLoginStep6(AccessToken)
MsLoginStep6(AccessToken)
Data.Progress = 0.9
If Data.IsAborted Then Throw New ThreadInterruptedException
Dim Result = MsLoginStep7(AccessToken)
'输出登录结果
Setup.Set("CacheMsOAuthRefresh", OAuthRefreshToken)
Setup.Set("CacheMsAccess", AccessToken)
@@ -540,7 +543,7 @@ Relogin:
SkipLogin:
McLaunchLog("微软登录完成")
Setup.Set("HintBuy", True) '关闭正版购买提示
Data.Progress = 0.95
Data.Progress = 0.98
If ThemeUnlock(10, False) Then MyMsgBox("感谢你对正版游戏的支持!" & vbCrLf & "隐藏主题 跳票红 已解锁!", "提示")
End Sub
Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
@@ -797,14 +800,14 @@ LoginFinish:
'微软登录步骤 1:打开网页认证,获取 OAuth Code
Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
McLaunchLog("开始微软登录步骤 1")
If OsVersion <= New Version(10, 0, 17763, 0) Then
If True OrElse OsVersion <= New Version(10, 0, 17763, 0) Then '由于 #3849,WebBrowser 已经无法正常加载微软登录网页了
SystemBrowser:
'Windows 7 或老版 Windows 10 登录
OpenWebsite(FormLoginOAuth.LoginUrl1)
Dim Result As String =
MyMsgBoxInput("等待网页登录",
"在登录成功后,网页会变成一片空白,请将该空白页面的网址复制到下面的框中。" & vbCrLf &
"如果网络环境不佳,登录网页可能一直加载不出来,此时请尝试使用 VPN 或加速器,然后再试。",
"登录完成后,网页会变得完全空白,把那个空白网页的网址复制到下面的框中就行了!" & vbCrLf &
"如果网络环境不佳,它可能一直加载不出来,那就只能试试用 VPN 或加速器了。",
ValidateRules:=New ObjectModel.Collection(Of Validate) From {New ValidateRegex("(?<=code\=)[^&]+", "返回网址应以 https://login.live.com/oauth20_desktop.srf?code= 开头")},
HintText:="https://login.live.com/oauth20_desktop.srf?code=XXXXXX")
If Result Is Nothing Then
@@ -813,7 +816,7 @@ SystemBrowser:
Else
Return RegexSeek(Result, "(?<=code\=)[^&]+")
End If
Hint("网页登录已完成,你现在可以关闭浏览器上的那个网页了", HintType.Finish)
Hint("网页登录成功,你可以关闭浏览器啦!", HintType.Finish)
Else
'Windows 10 登录
Dim ReturnCode As String = Nothing
@@ -926,12 +929,18 @@ SystemBrowser:
Try
Result = NetRequestMulty("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
Catch ex As Net.WebException
If ex.Message.Contains("2148916233") Then
If MyMsgBox("该微软账号尚未购买 Minecraft Java 版,或尚未注册 Xbox 账户。" & vbCrLf &
"如果你确定该账号完成了上述步骤,请先在游戏官网登录一次,然后再在启动器登录。", "登录提示", "打开游戏官网", "取消") = 1 Then
OpenWebsite("https://www.minecraft.net/")
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
If ex.Message.Contains("2148916227") Then
MyMsgBox("该账号似乎已被微软封禁,无法登录。", "登录失败", "我知道了", IsWarn:=True)
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916233") Then
If MyMsgBox("你尚未注册 Xbox 账户,请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then
OpenWebsite("https://signup.live.com/signup")
End If
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916235") Then
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请尝试使用加速器或 VPN。", "登录失败", "我知道了")
Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916238") Then
If MyMsgBox("该账号年龄不足,你需要先修改出生日期,然后才能登录。" & vbCrLf &
"该账号目前填写的年龄是否在 13 岁以上?", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then
@@ -979,28 +988,44 @@ SystemBrowser:
Dim AccessToken As String = ResultJson("access_token").ToString
Return AccessToken
End Function
'微软登录步骤 6:从 Minecraft AccessToken 获取 {UUID, UserName, ProfileJson}
Private Function MsLoginStep6(AccessToken As String) As String()
'微软登录步骤 6:验证微软账号是否持有 MC,这也会刷新 XGP
Private Sub MsLoginStep6(AccessToken As String)
McLaunchLog("开始微软登录步骤 6")
Dim Result As String = NetRequestMulty("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Try
Dim ResultJson As JObject = GetJson(Result)
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
Select Case MyMsgBox("你尚未购买正版 Minecraft,或者 Xbox Game Pass 已到期。", "登录失败", "购买 Minecraft", "取消")
Case 1
OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj")
End Select
Throw New Exception("$$")
End If
Catch ex As Exception
Log(ex, "微软登录第 6 步异常:" & Result)
Throw
End Try
End Sub
'微软登录步骤 7:从 Minecraft AccessToken 获取 {UUID, UserName, ProfileJson}
Private Function MsLoginStep7(AccessToken As String) As String()
McLaunchLog("开始微软登录步骤 7")
Dim Result As String
Try
NetRequestMulty("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Result = NetRequestMulty("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then
Log(ex, "微软登录第 6 步汇报 429")
Log(ex, "微软登录第 7 步汇报 429")
Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
ElseIf Message.Contains("(404)") Then
Log(ex, "微软登录第 6 步汇报 404")
RunInNewThread(Sub()
Select Case MyMsgBox("你可能没有创建 Minecraft 玩家档案、Xbox Game Pass 已到期,或者还没有购买 Minecraft。" & vbCrLf &
"如果您确认您已购买 Minecraft 或您的 Xbox Game Pass 未过期,请创建档案,之后即可使用 PCL 登录。", "登录失败", "创建档案", "购买 Minecraft", "取消")
Log(ex, "微软登录第 7 步汇报 404")
RunInNewThread(
Sub()
Select Case MyMsgBox("请先创建 Minecraft 玩家档案,然后再重新登录。", "登录失败", "创建档案", "取消")
Case 1
OpenWebsite("https://www.minecraft.net/zh-hans/msaprofile/mygames/editprofile")
Case 2
OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj")
End Select
End Sub, "Login Failed: Create Profile")
Throw New Exception("$$")
@@ -1169,6 +1194,8 @@ SystemBrowser:
MinVer = If(New Version(1, 8, 0, 101) > MinVer, New Version(1, 8, 0, 101), MinVer)
End If
SyncLock JavaLock
'选择 Java
McLaunchLog("Java 版本需求:最低 " & MinVer.ToString & ",最高 " & MaxVer.ToString)
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
@@ -1190,7 +1217,7 @@ SystemBrowser:
If Not JavaDownloadConfirm("Java 17") Then Throw New Exception("$$")
ElseIf MaxVer < New Version(1, 8, 0, 0) Then
JavaCode = 7
If Not JavaDownloadConfirm("Java 7") Then Throw New Exception("$$")
If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 100) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = "8u101"
If Not JavaDownloadConfirm("Java 8.0.101 ~ 8.0.320", True) Then Throw New Exception("$$")
@@ -1228,6 +1255,7 @@ SystemBrowser:
Throw New Exception("$$")
End If
End SyncLock
End Sub
#End Region
@@ -1342,7 +1370,7 @@ SystemBrowser:
If Not ArgumentJvm.Contains("-Dlog4j2.formatMsgNoLookups=true") Then ArgumentJvm += " -Dlog4j2.formatMsgNoLookups=true"
ArgumentJvm = ArgumentJvm.Replace(" -XX:MaxDirectMemorySize=256M", "") '#3511 的清理
DataList.Insert(0, ArgumentJvm) '可变 JVM 参数
DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024 * 0.5) & "m")
DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024 * 0.15) & "m")
DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & "m")
DataList.Add("""-Djava.library.path=" & GetNativesFolder() & """")
DataList.Add("-cp ${classpath}") '把支持库添加进启动参数表
@@ -1610,7 +1638,8 @@ NextVersion:
GameSize = New Size(875 - 2, 540 - 2)
End Select
GameSize.Height -= 29.5 * DPI / 96 '标题栏高度
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso McLaunchJavaSelected.VersionCode <= 8 Then '修复 #3463:1.12.2-,JRE 8 下窗口大小为设置大小的 DPI% 倍
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso McLaunchJavaSelected.VersionCode <= 8 AndAlso
Not McVersionCurrent.Version.HasOptiFine AndAlso Not McVersionCurrent.Version.HasForge Then '修复 #3463:1.12.2-,JRE 8 下窗口大小为设置大小的 DPI% 倍
GameSize.Width /= DPI / 96
GameSize.Height /= DPI / 96
End If
@@ -1809,13 +1838,14 @@ NextVersion:
'1.11 ~ 12:zh_cn 时正常,zh_CN 时虽然显示了中文但语言设置会错误地显示选择英文
'1.13+ :zh_cn 时正常,zh_CN 时自动切换为英文
Dim CurrentLang As String = ReadIni(SetupFileAddress, "lang", "none")
Dim RequiredLang As String = If(CurrentLang = "none", If(Setup.Get("ToolHelpChinese"), "zh_cn", "en_us"), CurrentLang.ToLower)
Dim RequiredLang As String = If(CurrentLang = "none" OrElse Not Directory.Exists(McVersionCurrent.PathIndie & "saves"), '#3844,整合包可能已经自带了 options.txt
If(Setup.Get("ToolHelpChinese"), "zh_cn", "en_us"), CurrentLang.ToLower)
If McVersionCurrent.Version.McCodeMain < 12 Then '注意老版本(包含 MC 1.1)的 McCodeMain 可能为 -1
'将最后两位改为大写,前面的部分保留
RequiredLang = RequiredLang.Substring(0, RequiredLang.Length - 2) & RequiredLang.Substring(RequiredLang.Length - 2).ToUpper
End If
If CurrentLang = RequiredLang Then
McLaunchLog($"当前语言为 {CurrentLang},无需修改")
McLaunchLog($"需要的语言为 {RequiredLang},当前语言为 {CurrentLang},无需修改")
Else
WriteIni(SetupFileAddress, "lang", "-") '触发缓存更改,避免删除后重新下载残留缓存
WriteIni(SetupFileAddress, "lang", RequiredLang)
@@ -1,4 +1,6 @@
Public Module ModMinecraft
Imports System.IO.Compression
Public Module ModMinecraft
#Region "文件夹"
@@ -149,7 +151,7 @@
#Region "版本处理"
Public Const McVersionCacheVersion As Integer = 27
Public Const McVersionCacheVersion As Integer = 29
Private _McVersionCurrent As McVersion
Private _McVersionLast = 0 '为 0 以保证与 Nothing 不相同,使得 UI 显示可以正常初始化
@@ -391,6 +393,29 @@
_Version.McName = JsonObject("jar").ToString
GoTo VersionSearchFinish
End If
'从 jar 文件的 version.json 中获取版本号
If File.Exists(Path & Name & ".jar") Then
Try
Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
If VersionJson IsNot Nothing Then
Using VersionJsonStream As New StreamReader(VersionJson.Open)
Dim VersionJsonObj As JObject = GetJson(VersionJsonStream.ReadToEnd)
If VersionJsonObj("id") IsNot Nothing Then
Dim VersionId As String = VersionJsonObj("id").ToString
If VersionId.Length < 32 Then '因为 wiki 说这玩意儿可能是个 hash,虽然我没发现
_Version.McName = VersionId
Log("[Minecraft] 从版本 jar 中的 version.json 获取到版本号:" & VersionId)
GoTo VersionSearchFinish
End If
End If
End Using
End If
End Using
Catch ex As Exception
Log(ex, "从版本 jar 中的 version.json 获取版本号失败")
End Try
End If
'非准确的版本判断警告
Log("[Minecraft] 无法完全确认 MC 版本号的版本:" & Name)
'从文件夹名中获取
@@ -1034,7 +1059,7 @@ ExitDataLoad:
Dim Path As String = Loader.Input
Try
'初始化
McVersionList.Clear()
McVersionList = New Dictionary(Of McVersionCardType, List(Of McVersion))
'检测缓存是否需要更新
Dim FolderList As New List(Of String)
@@ -1075,10 +1100,10 @@ Reload:
'改变当前选择的版本
OnLoaded:
If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then '不能判断 Count = 0,这在只有错误版本时导致了误判
If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then
'尝试读取已储存的选择
Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version")
If Not SavedSelection = "" Then
If SavedSelection <> "" Then
For Each Card As KeyValuePair(Of McVersionCardType, List(Of McVersion)) In McVersionList
For Each Version As McVersion In Card.Value
If Version.Name = SavedSelection AndAlso Not Version.State = McVersionState.Error Then
@@ -1190,7 +1215,7 @@ OnLoaded:
End Try
Next
ResultVersionList.Add(CardType, VersionList)
If VersionList.Any Then ResultVersionList.Add(CardType, VersionList)
Next
Return ResultVersionList
Catch ex As Exception
@@ -1200,10 +1225,14 @@ OnLoaded:
End Function
Private Function McVersionListLoadNoCache(Path As String) As Dictionary(Of McVersionCardType, List(Of McVersion))
Dim VersionList As New List(Of McVersion)
Dim ResultVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion))
#Region "循环加载每个版本的信息"
Dim Dirs As DirectoryInfo() = New DirectoryInfo(Path & "versions").GetDirectories
For Each Folder As DirectoryInfo In Dirs
If Not Folder.EnumerateFiles.Any Then
Log("[Minecraft] 跳过空文件夹:" & Folder.FullName)
Continue For
End If
If (Folder.Name = "cache" OrElse Folder.Name = "BLClient" OrElse Folder.Name = "PCL") AndAlso Not File.Exists(Folder.FullName & "\" & Folder.Name & ".json") Then
Log("[Minecraft] 跳过可能不是版本文件夹的项目:" & Folder.FullName)
Continue For
@@ -1223,6 +1252,9 @@ OnLoaded:
Version.Load()
Next
#End Region
Dim ResultVersionList As New Dictionary(Of McVersionCardType, List(Of McVersion))
#Region "将版本分类到各个卡片"
Try
@@ -1236,7 +1268,7 @@ OnLoaded:
Next
If StaredVersions.Any Then VersionListOriginal.Add(McVersionCardType.Star, StaredVersions)
'预先筛选出愚人节的版本
'预先筛选出愚人节和错误的版本
McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Error}, McVersionCardType.Error)
McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Fool}, McVersionCardType.Fool)
@@ -1347,9 +1379,7 @@ OnLoaded:
Next
If Not IsNothing(Snapshot) Then OldList.Remove(Snapshot)
'按版本号排序
Dim NewList As List(Of McVersion) = Sort(OldList, Function(Left As McVersion, Right As McVersion)
Return Left.Version.McCodeMain > Right.Version.McCodeMain
End Function)
Dim NewList As List(Of McVersion) = Sort(OldList, Function(Left, Right) Left.Version.McCodeMain > Right.Version.McCodeMain)
'回设
If Not IsNothing(Snapshot) Then NewList.Insert(0, Snapshot)
ResultVersionList(McVersionCardType.OriginalLike) = NewList
@@ -1357,7 +1387,8 @@ OnLoaded:
'不常用版本:按发布时间新旧排序,如果不可用则按名称排序
If ResultVersionList.ContainsKey(McVersionCardType.Rubbish) Then
ResultVersionList(McVersionCardType.Rubbish) = Sort(ResultVersionList(McVersionCardType.Rubbish), Function(Left As McVersion, Right As McVersion)
ResultVersionList(McVersionCardType.Rubbish) = Sort(ResultVersionList(McVersionCardType.Rubbish),
Function(Left As McVersion, Right As McVersion)
Dim LeftYear As Integer = Left.ReleaseTime.Year '+ If(Left.State = McVersionState.Original OrElse Left.Version.HasOptiFine, 100, 0)
Dim RightYear As Integer = Right.ReleaseTime.Year '+ If(Right.State = McVersionState.Original OrElse Left.Version.HasOptiFine, 100, 0)
If LeftYear > 2000 AndAlso RightYear > 2000 Then
@@ -1378,7 +1409,8 @@ OnLoaded:
'API 版本:优先按版本排序,此后【先放 Fabric,再放 Forge(按版本号从高到低排序),最后放 LiteLoader(按名称排序)】
If ResultVersionList.ContainsKey(McVersionCardType.API) Then
ResultVersionList(McVersionCardType.API) = Sort(ResultVersionList(McVersionCardType.API), Function(Left As McVersion, Right As McVersion)
ResultVersionList(McVersionCardType.API) = Sort(ResultVersionList(McVersionCardType.API),
Function(Left As McVersion, Right As McVersion)
Dim Basic = VersionSortInteger(Left.Version.McName, Right.Version.McName)
If Basic <> 0 Then
Return Basic > 0
@@ -1417,17 +1449,7 @@ OnLoaded:
''' <param name="Formula">需要筛选出的版本类型。-2 代表隐藏的版本。</param>
''' <param name="CardType">卡片的名称。</param>
Private Sub McVersionFilter(ByRef VersionList As List(Of McVersion), ByRef Target As Dictionary(Of McVersionCardType, List(Of McVersion)), Formula As McVersionState(), CardType As McVersionCardType)
'将某种版本筛选出来
Dim KeepList As New List(Of McVersion)
For Each Version As McVersion In VersionList
For Each Type As Integer In Formula
If Type = Version.State Then
KeepList.Add(Version)
GoTo NextVersion
End If
Next
NextVersion:
Next
Dim KeepList = VersionList.Where(Function(v) Formula.Contains(v.State)).ToList
'加入版本列表,并从剩余中删除
If KeepList.Any Then
Target.Add(CardType, KeepList)
@@ -1443,13 +1465,8 @@ NextVersion:
''' <param name="Formula">需要筛选出的版本类型。-2 代表隐藏的版本。</param>
''' <param name="KeepList">传入需要增加入的列表。</param>
Private Sub McVersionFilter(ByRef VersionList As List(Of McVersion), Formula As McVersionState(), ByRef KeepList As List(Of McVersion))
For Each Version As McVersion In VersionList
For Each Type As McVersionState In Formula
If Type <> Version.State Then Continue For
KeepList.Add(Version) : Exit For
Next
NextVersion:
Next
KeepList.AddRange(VersionList.Where(Function(v) Formula.Contains(v.State)))
'加入版本列表,并从剩余中删除
If KeepList.Any Then
For Each Version As McVersion In KeepList
VersionList.Remove(Version)
@@ -887,11 +887,11 @@ Finished:
ModList.Add(ModEntry)
'读取 Comp 缓存
If ModEntry.State = McMod.McModState.Unavaliable Then Continue For
Dim Hash = ModEntry.ModrinthHash
If Cache.ContainsKey(Hash) Then
ModEntry.FromJson(Cache(Hash))
Dim CacheKey = ModEntry.ModrinthHash & PageVersionLeft.Version.Version.McName
If Cache.ContainsKey(CacheKey) Then
ModEntry.FromJson(Cache(CacheKey))
'如果缓存中的信息在 6 小时以内更新过,则无需重新获取
If ModEntry.CompLoaded AndAlso Date.Now - Cache(Hash)("Comp")("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For
If ModEntry.CompLoaded AndAlso Date.Now - Cache(CacheKey)("Comp")("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For
End If
ModUpdateList.Add(ModEntry)
Next
@@ -925,7 +925,7 @@ Finished:
End Sub
'联网加载 Mod 详情
Private Const LocalModCacheVersion As Integer = 3
Private Const LocalModCacheVersion As Integer = 4
Public McModDetailLoader As New LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer)("Mod List Detail Loader", AddressOf McModDetailLoad)
Private Sub McModDetailLoad(Loader As LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer))
Dim Mods As List(Of McMod) = Loader.Input.Key
@@ -937,7 +937,7 @@ Finished:
If TargetMcVersion.HasFabric Then ModLoaders.Add(CompModLoaderType.Fabric)
If TargetMcVersion.HasLiteLoader Then ModLoaders.Add(CompModLoaderType.LiteLoader)
If Not ModLoaders.Any() Then ModLoaders.AddRange({CompModLoaderType.Forge, CompModLoaderType.Fabric, CompModLoaderType.LiteLoader, CompModLoaderType.Quilt})
Dim McVersions As New List(Of String) From {TargetMcVersion.McName}
Dim McVersion = TargetMcVersion.McName
'暂不向下扩展检查的 MC 小版本
'例如:Mod 在更新 1.16.5 后,对早期的 1.16.2 版本发布了修补补丁,这会导致 PCL 将 1.16.5 版本的 Mod 降级到 1.16.2
'If TargetMcVersion.McCodeMain > 0 AndAlso TargetMcVersion.McCodeMain < 99 Then
@@ -948,7 +948,7 @@ Finished:
'End If
'McVersions = McVersions.Distinct().ToList()
'开始网络获取
Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersions.Join("/")}")
Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersion}")
Dim EndedThreadCount As Integer = 0, SucceedThreadCount As Integer = 0
Dim MainThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息
@@ -991,8 +991,8 @@ Finished:
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息,继续获取更新信息")
'步骤 4:获取更新信息
Dim ModrinthUpdate = CType(GetJson(NetRequestRetry("https://api.modrinth.com/v2/version_files/update", "POST",
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1"",
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersions.Join(""",""")}""]}}", "application/json")), JObject)
$"{{""hashes"": [""{ModrinthMapping.SelectMany(Function(l) l.Value.Select(Function(m) m.ModrinthHash)).Join(""",""")}""], ""algorithm"": ""sha1"",
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")), JObject)
For Each Entry In Mods
If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For
Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod)
@@ -1001,11 +1001,11 @@ Finished:
If Entry.CompFile.ReleaseDate >= UpdateFile.ReleaseDate OrElse Entry.CompFile.Hash = UpdateFile.Hash Then Continue For
'设置更新日志与更新文件
If Entry.UpdateFile IsNot Nothing AndAlso UpdateFile.Hash = Entry.UpdateFile.Hash Then '合并
Entry.ChangelogUrls.Add($"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?{McVersions.Select(Function(v) $"g={v}&").Join("")}")
Entry.ChangelogUrls.Add($"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={McVersion}")
UpdateFile.DownloadUrls.AddRange(Entry.UpdateFile.DownloadUrls) '合并下载源
Entry.UpdateFile = UpdateFile '优先使用 Modrinth 的文件
ElseIf Entry.UpdateFile Is Nothing OrElse UpdateFile.ReleaseDate >= Entry.UpdateFile.ReleaseDate Then '替换
Entry.ChangelogUrls = New List(Of String) From {$"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?{McVersions.Select(Function(v) $"g={v}&").Join("")}"}
Entry.ChangelogUrls = New List(Of String) From {$"https://modrinth.com/mod/{ModrinthUpdate(Entry.ModrinthHash)("project_id")}/changelog?g={McVersion}"}
Entry.UpdateFile = UpdateFile
End If
Next
@@ -1073,7 +1073,7 @@ Finished:
For Each IndexEntry In ProjectJson("latestFilesIndexes")
If ModLoaders.Single <> IndexEntry("modLoader")?.ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
Dim IndexVersion As String = IndexEntry("gameVersion")
If Not McVersions.Contains(IndexVersion) Then Continue For 'MC 版本匹配
If McVersion <> IndexVersion Then Continue For 'MC 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的,所以只需取第一个;如果需要检查多个 releaseType 下的文件,将 > -1 改为 = 1,但这应当并不会获取到更新的文件
If NewestVersion IsNot Nothing AndAlso VersionSortInteger(NewestVersion, IndexVersion) > -1 Then Continue For '只保留最新 MC 版本
If NewestVersion <> IndexVersion Then
@@ -1136,7 +1136,7 @@ Finished:
If Not Mods.Any() Then Exit Sub
For Each Entry In Mods 'TODO: Bookshelf 的 Logo 会在两个网站间横跳
Entry.CompLoaded = SucceedThreadCount = 2
Cache(Entry.ModrinthHash) = Entry.ToJson()
Cache(Entry.ModrinthHash & McVersion) = Entry.ToJson()
Next
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
End Sub
@@ -348,6 +348,7 @@
'崩溃分析
WatcherLog("Minecraft 已崩溃,将在 2 秒后开始崩溃分析")
Hint("检测到 Minecraft 出现错误,错误分析已开始……")
FeedbackInfo()
RunInNewThread(Sub()
Try
Thread.Sleep(2000)
@@ -195,6 +195,7 @@ RetryStart:
Private Shared Swiping As Boolean = False
Private Shared SwipToState As Boolean '被滑动到的目标应将 Checked 改为此值
Private Sub Button_MouseSwipeStart(sender As Object, e As Object) Handles Me.MouseLeftButtonDown
If Parent Is Nothing Then Exit Sub 'Mod 可能已被删除(#3824)
'开始滑动
Dim Index = CType(Parent, StackPanel).Children.IndexOf(Me)
SwipeStart = Index
@@ -204,6 +205,7 @@ RetryStart:
FrmVersionMod.CardSelect.IsHitTestVisible = False '暂时禁用下边栏
End Sub
Private Sub Button_MouseSwipe(sender As Object, e As Object) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonUp
If Parent Is Nothing Then Exit Sub 'Mod 可能已被删除(#3824)
'结束滑动
If Mouse.LeftButton <> MouseButtonState.Pressed OrElse Not Swiping Then
Swiping = False
+3 -4
View File
@@ -73,8 +73,8 @@
Case "切换页面"
FrmMain.PageChange(Val(Data(0)), Val(Data(1)))
Case "导入整合包"
RunInThread(Sub() ModpackInstall())
Case "导入整合包", "安装整合包"
RunInUi(Sub() ModpackInstall())
Case "下载文件"
Data(0) = Data(0).Replace("\", "/")
@@ -101,8 +101,7 @@
'网页确认
If RelativeUrl.StartsWithF("http", True) Then
If RunInUi() Then
Throw New Exception("MyListItem 在界面初始化时就需要获取帮助标题等信息,这会导致程序在网络请求时卡死。" & vbCrLf &
"因此,请换用 MyListItem 以外的控件(例如 MyButton)作为联网帮助页面的入口!")
Throw New Exception("能打开联网帮助页面的 MyListItem 必须手动设置 Title、Info 属性!")
End If
'获取文件名
Dim RawFileName As String
+11 -9
View File
@@ -1,6 +1,4 @@
Imports System.Security.Cryptography
Public Module ModMusic
Public Module ModMusic
#Region "播放列表"
@@ -199,13 +197,15 @@ Public Module ModMusic
''' </summary>
Public Function MusicPause() As Boolean
If MusicState = MusicStates.Play Then
RunInThread(Sub()
MusicNAudio.Pause()
MusicRefreshUI()
RunInThread(
Sub()
Log("[Music] 已暂停播放")
MusicNAudio?.Pause()
MusicRefreshUI()
End Sub)
Return True
Else
Log($"[Music] 无需暂停播放,当前状态为 {MusicState}")
Return False
End If
End Function
@@ -214,12 +214,14 @@ Public Module ModMusic
''' </summary>
Public Function MusicResume() As Boolean
If MusicState = MusicStates.Play OrElse Not MusicAllList.Any() Then
Log($"[Music] 无需继续播放,当前状态为 {MusicState}")
Return False
Else
RunInThread(Sub()
MusicNAudio.Play()
MusicRefreshUI()
RunInThread(
Sub()
Log("[Music] 已恢复播放")
MusicNAudio?.Play()
MusicRefreshUI()
End Sub)
Return True
End If
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.7.3.0")>
<Assembly: AssemblyFileVersion("2.7.3.0")>
<Assembly: AssemblyVersion("2.7.4.0")>
<Assembly: AssemblyFileVersion("2.7.4.0")>
<Assembly: NeutralResourcesLanguage("")>
@@ -384,7 +384,9 @@ Public Module ModDownloadLib
End Sub
Private Sub McDownloadOptiFineInstall(BaseMcFolderHome As String, Target As String, Task As LoaderTask(Of List(Of NetFile), Boolean), UseJavaWrapper As Boolean)
'选择 Java
Dim Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0))
Dim Java As JavaEntry
SyncLock JavaLock
Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0))
If Java Is Nothing Then
If Not JavaDownloadConfirm("Java 8 或更高版本") Then Throw New Exception("由于未找到 Java,已取消安装。")
'开始自动下载
@@ -402,6 +404,7 @@ Public Module ModDownloadLib
If Task.IsAborted Then Exit Sub
If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。")
End If
End SyncLock
'添加 Java Wrapper 作为主 Jar
Dim Arguments As String
If UseJavaWrapper Then
@@ -1111,7 +1114,9 @@ Retry:
Private Sub ForgeInjector(Target As String, Task As LoaderTask(Of Boolean, Boolean), McFolder As String, UseJavaWrapper As Boolean)
'选择 Java
Dim Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60))
Dim Java As JavaEntry
SyncLock JavaLock
Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60))
If Java Is Nothing Then
If Not JavaDownloadConfirm("Java 8 或更高版本") Then Throw New Exception("由于未找到 Java,已取消安装。")
'开始自动下载
@@ -1129,6 +1134,7 @@ Retry:
If Task.IsAborted Then Exit Sub
If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。")
End If
End SyncLock
'添加 Java Wrapper 作为主 Jar
Dim Arguments As String
If UseJavaWrapper Then
@@ -1275,8 +1281,8 @@ Retry:
McFolder = If(McFolder, PathMcFolder)
If Version.StartsWithF("1.") AndAlso Version.Contains("-") Then
'类似 1.19.3-41.2.8 格式,优先使用 Version 中要求的版本而非 Inherit(例如 1.19.3 却使用了 1.19 的 Forge)
Inherit = Version.Split("-").First
Version = Version.Split("-").Last
Inherit = Version.Before("-")
Version = Version.After("-")
End If
Dim IsCustomFolder As Boolean = McFolder <> PathMcFolder
Dim Id As String = Inherit & "-forge-" & Version
@@ -1322,7 +1328,7 @@ Retry:
Loaders.Add(New LoaderDownload("下载 Mod 加载器主文件", New List(Of NetFile)) With {.ProgressWeight = 9})
'安装(仅在新版安装时需要原版 Jar)
If Version.Split(".")(0) >= 20 Then
If Version.Before(".") >= 20 Then
Log("[Download] 检测为新版 Forge:" & Version)
Dim Libs As List(Of McLibToken) = Nothing
Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 Mod 加载器支持库文件",
@@ -1344,7 +1350,7 @@ Retry:
Task.Progress = 0.4
Dim RawJson As JObject = GetJson(NetGetCodeByDownload(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True))
'[net.minecraft:client:1.17.1-20210706.113038:mappings@txt] 或 @tsrg]
Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(0)
Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Before("@")
Dim Address = McLibGet(OriginalName).Replace(".jar", "-mappings." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1))
Libs.Add(New McLibToken With {.IsJumpLoader = False, .IsNatives = False, .LocalPath = Address, .OriginalName = OriginalName,
.Url = RawJson("downloads")("client_mappings")("url"), .Size = RawJson("downloads")("client_mappings")("size"), .SHA1 = RawJson("downloads")("client_mappings")("sha1")})
@@ -1788,7 +1794,7 @@ Retry:
Public Function FabricApiDownloadListItem(Entry As CompFile, OnClick As MyListItem.ClickEventHandler) As MyListItem
'建立控件
Dim NewItem As New MyListItem With {
.Title = Entry.DisplayName.Split("]")(1).Replace("Fabric API ", "").Replace(" build ", ".").Split("+").First.Trim, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry,
.Title = Entry.DisplayName.Split("]")(1).Replace("Fabric API ", "").Replace(" build ", ".").Before("+").Trim, .SnapsToDevicePixels = True, .Height = 42, .Type = MyListItem.CheckType.Clickable, .Tag = Entry,
.Info = Entry.StatusDescription & ",发布于 " & Entry.ReleaseDate.ToString("yyyy'/'MM'/'dd HH':'mm"),
.Logo = PathImage & "Blocks/Fabric.png"
}
@@ -1978,7 +1984,7 @@ Retry:
If Directory.Exists(TempMcFolder) Then DeleteDirectory(TempMcFolder)
Dim OptiFineFolder As String = Nothing
If Request.OptiFineVersion IsNot Nothing Then
If Request.OptiFineVersion.Contains("_HD_U_") Then Request.OptiFineVersion = "HD_U_" & Request.OptiFineVersion.Split("_HD_U_").Last '#735
If Request.OptiFineVersion.Contains("_HD_U_") Then Request.OptiFineVersion = "HD_U_" & Request.OptiFineVersion.After("_HD_U_") '#735
Request.OptiFineEntry = New DlOptiFineListEntry With {
.NameDisplay = Request.MinecraftName & " " & Request.OptiFineVersion.Replace("HD_U_", "").Replace("_", "").Replace("pre", " pre"),
.Inherit = Request.MinecraftName,
@@ -2062,7 +2068,7 @@ Retry:
End Sub) With {.ProgressWeight = 2, .Block = True})
'补全文件
If Not DontFixLibraries AndAlso
(Request.OptiFineEntry IsNot Nothing OrElse (Request.ForgeVersion IsNot Nothing AndAlso Request.ForgeVersion.Split(".")(0) >= 20) OrElse Request.FabricVersion IsNot Nothing OrElse Request.LiteLoaderEntry IsNot Nothing) Then
(Request.OptiFineEntry IsNot Nothing OrElse (Request.ForgeVersion IsNot Nothing AndAlso Request.ForgeVersion.Before(".") >= 20) OrElse Request.FabricVersion IsNot Nothing OrElse Request.LiteLoaderEntry IsNot Nothing) Then
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件(副加载器)", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(OutputFolder))) With {.ProgressWeight = 1, .Show = False})
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
@@ -275,7 +275,7 @@
If Project.TranslatedName = Project.RawName Then
FileName = File.FileName
Else
Dim ChineseName As String = Project.TranslatedName.Split(" (").First.Split(" - ").First.
Dim ChineseName As String = Project.TranslatedName.Before(" (").Before(" - ").
Replace("\", "\").Replace("/", "/").Replace("|", "|").Replace(":", ":").Replace("<", "<").Replace(">", ">").Replace("*", "*").Replace("?", "?").Replace("""", "").Replace(": ", ":")
Select Case Setup.Get("ToolDownloadTranslate")
Case 0
@@ -299,7 +299,7 @@
If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder)
If Not Target.Contains("\") Then Exit Sub
'构造步骤加载器
Dim LoaderName As String = Desc & "下载:" & File.DisplayName & " "
Dim LoaderName As String = Desc & "下载:" & GetFileNameWithoutExtentionFromPath(Target) & " "
If Target <> DefaultFolder AndAlso Project.Type = CompType.Mod Then CachedFolder = GetPathFromFullPath(Target)
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True})
@@ -20,6 +20,7 @@
<StackPanel Margin="25,37,25,15">
<local:MyHint Text="你尚未选择安装 Fabric API,这会导致大多数 Mod 无法使用!" Margin="0,1,0,7" x:Name="HintFabricAPI" IsWarn="True" />
<local:MyHint Text="你尚未选择安装 OptiFabric,这会导致 OptiFine 无法使用!" Margin="0,1,0,7" x:Name="HintOptiFabric" IsWarn="True" />
<local:MyHint Text="OptiFine 与一部分 Mod 的兼容性不佳,请谨慎安装。" Margin="0,1,0,7" x:Name="HintModOptiFine" IsWarn="False" />
<Grid Margin="0,0,0,11">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="1*" />
@@ -60,26 +61,6 @@
<TextBlock VerticalAlignment="Center" Text="返回" Grid.Column="3" Foreground="{StaticResource ColorBrushGray4}" />
</Grid>
</local:MyCard>
<local:MyCard Title="OptiFine" Height="40" Margin="0,15,0,0" x:Name="CardOptiFine" IsSwaped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top">
<StackPanel Name="PanOptiFine" />
</StackPanel>
<Grid x:Name="PanOptiFineInfo" Height="18" Margin="175,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform>
<TranslateTransform />
</Grid.RenderTransform>
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" />
</Grid.ColumnDefinitions>
<Image x:Name="ImgOptiFine" Margin="0,0,7,0" SnapsToDevicePixels="True" Height="18" RenderOptions.BitmapScalingMode="Linear" Source="pack://application:,,,/images/Blocks/GrassPath.png" />
<TextBlock x:Name="LabOptiFine" VerticalAlignment="Center" TextTrimming="CharacterEllipsis" Grid.Column="1" />
</Grid>
<Grid x:Name="BtnOptiFineClear" Height="30" Width="30" HorizontalAlignment="Right" VerticalAlignment="Top" Margin="0,5,32,0" Background="{StaticResource ColorBrushSemiTransparent}">
<Path x:Name="BtnOptiFineClearInner" Height="10" Width="10" Stretch="Uniform" Fill="{StaticResource ColorBrushGray1}" HorizontalAlignment="Center" VerticalAlignment="Center"
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid>
</local:MyCard>
<local:MyCard Title="Forge" Height="40" Margin="0,15,0,0" x:Name="CardForge" IsSwaped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanForge" />
<Grid x:Name="PanForgeInfo" Height="18" Margin="175,11,15,0" VerticalAlignment="Top" Tag="True">
@@ -134,6 +115,26 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid>
</local:MyCard>
<local:MyCard Title="OptiFine" Height="40" Margin="0,15,0,0" x:Name="CardOptiFine" IsSwaped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top">
<StackPanel Name="PanOptiFine" />
</StackPanel>
<Grid x:Name="PanOptiFineInfo" Height="18" Margin="175,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform>
<TranslateTransform />
</Grid.RenderTransform>
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" />
</Grid.ColumnDefinitions>
<Image x:Name="ImgOptiFine" Margin="0,0,7,0" SnapsToDevicePixels="True" Height="18" RenderOptions.BitmapScalingMode="Linear" Source="pack://application:,,,/images/Blocks/GrassPath.png" />
<TextBlock x:Name="LabOptiFine" VerticalAlignment="Center" TextTrimming="CharacterEllipsis" Grid.Column="1" />
</Grid>
<Grid x:Name="BtnOptiFineClear" Height="30" Width="30" HorizontalAlignment="Right" VerticalAlignment="Top" Margin="0,5,32,0" Background="{StaticResource ColorBrushSemiTransparent}">
<Path x:Name="BtnOptiFineClearInner" Height="10" Width="10" Stretch="Uniform" Fill="{StaticResource ColorBrushGray1}" HorizontalAlignment="Center" VerticalAlignment="Center"
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid>
</local:MyCard>
<local:MyCard Title="OptiFabric" Height="40" Margin="0,15,0,0" x:Name="CardOptiFabric" IsSwaped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanOptiFabric" />
<Grid x:Name="PanOptiFabricInfo" Height="18" Margin="175,11,15,0" VerticalAlignment="Top" Tag="True">
@@ -305,6 +305,10 @@
LabOptiFine.Foreground = ColorGray1
End If
'LiteLoader
If Not SelectedMinecraftId.Contains("1.") OrElse Val(SelectedMinecraftId.Split(".")(1)) > 12 Then
CardLiteLoader.Visibility = Visibility.Collapsed
Else
CardLiteLoader.Visibility = Visibility.Visible
Dim LiteLoaderError As String = LoadLiteLoaderGetError()
CardLiteLoader.MainSwap.Visibility = If(LiteLoaderError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If LiteLoaderError IsNot Nothing Then CardLiteLoader.IsSwaped = True '例如在同时展开卡片时选择了不兼容项则强制折叠
@@ -320,6 +324,7 @@
LabLiteLoader.Text = SelectedLiteLoader.Inherit
LabLiteLoader.Foreground = ColorGray1
End If
End If
'Forge
Dim ForgeError As String = LoadForgeGetError()
CardForge.MainSwap.Visibility = If(ForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed)
@@ -337,6 +342,10 @@
LabForge.Foreground = ColorGray1
End If
'Fabric
If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) <= 13 Then
CardFabric.Visibility = Visibility.Collapsed
Else
CardFabric.Visibility = Visibility.Visible
Dim FabricError As String = LoadFabricGetError()
CardFabric.MainSwap.Visibility = If(FabricError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If FabricError IsNot Nothing Then CardFabric.IsSwaped = True
@@ -352,7 +361,12 @@
LabFabric.Text = SelectedFabric.Replace("+build", "")
LabFabric.Foreground = ColorGray1
End If
End If
'FabricApi
If SelectedFabric Is Nothing Then
CardFabricApi.Visibility = Visibility.Collapsed
Else
CardFabricApi.Visibility = Visibility.Visible
Dim FabricApiError As String = LoadFabricApiGetError()
CardFabricApi.MainSwap.Visibility = If(FabricApiError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If FabricApiError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardFabricApi.IsSwaped = True
@@ -368,7 +382,12 @@
LabFabricApi.Text = SelectedFabricApi.DisplayName.Split("]")(1).Replace("Fabric API ", "").Replace(" build ", ".").Split("+").First.Trim
LabFabricApi.Foreground = ColorGray1
End If
End If
'OptiFabric
If SelectedFabric Is Nothing OrElse SelectedOptiFine Is Nothing Then
CardOptiFabric.Visibility = Visibility.Collapsed
Else
CardOptiFabric.Visibility = Visibility.Visible
Dim OptiFabricError As String = LoadOptiFabricGetError()
CardOptiFabric.MainSwap.Visibility = If(OptiFabricError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If OptiFabricError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardOptiFabric.IsSwaped = True
@@ -384,13 +403,24 @@
LabOptiFabric.Text = SelectedOptiFabric.DisplayName.ToLower.Replace("optifabric-", "").Replace(".jar", "").Trim.TrimStart("v")
LabOptiFabric.Foreground = ColorGray1
End If
End If
'主警告
HintFabricAPI.Visibility = If(SelectedFabric IsNot Nothing AndAlso SelectedFabricApi Is Nothing, Visibility.Visible, Visibility.Collapsed)
If SelectedFabric IsNot Nothing AndAlso SelectedFabricApi Is Nothing Then
HintFabricAPI.Visibility = Visibility.Visible
Else
HintFabricAPI.Visibility = Visibility.Collapsed
End If
If SelectedFabric IsNot Nothing AndAlso SelectedOptiFine IsNot Nothing AndAlso SelectedOptiFabric Is Nothing Then
HintOptiFabric.Visibility = Visibility.Visible
Else
HintOptiFabric.Visibility = Visibility.Collapsed
End If
If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) >= 16 AndAlso SelectedOptiFine IsNot Nothing AndAlso
(SelectedForge IsNot Nothing OrElse SelectedFabric IsNot Nothing) Then
HintModOptiFine.Visibility = Visibility.Visible
Else
HintModOptiFine.Visibility = Visibility.Collapsed
End If
'结束
IsReloading = False
End Sub
@@ -632,7 +662,7 @@
Return (OptiFine.RequiredForgeVersion.Contains(".") AndAlso 'XX.X.XXX
VersionSortInteger(Forge.Version, OptiFine.RequiredForgeVersion) >= 0) OrElse
(Not OptiFine.RequiredForgeVersion.Contains(".") AndAlso '#XXXX
VersionSortInteger(Forge.Version.Split(".").Last, OptiFine.RequiredForgeVersion) >= 0)
Forge.Version.After(".") >= OptiFine.RequiredForgeVersion)
End Function
'限制展开
@@ -909,12 +939,12 @@
If DisplayName.StartsWith("[" & MinecraftVersion & "]") Then Return True
If Not DisplayName.Contains("/") OrElse Not DisplayName.Contains("]") Then Return False
'直接的判断(例如 1.18.1/22w03a)
For Each Part As String In DisplayName.Split("]")(0).TrimStart("[").Split("/")
For Each Part As String In DisplayName.Before("]").TrimStart("[").Split("/")
If Part = MinecraftVersion Then Return True
Next
'将版本名分割语素(例如 1.16.4/5)
Dim Lefts = RegexSearch(DisplayName.Split("]")(0), "[a-z/]+|[0-9/]+")
Dim Rights = RegexSearch(MinecraftVersion.Split("]")(0), "[a-z/]+|[0-9/]+")
Dim Lefts = RegexSearch(DisplayName.Before("]"), "[a-z/]+|[0-9/]+")
Dim Rights = RegexSearch(MinecraftVersion.Before("]"), "[a-z/]+|[0-9/]+")
'对每段进行判断
Dim i As Integer = 0
While True
@@ -93,7 +93,7 @@ Public Class FormLoginOAuth
If Not IsLoginSuccessed Then RaiseEvent OnLoginCanceled(IsSwitch)
FrmMain.Focus()
End Sub
Private Sub HintSwitch_Click(sender As Object, e As EventArgs) Handles HintSwitch.Click
Private Sub HintSwitch_Click() Handles HintSwitch.Click
IsSwitch = True
Close()
End Sub
@@ -400,7 +400,7 @@ Finish:
ElseIf Setup.Get("LoginLegacyName") = "" Then
Return New EqualableList(Of String) From {0, ""}
Else
Return New EqualableList(Of String) From {0, If(Setup.Get("LoginLegacyName").ToString.Split("¨")(0), "")}
Return New EqualableList(Of String) From {0, If(Setup.Get("LoginLegacyName").ToString.Before("¨"), "")}
End If
Case 3
Return New EqualableList(Of String) From {3, Setup.Get("LaunchSkinID")}
@@ -97,6 +97,10 @@ Download:
Log("[Page] 主页预设:每日整合包推荐")
Url = "https://pclsub.sodamc.com/"
GoTo Download
Case 5
Log("[Page] 主页预设:Minecraft 皮肤推荐")
Url = "https://forgepixel.com/pcl_sub_file"
GoTo Download
End Select
End Select
RunInUi(Sub() LoadContent(Content))
@@ -106,16 +110,17 @@ Download:
'联网获取自定义主页文件
Private OnlineLoader As New LoaderTask(Of String, Integer)("自定义主页获取", AddressOf OnlineLoaderSub) With {.ReloadTimeout = 10 * 60 * 1000}
Private Sub OnlineLoaderSub(Task As LoaderTask(Of String, Integer))
Dim Address As String = Task.Input '#3721 中连续触发两次导致内容变化
Try
'获取版本校验地址
Dim VersionAddress As String
If Task.Input.Contains(".xaml") Then
VersionAddress = Task.Input.Replace(".xaml", ".xaml.ini")
If Address.Contains(".xaml") Then
VersionAddress = Address.Replace(".xaml", ".xaml.ini")
Else
VersionAddress = Task.Input.Split("?").First
VersionAddress = Address.Before("?")
If Not VersionAddress.EndsWith("/") Then VersionAddress += "/"
VersionAddress += "version"
If Task.Input.Contains("?") Then VersionAddress += Task.Input.Split("?").Last
If Address.Contains("?") Then VersionAddress += Address.After("?")
End If
'校验版本
Dim Version As String = ""
@@ -136,9 +141,9 @@ Download:
End Try
'实际下载
If NeedDownload Then
Dim FileContent As String = NetGetCodeByRequestRetry(Task.Input)
Log($"[Page] 已联网下载自定义主页,内容长度:{FileContent.Length},来源:{Task.Input}")
Setup.Set("CacheSavedPageUrl", Task.Input)
Dim FileContent As String = NetGetCodeByRequestRetry(Address)
Log($"[Page] 已联网下载自定义主页,内容长度:{FileContent.Length},来源:{Address}")
Setup.Set("CacheSavedPageUrl", Address)
Setup.Set("CacheSavedPageVersion", Version)
WriteFile(PathTemp & "Cache\Custom.xaml", FileContent)
End If
@@ -146,11 +151,11 @@ Download:
Refresh()
Catch ex As Exception
If Setup.Get("CacheSavedPageVersion") = "" Then
Log(ex, $"联网下载自定义主页失败({Task.Input})", LogLevel.Msgbox)
Log(ex, $"联网下载自定义主页失败({Address})", LogLevel.Msgbox)
Else
Log(ex, $"联网下载自定义主页失败({Task.Input})")
Log(ex, $"联网下载自定义主页失败({Address})")
End If
Task.Input = ""
Address = ""
End Try
End Sub
@@ -208,6 +213,7 @@ Download:
GoTo Refresh '防止 SyncLock 死锁
End If
End Try
Log($"[Page] 实例化:加载自定义主页 UI 完成")
End SyncLock
Return
Refresh:
@@ -17,8 +17,8 @@
ComboName.ItemsSource = Nothing
Else
ComboName.ItemsSource = Setup.Get("LoginAuthEmail").ToString.Split("¨")
ComboName.Text = Setup.Get("LoginAuthEmail").ToString.Split("¨")(0)
If Setup.Get("LoginRemember") Then TextPass.Password = Setup.Get("LoginAuthPass").ToString.Split("¨")(0).Trim
ComboName.Text = Setup.Get("LoginAuthEmail").ToString.Before("¨")
If Setup.Get("LoginRemember") Then TextPass.Password = Setup.Get("LoginAuthPass").ToString.Before("¨").Trim
End If
End If
IsFirstLoad = False
@@ -26,7 +26,7 @@ Public Class PageLoginLegacy
ComboName.ItemsSource = Nothing
Else
ComboName.ItemsSource = Setup.Get("LoginLegacyName").ToString.Split("¨")
ComboName.Text = Setup.Get("LoginLegacyName").ToString.Split("¨")(0).Trim
ComboName.Text = Setup.Get("LoginLegacyName").ToString.Before("¨").Trim
End If
End If
IsReloaded = True
@@ -67,7 +67,8 @@
ComboAccounts.IsEnabled = False
BtnLogin.IsEnabled = False
BtnLogin.Text = "0%"
RunInNewThread(Sub()
RunInNewThread(
Sub()
Try
McLoginMsLoader.Start(GetLoginData(), IsForceRestart:=True)
Do While McLoginMsLoader.State = LoadState.Loading
@@ -89,11 +90,14 @@
If ex.Message = "$$" Then
ElseIf ex.Message.StartsWith("$") Then
Hint(ex.Message.TrimStart("$"), HintType.Critical)
ElseIf TypeOf ex Is Security.Authentication.AuthenticationException AndAlso ex.Message.ContainsF("SSL/TLS") Then
Log(ex, "正版登录验证失败,请尝试在 [设置 → 启动器] 中关闭 [验证 SSL 证书] 然后再试。" & vbCrLf & vbCrLf & "原始错误信息:", LogLevel.Msgbox)
Else
Log(ex, "微软登录尝试失败", LogLevel.Msgbox)
Log(ex, "正版登录尝试失败", LogLevel.Msgbox)
End If
Finally
RunInUi(Sub()
RunInUi(
Sub()
ComboAccounts.IsEnabled = True
BtnLogin.IsEnabled = True
BtnLogin.Text = "登录"
@@ -17,8 +17,8 @@
ComboName.ItemsSource = Nothing
Else
ComboName.ItemsSource = Setup.Get("LoginNideEmail").ToString.Split("¨")
ComboName.Text = Setup.Get("LoginNideEmail").ToString.Split("¨")(0)
If Setup.Get("LoginRemember") Then TextPass.Password = Setup.Get("LoginNidePass").ToString.Split("¨")(0).Trim
ComboName.Text = Setup.Get("LoginNideEmail").ToString.Before("¨")
If Setup.Get("LoginRemember") Then TextPass.Password = Setup.Get("LoginNidePass").ToString.Before("¨").Trim
End If
End If
IsFirstLoad = False
@@ -295,7 +295,7 @@
For i = 0 To Folders.Count - 1
If Folders(i) = "" Then Exit For
If Folders(i).ToString.EndsWith(Folder.Path) Then
Name = Folders(i).ToString.Split(">")(0)
Name = Folders(i).ToString.Before(">")
Folders.RemoveAt(i)
Exit For
End If
@@ -320,7 +320,7 @@
For i = 0 To Folders.Count - 1
If Folders(i) = "" Then Exit For
If Folders(i).ToString.EndsWith(Folder.Path) Then
'Name = Folders(i).ToString.Split(">")(0)
'Name = Folders(i).ToString.Before(">")
Folders.RemoveAt(i)
Exit For
End If
@@ -81,7 +81,7 @@
<TextBlock Grid.Row="0" VerticalAlignment="Center" HorizontalAlignment="Left" Text="游戏窗口标题" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextArgumentTitle" Grid.Row="0" Grid.ColumnSpan="2" Tag="LaunchArgumentTitle" Grid.Column="1" ToolTip="自定义游戏窗口的标题,若留空则不进行更改。&#xa;支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {name}:游戏版本名&#xa; · {date}、{time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号" HintText="默认" MaxLength="100" />
<TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="自定义信息" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextArgumentInfo" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchArgumentInfo" Text="Plain Craft Launcher 2" Grid.Column="1" ToolTip="该信息会显示在游戏主界面的左下角,与 F3 调试页面的左上角">
<local:MyTextBox x:Name="TextArgumentInfo" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchArgumentInfo" Text="PCL" Grid.Column="1" ToolTip="该信息会显示在游戏主界面的左下角,与 F3 调试页面的左上角">
<local:MyTextBox.ValidateRules>
<local:ValidateExcept>
<local:ValidateExcept.Excepts>
@@ -58,7 +58,7 @@
ToolTip="下载 Mod 时,若该 Mod 支持 Forge 和 Fabric,则显示为支持任意 Mod 加载器。&#xa;例如,开启时 JEI 显示支持全版本,关闭后 JEI 就会显示仅支持 Forge / Fabric 全版本。" />
<local:MyCheckBox Margin="0,2,0,4" Text="验证 SSL 证书" Grid.Row="9" Height="22" Grid.ColumnSpan="2"
x:Name="CheckDownloadCert" Tag="ToolDownloadCert"
ToolTip="在进行连接时,检查 SSL 证书是否正常。&#xa;进行验证会提高安全性,但疑似会导致少部分玩家的微软登录失败。" />
ToolTip="验证证书会提高安全性,但疑似有概率导致正版登录失败(#3018)。&#xa;如果在正版登录时因为 [根据验证过程,远程证书无效] 失败,可以尝试关闭此项。" />
</Grid>
</StackPanel>
</local:MyCard>
@@ -1,4 +1,6 @@
Public Class PageSpeedLeft
Imports System.Threading.Tasks
Public Class PageSpeedLeft
Private Const WatcherInterval As Integer = 300
'初始化
@@ -59,8 +61,8 @@
If FrmSpeedRight Is Nothing OrElse FrmSpeedRight.PanMain Is Nothing Then Exit Sub
Try
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
TaskRefresh(LoaderTaskbar(i))
For Each Loader In LoaderTaskbar.ToList
TaskRefresh(Loader)
Next
End SyncLock
Catch ex As Exception
@@ -110,7 +112,7 @@
#Region "进度不同,更新卡片"
Try
If Card.Children.Count < LoaderList.Count * 2 Then
Log("刷新下载管理卡片失败:卡片中仅有 " & Card.Children.Count & " 个子项", LogLevel.Debug)
Log($"[Watcher] 刷新下载管理卡片 {Loader.Name} 失败:卡片中仅有 {Card.Children.Count} 个子项,要求至少有 {LoaderList.Count * 2} 个子项", LogLevel.Debug)
Exit Try
End If
Dim Row As Integer = 0
@@ -137,7 +139,7 @@
Row += 1
Next
Catch ex As Exception
Log(ex, "刷新下载管理卡片失败", LogLevel.Feedback)
Log(ex, $"刷新下载管理卡片 {Loader.Name} 失败", LogLevel.Feedback)
End Try
#End Region
End Select
@@ -191,10 +193,15 @@
'添加取消按钮
Dim Cancel As New MyIconButton With {.Name = "BtnCancel", .Logo = "F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z", .Height = 20, .Margin = New Thickness(0, 10, 10, 0), .LogoScale = 1.1, .HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Top}
Card.Children.Add(Cancel)
AddHandler Cancel.Click, Sub(sender As MyIconButton, e As EventArgs)
AddHandler Cancel.Click,
Sub(sender As MyIconButton, e As EventArgs)
AniDispose(sender, False)
AniDispose(Card, True, Sub() If FrmSpeedRight.PanMain.Children.Count = 0 AndAlso FrmMain.PageCurrent = FormMain.PageType.DownloadManager Then FrmMain.PageBack())
RightCards.Remove(Loader.Name)
SyncLock LoaderTaskbarLock
LoaderTaskbar.Remove(Loader)
Log($"[Taskbar] 由于下载管理卡片关闭,{Loader.Name} 已移出任务列表")
End SyncLock
Log($"[Watcher] 关闭下载管理卡片:{Loader.Name}")
RunInThread(Sub() Loader.Abort())
End Sub