Compare commits

..
62 Commits
Author SHA1 Message Date
龙腾猫跃 a84601d99c 2.7.2 2024-05-13 18:09:30 +08:00
龙腾猫跃 a5a3800957 Merge pull request #3781 from Chiloven945/main
修改模组及整合包版本筛选列表冗余
2024-05-06 17:14:35 +08:00
龙腾猫跃 baba653a67 Update README.md 2024-05-06 17:10:37 +08:00
龙腾猫跃 5733cbdb0e Merge pull request #3768 from allMagicNB/Revive-#85-#91-#192
Revive #85 #91 #192
2024-05-06 16:09:33 +08:00
ClovenBugle 6e1072d042 修改整合包版本筛选列表冗余
删去1.20、1.20.3、1.20.5因均有被继后版本修复的bug
添加1.19.2因其为1.19最常用的模组版本
2024-05-04 11:40:42 +08:00
ClovenBugle efe58c9748 修改模组版本筛选列表冗余
删去1.20、1.20.3、1.20.5因均有被继后版本修复的bug
添加1.19.2因其为1.19最常用的模组版本
2024-05-04 11:37:50 +08:00
allMagicNB 5b58e3868d 更换爱发电主页链接 2024-05-01 16:28:24 +08:00
allMagicNB 0a48feba18 不加了不加了……都预览不了 2024-05-01 14:58:46 +08:00
allMagicNB 7d89b90ae1 换 SVG…… 2024-05-01 14:31:02 +08:00
allMagicNB f6cae4ea23 添加 “赞助-爱发电” Badge 2024-05-01 14:14:29 +08:00
allMagicNB a09baee5f8 添加 “赞助-爱发电” Badge 2024-05-01 14:13:20 +08:00
allMagicNB fa3d5bc09b 增加 “Issues” Badge 2024-05-01 13:33:39 +08:00
allMagicNB c169532794 为 Bagde 添加链接和说明 2024-05-01 10:48:38 +08:00
allMagic 37313e4d6e Update README.md
再改下
2024-05-01 10:18:04 +08:00
allMagic dd9cdaf15f Update README.md
换了下 Star 的 Logo
2024-05-01 10:17:32 +08:00
allMagic 6a2f95e96f Update README.md
Revive #85 #91 #192
2024-04-30 23:00:24 +08:00
龙腾猫跃 d682b59803 Merge pull request #3732 from allMagicNB/main
增加资源下载界面的 1.20.5(#3731)
2024-04-25 04:14:52 +08:00
allMagic 02347239b4 Add 1.20.5 2024-04-25 02:12:48 +08:00
allMagic dc4eda533c Add 1.20.5 2024-04-25 02:10:28 +08:00
龙腾猫跃 d86ad945a6 Merge pull request #3699 from zkitefly/crash
updata CrashReason.Fabric报错并给出解决方案
2024-04-19 22:04:02 +08:00
zkitefly 12be800391 updata CrashReason.Fabric报错并给出解决方案 2024-04-19 13:52:59 +00:00
龙腾猫跃 c47b80df36 2.7.1 正式版 2024-04-08 17:15:20 +08:00
龙腾猫跃 43b0acba08 2.7.1 2024-04-08 01:54:35 +08:00
龙腾猫跃 c1cad542c2 Merge pull request #3530 from wuliaodexiaoluo/main
添加 JVM 参数
2024-04-05 22:14:26 +08:00
龙腾猫跃 09f9b8f1e5 Merge branch 'main' into main 2024-04-05 22:14:18 +08:00
龙腾猫跃 4241060010 2.7.0 正式版 2024-04-05 17:36:13 +08:00
龙腾猫跃 0dab617b64 2.7.0 2024-04-04 03:26:43 +08:00
龙腾猫跃 515b7e89c5 Merge pull request #3593 from allMagicNB/main
fix #3591
2024-04-04 01:26:23 +08:00
allMagic d83f98b34a fix #3591 2024-04-02 13:32:14 +08:00
allMagic e2030970a3 fix #3591 2024-04-02 06:23:00 +08:00
allMagic e623d3464a fix #3591 2024-04-01 22:55:39 +08:00
allMagic 81346f0821 fix #3591 2024-04-01 22:37:05 +08:00
allMagic 810c6e8618 fix #3591 2024-04-01 22:17:49 +08:00
wuliaodexiaoluo a5199d32ed Update FormMain.xaml.vb 2024-03-20 08:42:54 +08:00
wuliaodexiaoluo b058e7722d Update FormMain.xaml.vb 2024-03-19 14:52:56 +08:00
wuliaodexiaoluo 4beef0fb5d Merge pull request #4 from wuliaodexiaoluo/wuliaodexiaoluo-patch-2
Update FormMain.xaml.vb
2024-03-19 13:56:29 +08:00
wuliaodexiaoluo eb195373ea Update FormMain.xaml.vb
修复 UAC 阻止文件拖拽
2024-03-19 13:56:11 +08:00
wuliaodexiaoluo 65ca2e0cf4 Update PageSetupLaunch.xaml 2024-03-16 13:10:15 +08:00
wuliaodexiaoluo 09e420ad6b Merge pull request #3 from wuliaodexiaoluo/wuliaodexiaoluo-patch-2
Update PageSetupLaunch.xaml
2024-03-16 13:01:45 +08:00
wuliaodexiaoluo 95429cc9cc Merge branch 'main' into wuliaodexiaoluo-patch-2 2024-03-16 13:01:37 +08:00
wuliaodexiaoluo 5a78a46b28 Update PageSetupLaunch.xaml
解决描述错误
2024-03-16 12:53:00 +08:00
wuliaodexiaoluo 3ae624d4fb Update PageSetupLaunch.xaml
手滑了抱歉。。。
2024-03-16 12:51:14 +08:00
wuliaodexiaoluo 91f39f2afd Merge pull request #2 from wuliaodexiaoluo/wuliaodexiaoluo-patch-1
Fix # 3511
2024-03-16 12:31:42 +08:00
wuliaodexiaoluo 65da5b67f7 Update PageSetupLaunch.xaml 2024-03-16 12:30:46 +08:00
wuliaodexiaoluo 268cb092dd Update PageSetupLaunch.xaml 2024-03-16 12:27:47 +08:00
wuliaodexiaoluo 9728af60d0 Update PageSetupLaunch.xaml 2024-03-16 12:24:48 +08:00
wuliaodexiaoluo 7affc1e24f Merge pull request #1 from Hex-Dragon/main
Update
2024-03-16 12:23:26 +08:00
龙腾猫跃 3076f3a6b7 Merge pull request #3475 from WorldHim/patch-1
修复 #3461 换行缺失
2024-03-03 04:42:17 +08:00
WorldHim 02c8b7211b fix: #3461 2024-03-02 20:30:02 +08:00
龙腾猫跃 5843649cfa 2.6.15 正式版 2024-03-02 18:04:12 +08:00
龙腾猫跃 f78250020e 2.6.15 2024-03-02 17:53:55 +08:00
龙腾猫跃 031cd898f6 Merge pull request #3427 from zkitefly/patch-4
Update bug2.yml
2024-02-26 06:14:19 +08:00
zkitefly 1b272a6f06 更新 bug2.yml 2024-02-25 17:23:50 +08:00
zkiteflyand柚子柚子 f2e9be66c1 Update .github/ISSUE_TEMPLATE/bug2.yml
Co-authored-by: 柚子柚子 <[email protected]>
2024-02-25 15:28:04 +08:00
zkitefly c719803849 Update bug2.yml
?
2024-02-25 15:15:13 +08:00
zkiteflyand何杰豪 2b485233cb Update .github/ISSUE_TEMPLATE/bug2.yml
Co-authored-by: 何杰豪 <[email protected]>
2024-02-25 15:10:49 +08:00
zkitefly 5198298336 Update bug2.yml 2024-02-25 15:07:14 +08:00
zkitefly a1a2d53d31 Update bug2.yml 2024-02-25 11:37:16 +08:00
龙腾猫跃 ec6784d57d 2.6.14 正式版 2024-02-23 17:59:24 +08:00
龙腾猫跃 83ebc61d8a 2.6.14 2024-02-22 00:04:00 +08:00
龙腾猫跃 63d48b09e3 Merge pull request #3231 from zkitefly/fabric_error-chinese
添加"Fabric报错并给出解决方案"中文检查支持
2024-02-20 04:27:32 +08:00
zkitefly 4a25b066d2 Fix https://github.com/Hex-Dragon/PCL2/issues/3228 . 添加"Fabric报错并给出解决方案"中文检查支持 2024-01-31 11:39:32 +00:00
72 changed files with 5466 additions and 5318 deletions

No files matched your search

+2 -2
View File
@@ -8,7 +8,7 @@ body:
label: "检查项"
description: "请逐个检查下列项目,并勾选确认。"
options:
- label: "**我已尝试使用其他启动器,其他启动器没有出现问题。** 如果其他启动器也存在问题,证明是网络环境不佳[(解决方法)](https://shimo.im/docs/qKPttVvXKqPD8YDC#anchor-0hDr),并非 PCL 的问题,请 **不要** 提交反馈。[下载其他启动器](https://www.mcbbs.net/forum.php?mod=forumdisplay&fid=43&filter=typeid&typeid=908)"
- label: "**我已尝试使用其他启动器,其他启动器没有出现问题。** 如果其他启动器也存在问题,证明是网络环境不佳[(解决方法)](https://shimo.im/docs/qKPttVvXKqPD8YDC#anchor-0hDr),并非 PCL 的问题,请 **不要** 提交反馈。[下载 HMCL](https://hmcl.huangyuhui.net/download)"
required: false
- label: "我知晓大多数此类问题都是网络环境不佳导致的,但我确实认为我的问题可能是 PCL 导致的,和网络环境无关。"
required: true
@@ -38,4 +38,4 @@ body:
description: "上传 PCL 文件夹中的 Log1~5.txt。[日志在哪?](https://shimo.im/docs/qKPttVvXKqPD8YDC#anchor-fvZW)"
placeholder: "先点击这个文本框,然后再将文件直接拖拽到文本框中以上传。"
validations:
required: true
required: true
+1 -1
View File
@@ -277,7 +277,7 @@
<Setter Property="ScrollViewer.PanningMode" Value="VerticalFirst"/>
<Setter Property="Stylus.IsFlicksEnabled" Value="False"/>
<Setter Property="UndoLimit" Value="15" />
<Setter Property="MaxLength" Value="10000" />
<Setter Property="MaxLength" Value="1000" />
<Setter Property="BorderBrush" Value="{DynamicResource ColorBrushBg0}" />
<Setter Property="Template">
<Setter.Value>
+20 -19
View File
@@ -19,7 +19,6 @@ Public Class Application
'开始
Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup
ApplicationStartTick = GetTimeTick()
SecretOnApplicationStart()
Try
'检查参数调用
@@ -28,11 +27,11 @@ Public Class Application
'自动更新
UpdateReplace(e.Args(1), e.Args(2).Trim(""""), e.Args(3).Trim(""""), e.Args(4))
Environment.Exit(Result.Cancel)
'ElseIf e.Args(0).StartsWith("--link") Then
'ElseIf e.Args(0).StartsWithF("--link") Then
' '稍作等待后切换到联机页面
' Thread.Sleep(1000)
' FormMain.IsLinkRestart = True
ElseIf e.Args(0).StartsWith("--memory") Then
ElseIf e.Args(0).StartsWithF("--memory") Then
'内存优化
Dim Ram = My.Computer.Info.AvailablePhysicalMemory
Try
@@ -47,9 +46,12 @@ Public Class Application
Environment.Exit((My.Computer.Info.AvailablePhysicalMemory - Ram) / 1024) '返回清理的内存量(K)
End If
#If DEBUG Then
ElseIf e.Args(0) = "--make" Then
'制作更新包
UpdateMake(e.Args(1))
ElseIf e.Args(0) = "--edit1" Then
ExeEdit(e.Args(1), True)
Environment.Exit(Result.Cancel)
ElseIf e.Args(0) = "--edit2" Then
ExeEdit(e.Args(1), False)
Environment.Exit(Result.Cancel)
#End If
End If
@@ -101,9 +103,10 @@ Public Class Application
'日志初始化
LogStart()
'添加日志
Log("[Start] 程序版本:" & VersionDisplayName & "(" & VersionCode & ")")
Log("[Start] 识别码:" & UniqueAddress & If(ThemeCheckOne(9), ",已解锁反馈主题", ""))
Log("[Start] 程序路径:" & PathWithName)
Log($"[Start] 程序版本:{VersionDisplayName} ({VersionCode})")
Log($"[Start] 识别码:{UniqueAddress}{If(ThemeCheckOne(9), ",已解锁反馈主题", "")}")
Log($"[Start] 程序路径:{PathWithName}")
Log($"[Start] 系统编码:{Encoding.Default} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})")
'检测压缩包运行
If Path.Contains(IO.Path.GetTempPath()) OrElse Path.Contains("AppData\Local\Temp\") Then
MyMsgBox("PCL 正在临时文件夹运行,设置、游戏存档等很可能无法保存,且部分功能会无法使用或出错。" & vbCrLf & "请将 PCL 从压缩文件中解压,或是更换文件夹后再继续使用!", "环境警告", "我知道了", IsWarn:=True)
@@ -112,13 +115,11 @@ Public Class Application
Setup.Load("SystemDebugMode")
Setup.Load("SystemDebugAnim")
Setup.Load("ToolDownloadThread")
Setup.Load("ToolDownloadCert")
'网络配置初始化
ServicePointManager.Expect100Continue = True
ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12
ServicePointManager.DefaultConnectionLimit = 1024
'ServicePointManager.ServerCertificateValidationCallback = New Security.RemoteCertificateValidationCallback(Function() As Boolean
' Return True
' End Function)
'计时
Log("[Start] 第一阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms")
ApplicationStartTick = GetTimeTick()
@@ -172,7 +173,7 @@ Public Class Application
Private Shared ReadOnly AssemblyJsonLock As New Object
Private Shared ReadOnly AssemblyDialogLock As New Object
Public Shared Function AssemblyResolve(sender As Object, args As ResolveEventArgs) As Assembly
If args.Name.StartsWith("NAudio") Then
If args.Name.StartsWithF("NAudio") Then
SyncLock AssemblyNAudioLock
If AssemblyNAudio Is Nothing Then
Log("[Start] 加载 DLL:NAudio")
@@ -180,7 +181,7 @@ Public Class Application
End If
Return AssemblyNAudio
End SyncLock
ElseIf args.Name.StartsWith("Newtonsoft.Json") Then
ElseIf args.Name.StartsWithF("Newtonsoft.Json") Then
SyncLock AssemblyJsonLock
If AssemblyJson Is Nothing Then
Log("[Start] 加载 DLL:Json")
@@ -188,7 +189,7 @@ Public Class Application
End If
Return AssemblyJson
End SyncLock
ElseIf args.Name.StartsWith("Ookii.Dialogs.Wpf") Then
ElseIf args.Name.StartsWithF("Ookii.Dialogs.Wpf") Then
SyncLock AssemblyDialogLock
If AssemblyDialog Is Nothing Then
Log("[Start] 加载 DLL:Dialogs")
@@ -219,7 +220,7 @@ Public Class Application
Names.Remove(sender.Tag)
Setup.Set("LoginLegacyName", Join(Names, "¨"))
FrmLoginLegacy.ComboName.ItemsSource = Names
FrmLoginLegacy.ComboName.Text = If(Names.Count > 0, Names(0), "")
FrmLoginLegacy.ComboName.Text = If(Names.Any, Names(0), "")
Case Else
'第三方
Dim Token As String = GetStringFromEnum(Setup.Get("LoginType"))
@@ -237,12 +238,12 @@ Public Class Application
Select Case Token
Case "Nide"
FrmLoginNide.ComboName.ItemsSource = Dict.Keys
FrmLoginNide.ComboName.Text = If(Dict.Keys.Count > 0, Dict.Keys(0), "")
FrmLoginNide.TextPass.Password = If(Dict.Values.Count > 0, Dict.Values(0), "")
FrmLoginNide.ComboName.Text = If(Dict.Keys.Any, Dict.Keys(0), "")
FrmLoginNide.TextPass.Password = If(Dict.Values.Any, Dict.Values(0), "")
Case "Auth"
FrmLoginAuth.ComboName.ItemsSource = Dict.Keys
FrmLoginAuth.ComboName.Text = If(Dict.Keys.Count > 0, Dict.Keys(0), "")
FrmLoginAuth.TextPass.Password = If(Dict.Values.Count > 0, Dict.Values(0), "")
FrmLoginAuth.ComboName.Text = If(Dict.Keys.Any, Dict.Keys(0), "")
FrmLoginAuth.TextPass.Password = If(Dict.Values.Any, Dict.Values(0), "")
End Select
End Select
End Sub
@@ -138,7 +138,7 @@
Log("[Control] 按下按钮:" & Text)
RaiseEvent Click(sender, e)
If Not String.IsNullOrEmpty(Tag) Then
If Tag.ToString.StartsWith("链接-") OrElse Tag.ToString.StartsWith("启动-") Then
If Tag.ToString.StartsWithF("链接-") OrElse Tag.ToString.StartsWithF("启动-") Then
Hint("主页自定义按钮语法已更新,且不再兼容老版本语法,请查看新的自定义示例!")
End If
End If
@@ -1,7 +1,7 @@
Public Class MyIconButton
'声明
Public Event Click(sender As Object, e As EventArgs) '自定义事件
'自定义事件
Public Event Click(sender As Object, e As EventArgs)
'自定义属性
@@ -210,7 +210,7 @@
If Not IsNothing(PathLogo) Then Children.Remove(PathLogo)
'添加新 Logo
If Not _Logo = "" Then
If _Logo.ToLower.StartsWith("http") Then
If _Logo.StartsWithF("http", True) Then
'网络图片
PathLogo = New Image With {
.Tag = Me,
@@ -220,7 +220,7 @@
.RenderTransform = New ScaleTransform With {.ScaleX = LogoScale, .ScaleY = LogoScale},
.SnapsToDevicePixels = True, .UseLayoutRounding = False}
RenderOptions.SetBitmapScalingMode(PathLogo, BitmapScalingMode.Linear)
ElseIf _Logo.ToLower.EndsWith(".png") OrElse _Logo.ToLower.EndsWith(".jpg") Then
ElseIf _Logo.EndsWithF(".png", True) OrElse _Logo.EndsWithF(".jpg", True) Then
'位图
Dim Bitmap = New MyBitmap(_Logo)
PathLogo = New Canvas With {
@@ -328,7 +328,7 @@
ColumnCheck.Width = New GridLength(If(_Type = CheckType.None OrElse _Type = CheckType.Clickable, If(Height < 40, 4, 2), 6))
ColumnLogo.Width = New GridLength(If(_Logo = "", 0, 34) + If(Height < 40, 0, 4))
If Not IsNothing(PathLogo) Then
If _Logo.EndsWith(".png") Then
If _Logo.EndsWithF(".png", True) Then
PathLogo.Margin = New Thickness(4, 5, 3, 5)
Else
PathLogo.Margin = New Thickness(If(Height < 40, 6, 8), 8, If(Height < 40, 4, 6), 8)
@@ -58,11 +58,12 @@
Interop.ComponentDispatcher.PopModal()
'动画
AniStart({
AaCode(Sub()
If WaitingMyMsgBox.Count = 0 Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaCode(
Sub()
If Not WaitingMyMsgBox.Any() Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaOpacity(Me, -Opacity, 80, 20),
AaDouble(Sub(i) TransformPos.Y += i, 20 - TransformPos.Y, 150, 0, New AniEaseOutFluent),
AaDouble(Sub(i) TransformRotate.Angle += i, 6 - TransformRotate.Angle, 150, 0, New AniEaseInFluent(AniEasePower.Weak)),
@@ -63,11 +63,12 @@
Interop.ComponentDispatcher.PopModal()
'动画
AniStart({
AaCode(Sub()
If WaitingMyMsgBox.Count = 0 Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaCode(
Sub()
If Not WaitingMyMsgBox.Any() Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaOpacity(Me, -Opacity, 80, 20),
AaDouble(Sub(i) TransformPos.Y += i, 20 - TransformPos.Y, 150, 0, New AniEaseOutFluent),
AaDouble(Sub(i) TransformRotate.Angle += i, 6 - TransformRotate.Angle, 150, 0, New AniEaseInFluent(AniEasePower.Weak)),
@@ -56,11 +56,12 @@
Interop.ComponentDispatcher.PopModal()
'动画
AniStart({
AaCode(Sub()
If WaitingMyMsgBox.Count = 0 Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaCode(
Sub()
If Not WaitingMyMsgBox.Any() Then
AniStart(AaColor(FrmMain.PanMsg, Grid.BackgroundProperty, New MyColor(0, 0, 0, 0) - FrmMain.PanMsg.Background, 200, Ease:=New AniEaseOutFluent(AniEasePower.Weak)))
End If
End Sub, 30),
AaOpacity(Me, -Opacity, 80, 20),
AaDouble(Sub(i) TransformPos.Y += i, 20 - TransformPos.Y, 150, 0, New AniEaseOutFluent),
AaDouble(Sub(i) TransformRotate.Angle += i, 6 - TransformRotate.Angle, 150, 0, New AniEaseInFluent(AniEasePower.Weak)),
@@ -89,7 +89,7 @@
If PanAlways IsNot Nothing Then PanAlways.Visibility = Visibility.Collapsed
'初次运行加载器
If PageLoaderAutoRun Then
If PageLoader.GetType.Name.StartsWith("LoaderTask") Then
If PageLoader.GetType.Name.StartsWithF("LoaderTask") Then
PageLoader.Start(CType(PageLoader, Object).StartGetInput(Nothing, PageLoaderInputInvoke))
Else
Dim Input = Nothing
@@ -107,7 +107,7 @@
'重试
Public Sub PageLoaderRestart(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = True) '由外部调用的重试
If Not PageLoaderAutoRun Then Exit Sub
If PageLoader.GetType.Name.StartsWith("LoaderTask") Then
If PageLoader.GetType.Name.StartsWithF("LoaderTask") Then
PageLoader.Start(CType(PageLoader, Object).StartGetInput(Input, PageLoaderInputInvoke), IsForceRestart:=IsForceRestart)
Else
If Input Is Nothing AndAlso PageLoaderInputInvoke IsNot Nothing Then Input = PageLoaderInputInvoke()
+1 -1
View File
@@ -128,7 +128,7 @@ Public Class MyResizer
Private Declare Function GetMonitorInfo Lib "user32" (hMonitor As IntPtr, lpmi As MONITORINFO) As Boolean
Friend Declare Function MonitorFromWindow Lib "User32" (handle As IntPtr, flags As Integer) As IntPtr
Private Declare Function MonitorFromWindow Lib "User32" (handle As IntPtr, flags As Integer) As IntPtr
Private Sub connectMouseHandlers(element As UIElement)
AddHandler element.MouseLeftButtonDown, AddressOf Me.element_MouseLeftButtonDown
@@ -8,10 +8,12 @@
Private Sub MyScrollViewer_PreviewMouseWheel(sender As Object, e As MouseWheelEventArgs) Handles Me.PreviewMouseWheel
If e.Delta = 0 OrElse ActualHeight = 0 OrElse ScrollableHeight = 0 Then Exit Sub
Dim SourceType = e.Source.GetType
If Content.TemplatedParent Is Nothing AndAlso
((GetType(ComboBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, ComboBox).IsDropDownOpen) OrElse
(GetType(TextBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, TextBox).AcceptsReturn) OrElse
GetType(ComboBoxItem).IsAssignableFrom(SourceType)) Then
If Content.TemplatedParent Is Nothing AndAlso (
(GetType(ComboBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, ComboBox).IsDropDownOpen) OrElse
(GetType(TextBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, TextBox).AcceptsReturn) OrElse
GetType(ComboBoxItem).IsAssignableFrom(SourceType) OrElse
TypeOf e.Source Is CheckBox
) Then
'如果当前是在对有滚动条的下拉框或文本框执行,则不接管操作
Exit Sub
End If
+1 -1
View File
@@ -134,7 +134,7 @@
<Grid x:Name="PanTitleInner" Visibility="Collapsed" Margin="-16,0,0,0" Opacity="0" HorizontalAlignment="Left" Width="{Binding ActualWidth, ElementName=PanTitle, Mode=OneWay}">
<local:MyIconButton HorizontalAlignment="Left" Theme="White" x:Name="BtnTitleInner" Margin="12,0,0,0" Height="28" Width="28"
LogoScale="0.87" Logo="M1097.162313 584.707482 250.272424 584.707482 562.833701 896.95123C591.749274 925.859979 591.749274 972.659975 562.833701 1001.568724 533.91812 1030.477473 487.058315 1030.477473 458.142742 1001.568724L21.580946 565.451235C6.757449 550.631234-0.361728 531.131238 0.028357 511.679985L0.028357 511.631236 0.028357 511.582486C-0.361728 492.13124 6.757449 472.582488 21.580946 457.762487L458.142742 21.644997C487.058315-7.215002 533.91812-7.215002 562.833701 21.644997 591.749274 50.553746 591.749274 97.4025 562.833701 126.262499L250.272424 438.55499 1097.162313 438.55499C1137.585605 438.55499 1170.304578 471.266238 1170.304578 511.631236 1170.304578 551.947483 1137.585605 584.707482 1097.162313 584.707482L1097.162313 584.707482Z" />
<TextBlock SnapsToDevicePixels="False" IsHitTestVisible="False" Name="LabTitleInner" VerticalAlignment="Center" Margin="47,1,0,0" HorizontalAlignment="Left" Foreground="{DynamicResource ColorBrush8}" FontSize="15" />
<TextBlock SnapsToDevicePixels="False" IsHitTestVisible="False" Name="LabTitleInner" VerticalAlignment="Center" Margin="47,1,60,0" HorizontalAlignment="Left" Foreground="{DynamicResource ColorBrush8}" FontSize="15" />
</Grid>
</Grid>
<Grid x:Name="PanLeft" Grid.Row="1" HorizontalAlignment="Left" SnapsToDevicePixels="True">
+114 -202
View File
@@ -10,6 +10,29 @@ Public Class FormMain
Dim FeatureList As New List(Of KeyValuePair(Of Integer, String))
'统计更新日志条目
#If BETA Then
If LastVersion < 321 Then 'Release 2.7.1
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复启动部分整合包导致设置丢失的 Bug"))
BugCount += 1
End If
If LastVersion < 319 Then 'Release 2.7.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "支持更新 Mod"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "支持查看可更新的 Mod 的更新日志"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "支持滑动鼠标快速选中、取消选中多个 Mod"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法启动 MC 24w14a+ 的 Bug"))
FeatureCount += 10
BugCount += 10
End If
If LastVersion < 317 Then 'Release 2.6.15
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法安装 Forge 的 Bug"))
FeatureCount += 2
BugCount += 2
End If
If LastVersion < 315 Then 'Release 2.6.14
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 MC 下载,尝试解决各种导致 MC 下载失败的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "由于 MCBBS 关站,移除其相关内容"))
FeatureCount += 17
BugCount += 16
End If
If LastVersion < 313 Then 'Release 2.6.13
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法启动 Forge 1.18.3+ 的 Bug"))
FeatureCount += 6
@@ -71,64 +94,43 @@ Public Class FormMain
FeatureCount += 35
BugCount += 36
End If
If LastVersion < 281 Then 'Release 2.4.9
If LastVersion = 279 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复进入 Mod、整合包下载页时报错的 Bug"))
FeatureCount += 1
BugCount += 5
End If
If LastVersion < 279 Then 'Release 2.4.8
FeatureCount += 1
BugCount += 10
End If
If LastVersion < 276 Then 'Release 2.4.7
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "增加 在游戏启动前执行命令 设置"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在百宝箱添加了清理 MC 日志、崩溃报告的按钮"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化界面动画,修改部分配色"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文搜索"))
FeatureCount += 25
BugCount += 56
End If
If LastVersion < 272 Then 'Release 2.4.4
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "支持在版本设置页导出启动脚本、打开存档文件夹等"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 Mod、整合包下载的版本检查与显示"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修改部分配色,让整体边框变得更淡"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法从下载页安装最新 MC 版本的整合包的 Bug"))
If LastVersion <= 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法安装 LiteLoader 的 Bug"))
FeatureCount += 13
BugCount += 23
End If
If LastVersion < 268 Then 'Release 2.4.2
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "暂时关闭了联机功能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "游戏崩溃的弹窗添加了直接查看日志的选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在更多分类下添加了新功能投票选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "自动安装时支持检查 OptiFine 对 Forge 的具体版本需求"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化自动 Java 选择的准确度"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文名的显示"))
FeatureCount += 14
BugCount += 33
End If
If LastVersion < 265 Then 'Release 2.3.5
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复部分情况下无法启动路径带有中文的游戏的 Bug"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复多个可能导致 OptiFine、Forge 安装失败的 Bug"))
FeatureCount += 13
BugCount += 9
End If
If LastVersion < 260 Then 'Release 2.3.2
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "解决了联机人数 ≥3 人时出现的频繁掉线或突发高延迟的问题"))
FeatureCount += 22
BugCount += 4
End If
If LastVersion < 257 Then 'Release 2.3.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复下载部分 Mod、整合包的 Bug"))
FeatureCount += 4
BugCount += 4
End If
#Else
'5: FEAT+
'4: IMP+ FEAT*
'3:BUG+ IMP* FEAT-
'2:BUG* IMP-
'1:BUG-
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
BugCount += 18
End If
If LastVersion < 320 Then 'Snapshot 2.7.1
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复启动部分整合包导致设置丢失的 Bug"))
BugCount += 1
End If
If LastVersion < 318 Then 'Snapshot 2.7.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "支持更新 Mod"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "支持查看可更新的 Mod 的更新日志"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "支持滑动鼠标快速选中、取消选中多个 Mod"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法启动 MC 24w14a+ 的 Bug"))
FeatureCount += 10
BugCount += 10
End If
If LastVersion < 316 Then 'Snapshot 2.6.15
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法安装 Forge 的 Bug"))
FeatureCount += 2
BugCount += 2
End If
If LastVersion < 314 Then 'Snapshot 2.6.14
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 MC 下载,尝试解决各种导致 MC 下载失败的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "由于 MCBBS 关站,移除其相关内容"))
FeatureCount += 17
BugCount += 16
End If
If LastVersion < 312 Then 'Snapshot 2.6.13
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法启动 Forge 1.18.3+ 的 Bug"))
FeatureCount += 6
@@ -229,116 +231,29 @@ Public Class FormMain
FeatureCount += 5
BugCount += 5
End If
If LastVersion < 282 Then 'Snapshot 2.4.9
FeatureCount += 1
BugCount += 5
If LastVersion = 280 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复进入 Mod、整合包下载页时报错的 Bug"))
End If
If LastVersion < 280 Then 'Snapshot 2.4.8
FeatureCount += 1
BugCount += 10
End If
If LastVersion < 278 Then 'Snapshot 2.4.7
If LastVersion = 277 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复设置背景音乐可能导致无法启动 PCL 的 Bug"))
BugCount += 2
End If
If LastVersion < 277 Then 'Snapshot 2.4.6
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在百宝箱添加了清理 MC 日志、崩溃报告的按钮"))
FeatureCount += 8
BugCount += 21
End If
If LastVersion < 275 Then 'Snapshot 2.4.5
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "增加 在游戏启动前执行命令 设置"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化界面动画,修改部分配色"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文搜索"))
FeatureCount += 17
BugCount += 35
End If
If LastVersion < 273 Then 'Snapshot 2.4.4
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "支持在版本设置页导出启动脚本、打开存档文件夹等"))
If LastVersion = 271 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法同时开启多个 Minecraft 客户端的 Bug"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法从下载页安装最新 MC 版本的整合包的 Bug"))
FeatureCount += 7
BugCount += 8
End If
If LastVersion < 271 Then 'Snapshot 2.4.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 Mod、整合包下载的版本检查与显示"))
If LastVersion <= 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法安装 LiteLoader 的 Bug"))
FeatureCount += 6
BugCount += 15
End If
If LastVersion < 269 Then 'Snapshot 2.4.2
If LastVersion = 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法下载 CurseForge 整合包的 Bug"))
FeatureCount += 2
BugCount += 3
End If
If LastVersion < 267 Then 'Snapshot 2.4.1
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "暂时关闭了联机功能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "自动安装时支持检查 OptiFine 对 Forge 的具体版本需求"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化自动 Java 选择的准确度"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文名的显示"))
FeatureCount += 12
BugCount += 22
End If
If LastVersion < 266 Then 'Snapshot 2.4.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "游戏崩溃的弹窗添加了直接查看日志的选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在更多分类下添加了新功能投票选项"))
FeatureCount += 3
BugCount += 11
End If
If LastVersion < 264 Then 'Snapshot 2.3.5
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法启动部分 Forge 版本的 Bug"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复多个可能导致 OptiFine、Forge 安装失败的 Bug"))
FeatureCount += 2
BugCount += 3
End If
If LastVersion < 263 Then 'Snapshot 2.3.4
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复部分情况下无法启动路径带有中文的游戏的 Bug"))
FeatureCount += 11
BugCount += 5
End If
If LastVersion < 262 Then 'Snapshot 2.3.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "修复无法使用 Mod、整合包搜索功能的 Bug"))
BugCount += 1
End If
If LastVersion < 261 Then 'Snapshot 2.3.2
FeatureCount += 8
BugCount += 4
End If
If LastVersion < 259 Then 'Snapshot 2.3.1
FeatureList.Add(New KeyValuePair(Of Integer, String)(4, "解决了联机人数 ≥3 人时出现的频繁掉线或突发高延迟的问题"))
FeatureCount += 14
End If
If LastVersion < 258 Then 'Snapshot 2.3.0
FeatureCount += 4
BugCount += 4
End If
#End If
'整理更新日志文本
Dim ContentList As New List(Of String)
Dim SortedFeatures = Sort(FeatureList, Function(Left As KeyValuePair(Of Integer, String), Right As KeyValuePair(Of Integer, String)) As Boolean
Return Left.Key > Right.Key
End Function)
If SortedFeatures.Count = 0 AndAlso FeatureCount = 0 AndAlso BugCount = 0 Then
ContentList.Add("龙猫忘记写更新日志啦!可以去提醒他一下……")
End If
Dim SortedFeatures = Sort(FeatureList, Function(Left, Right) Left.Key > Right.Key)
If Not SortedFeatures.Any() AndAlso FeatureCount = 0 AndAlso BugCount = 0 Then ContentList.Add("龙猫忘记写更新日志啦!可以去提醒他一下……")
For i = 0 To Math.Min(9, SortedFeatures.Count - 1) '最多取 10 项
ContentList.Add(SortedFeatures(i).Value)
Next
If SortedFeatures.Count > 10 Then FeatureCount += SortedFeatures.Count - 10
If FeatureCount > 0 OrElse BugCount > 0 Then
ContentList.Add(If(FeatureCount > 0, "其他 " & FeatureCount & " 项小调整与修改", "") &
If(FeatureCount > 0 AndAlso BugCount > 0, ",", "") &
If(BugCount > 0, "修复了 " & BugCount & " 个 Bug", "") &
",详见完整更新日志")
If(FeatureCount > 0 AndAlso BugCount > 0, ",", "") &
If(BugCount > 0, "修复了 " & BugCount & " 个 Bug", "") &
",详见完整更新日志")
End If
Dim Content As String = "· " & Join(ContentList, vbCrLf & "· ")
'输出更新日志
RunInNewThread(Sub()
If MyMsgBox(Content, "PCL 已更新至 " & VersionDisplayName, "确定", "完整更新日志") = 2 Then
OpenWebsite("https://afdian.net/a/LTCat?tab=feed")
End If
End Sub, "UpdateLog Output")
RunInNewThread(
Sub()
If MyMsgBox(Content, "PCL 已更新至 " & VersionDisplayName, "确定", "完整更新日志") = 2 Then
OpenWebsite("https://afdian.net/a/LTCat?tab=feed")
End If
End Sub, "UpdateLog Output")
End Sub
'窗口加载
@@ -490,7 +405,6 @@ Public Class FormMain
Log("[Start] 第三阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms")
End Sub
'Private Declare Function ChangeWindowMessageFilter Lib "user32.dll" (message As Integer, action As Integer) As Boolean
'根据打开次数触发的事件
Private Sub RunCountSub()
Setup.Set("SystemCount", Setup.Get("SystemCount") + 1)
@@ -528,6 +442,8 @@ Public Class FormMain
Log("[Start] 最高版本号从 " & LowerVersionCode & " 升高到 " & VersionCode)
End If
#End If
'被移除的窗口设置选项
If Setup.Get("LaunchArgumentWindowType") = 5 Then Setup.Set("LaunchArgumentWindowType", 1)
'修改主题设置项名称
If LowerVersionCode <= 207 Then
Dim UnlockedTheme As New List(Of String) From {"2"}
@@ -751,7 +667,7 @@ Public Class FormMain
If e.ChangedButton = MouseButton.XButton1 OrElse e.ChangedButton = MouseButton.XButton2 Then TriggerPageBack()
End Sub
Private Sub TriggerPageBack()
If PageCurrent = PageType.Download AndAlso PageCurrentSub = PageSubType.DownloadInstall Then
If PageCurrent = PageType.Download AndAlso PageCurrentSub = PageSubType.DownloadInstall AndAlso FrmDownloadInstall.IsInSelectPage Then
FrmDownloadInstall.ExitSelectPage()
Else
PageBack()
@@ -788,7 +704,7 @@ Public Class FormMain
Try
Dim Str As String = e.Data.GetData(DataFormats.Text)
Log("[System] 接受文本拖拽:" & Str)
If Str.StartsWith("authlib-injector:yggdrasil-server:") Then
If Str.StartsWithF("authlib-injector:yggdrasil-server:") Then
'Authlib 拖拽
e.Handled = True
Dim AuthlibServer As String = Net.WebUtility.UrlDecode(Str.Substring("authlib-injector:yggdrasil-server:".Length))
@@ -831,7 +747,7 @@ Public Class FormMain
'正在主页,需要刷新左边栏
FrmLaunchLeft.RefreshPage(True, False)
End If
ElseIf Str.StartsWith("file:///") Then
ElseIf Str.StartsWithF("file:///") Then
'文件拖拽(例如从浏览器下载窗口拖入)
Dim FilePath = Net.WebUtility.UrlDecode(Str).Substring("file:///".Length).Replace("/", "\")
e.Handled = True
@@ -859,7 +775,7 @@ Public Class FormMain
RunInNewThread(
Sub()
Dim FilePath As String = FilePathList.First
Log("[System] 接受文件拖拽:" & FilePath & If(FilePathList.Count > 0, $" 等 {FilePathList.Count} 个文件", ""), LogLevel.Developer)
Log("[System] 接受文件拖拽:" & FilePath & If(FilePathList.Any, $" 等 {FilePathList.Count} 个文件", ""), LogLevel.Developer)
'基础检查
If Directory.Exists(FilePathList.First) AndAlso Not File.Exists(FilePathList.First) Then
Hint("请拖入一个文件,而非文件夹!", HintType.Critical)
@@ -906,7 +822,7 @@ Public Class FormMain
Hint("若要安装 Mod,请先选择一个可以安装 Mod 的版本!")
ElseIf Not (PageCurrent = PageType.VersionSetup AndAlso PageCurrentSub = PageSubType.VersionMod) Then
'未处于 Mod 管理页面
If MyMsgBox($"是否要将这些文件作为 Mod 安装到 {TargetVersion.Name}?", "Mod 安装确认", "确定", "取消") = 1 Then GoTo Install
If MyMsgBox($"是否要将这{If(FilePathList.Count = 1, "个", "些")}文件作为 Mod 安装到 {TargetVersion.Name}?", "Mod 安装确认", "确定", "取消") = 1 Then GoTo Install
Else
'处于 Mod 管理页面
Install:
@@ -994,7 +910,6 @@ Install:
Left -= 10000
ShowInTaskbar = False
Visibility = Visibility.Hidden
'SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW)
Log("[System] 窗口已隐藏,位置:(" & Left & "," & Top & ")")
Else
'取消隐藏
@@ -1017,16 +932,9 @@ Install:
Topmost = False
SetForegroundWindow(Handle)
Focus()
'ShowWindow(Handle, 1) 'SW_RESTORE
'SetWindowPos(Handle, 0, 0, 0, 0, 0, 3) 'InsertAfter: TOP, NOMOVE & NOSIZE
'SetFocus(Handle)
Log("[System] 窗口已置顶,位置:(" & Left & ", " & Top & "), " & Width & " x " & Height)
End Sub)
End Sub
'Private Declare Function SetFocus Lib "user32" (hWnd As IntPtr) As IntPtr
'Private Declare Function SetWindowPos Lib "user32" (hWnd As IntPtr, hWndInsertAfter As IntPtr, x As Integer, y As Integer, cx As Integer, cy As Integer, flags As UInteger) As Boolean
'Private Declare Function AttachThreadInput Lib "user32" (attachFrom As IntPtr, attachTo As IntPtr, isAttach As Boolean) As Boolean
'Private Declare Function SendMessage Lib "user32" (hWnd As IntPtr, msg As UInteger, wParam As Long, lParam As Long) As IntPtr
#End Region
@@ -1282,8 +1190,11 @@ Install:
''' 通过点击返回按钮或手动触发返回来改变页面。
''' </summary>
Public Sub PageBack() Handles BtnTitleInner.Click
If PageStack.Count = 0 Then Exit Sub
PageChangeActual(PageStack(0))
If PageStack.Any() Then
PageChangeActual(PageStack(0))
Else
PageChange(PageType.Launch)
End If
End Sub
'实际处理页面切换
@@ -1302,27 +1213,13 @@ Install:
PageChangeExit()
Else
'即将切换到一个子页面
If PageStack.Count = 0 Then
'主页面 → 子页面,进入
PanTitleInner.Visibility = Visibility.Visible
PanTitleMain.IsHitTestVisible = False
PanTitleInner.IsHitTestVisible = True
PageNameRefresh(Stack)
AniStart({
AaOpacity(PanTitleMain, -PanTitleMain.Opacity, 150),
AaX(PanTitleMain, 12 - PanTitleMain.Margin.Left, 150,, New AniEaseInFluent(AniEasePower.Weak)),
AaOpacity(PanTitleInner, 1 - PanTitleInner.Opacity, 150, 200),
AaX(PanTitleInner, -PanTitleInner.Margin.Left, 350, 200, New AniEaseOutBack),
AaCode(Sub() PanTitleMain.Visibility = Visibility.Collapsed,, True)
}, "FrmMain Titlebar FirstLayer")
PageStack.Insert(0, PageCurrent)
Else
If PageStack.Any Then
'子页面 → 另一个子页面,更新
AniStart({
AaOpacity(LabTitleInner, -LabTitleInner.Opacity, 130),
AaCode(Sub() LabTitleInner.Text = PageName,, True),
AaOpacity(LabTitleInner, 1, 150, 30)
}, "FrmMain Titlebar SubLayer")
AaOpacity(LabTitleInner, -LabTitleInner.Opacity, 130),
AaCode(Sub() LabTitleInner.Text = PageName,, True),
AaOpacity(LabTitleInner, 1, 150, 30)
}, "FrmMain Titlebar SubLayer")
If PageStack.Contains(Stack) Then
'返回到更上层的子页面
Do While PageStack.Contains(Stack)
@@ -1332,6 +1229,20 @@ Install:
'进入更深层的子页面
PageStack.Insert(0, PageCurrent)
End If
Else
'主页面 → 子页面,进入
PanTitleInner.Visibility = Visibility.Visible
PanTitleMain.IsHitTestVisible = False
PanTitleInner.IsHitTestVisible = True
PageNameRefresh(Stack)
AniStart({
AaOpacity(PanTitleMain, -PanTitleMain.Opacity, 150),
AaX(PanTitleMain, 12 - PanTitleMain.Margin.Left, 150,, New AniEaseInFluent(AniEasePower.Weak)),
AaOpacity(PanTitleInner, 1 - PanTitleInner.Opacity, 150, 200),
AaX(PanTitleInner, -PanTitleInner.Margin.Left, 350, 200, New AniEaseOutBack),
AaCode(Sub() PanTitleMain.Visibility = Visibility.Collapsed,, True)
}, "FrmMain Titlebar FirstLayer")
PageStack.Insert(0, PageCurrent)
End If
End If
#End Region
@@ -1438,9 +1349,7 @@ Install:
''' 退出子界面。
''' </summary>
Private Sub PageChangeExit()
If PageStack.Count = 0 Then
'主页面 → 主页面,无事发生
Else
If PageStack.Any Then
'子页面 → 主页面,退出
PanTitleMain.Visibility = Visibility.Visible
PanTitleMain.IsHitTestVisible = True
@@ -1453,6 +1362,8 @@ Install:
AaCode(Sub() PanTitleInner.Visibility = Visibility.Collapsed,, True)
}, "FrmMain Titlebar FirstLayer")
PageStack.Clear()
Else
'主页面 → 主页面,无事发生
End If
End Sub
@@ -1463,23 +1374,22 @@ Install:
End Sub
Private Sub PanMainLeft_Resize(NewWidth As Double)
Dim Delta As Double = NewWidth - RectLeftBackground.Width
If Math.Abs(Delta) < 0.1 Then Exit Sub
If AniControlEnabled = 0 Then
If Math.Abs(Delta) > 0.1 AndAlso AniControlEnabled = 0 Then
If PanMain.Opacity < 0.1 Then PanMainLeft.IsHitTestVisible = False '避免左边栏指向背景未能完美覆盖左边栏
If NewWidth > 0 Then
'宽度足够,显示
AniStart({
AaWidth(RectLeftBackground, NewWidth - RectLeftBackground.Width, 400,, New AniEaseOutFluent(AniEasePower.ExtraStrong)),
AaOpacity(RectLeftShadow, 1 - RectLeftShadow.Opacity, 200),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 250)
}, "FrmMain LeftChange", True)
AaWidth(RectLeftBackground, NewWidth - RectLeftBackground.Width, 400,, New AniEaseOutFluent(AniEasePower.ExtraStrong)),
AaOpacity(RectLeftShadow, 1 - RectLeftShadow.Opacity, 200),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 250)
}, "FrmMain LeftChange", True)
Else
'宽度不足,隐藏
AniStart({
AaWidth(RectLeftBackground, -RectLeftBackground.Width, 200,, New AniEaseOutFluent),
AaOpacity(RectLeftShadow, -RectLeftShadow.Opacity, 200),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 170)
}, "FrmMain LeftChange", True)
AaWidth(RectLeftBackground, -RectLeftBackground.Width, 200,, New AniEaseOutFluent),
AaOpacity(RectLeftShadow, -RectLeftShadow.Opacity, 200),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 170)
}, "FrmMain LeftChange", True)
End If
Else
RectLeftBackground.Width = NewWidth
@@ -1573,7 +1483,11 @@ Install:
''' </summary>
Public Sub BackToTop() Handles BtnExtraBack.Click
Dim RealScroll As MyScrollViewer = BtnExtraBack_GetRealChild()
RealScroll.PerformVerticalOffsetDelta(-RealScroll.VerticalOffset)
If RealScroll IsNot Nothing Then
RealScroll.PerformVerticalOffsetDelta(-RealScroll.VerticalOffset)
Else
Log("[UI] 无法返回顶部,未找到合适的 RealScroll", LogLevel.Hint)
End If
End Sub
Private Function BtnExtraBack_ShowCheck() As Boolean
Dim RealScroll As MyScrollViewer = BtnExtraBack_GetRealChild()
@@ -1581,9 +1495,7 @@ Install:
End Function
Private Function BtnExtraBack_GetRealChild() As MyScrollViewer
If PanMainRight.Child Is Nothing OrElse TypeOf PanMainRight.Child IsNot MyPageRight Then Return Nothing
Dim Scroll = CType(PanMainRight.Child, MyPageRight).PanScroll
If Scroll Is Nothing OrElse Scroll.Visibility <> Visibility.Visible Then Return Nothing
Return Scroll
Return CType(PanMainRight.Child, MyPageRight).PanScroll
End Function
#End Region
@@ -869,7 +869,7 @@ NextAni:
Loop
'如果当前动画组都执行完毕则删除
If Entry.Data.Count = 0 Then
If Not Entry.Data.Any() Then
'为了避免新添加的动画影响顺序,不能 RemoveAt(i)
'为了允许动画在执行中添加同名动画组,不能按名字移除
For Current = 0 To AniGroups.Count - 1
+180 -160
View File
@@ -11,12 +11,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.6.13" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.6.13." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.7.2" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.7.2." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 313 'Release
Public Const VersionCode As Integer = 321 'Release
#Else
Public Const VersionCode As Integer = 312 'Snapshot
Public Const VersionCode As Integer = 322 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -58,7 +58,7 @@ Public Module ModBase
''' <summary>
''' 程序的打开计时。
''' </summary>
Public ApplicationStartTick As Long
Public ApplicationStartTick As Long = GetTimeTick()
''' <summary>
''' 程序打开时的时间。
''' </summary>
@@ -76,6 +76,10 @@ Public Module ModBase
''' </summary>
Public Is32BitSystem As Boolean = Not Environment.Is64BitOperatingSystem
''' <summary>
''' 是否使用 GBK 编码。
''' </summary>
Public IsGBKEncoding As Boolean = Encoding.Default.CodePage = 936
''' <summary>
''' 操作系统版本。Win10 为 10.0。
''' </summary>
Public OsVersion As Version = Environment.OSVersion.Version
@@ -110,6 +114,14 @@ Public Module ModBase
''' </summary>
Public Const IconButtonDelete As String = "M520.192 0C408.43 0 317.44 82.87 313.563 186.734H52.736c-29.038 0-52.663 21.943-52.663 49.079s23.625 49.152 52.663 49.152h58.075v550.473c0 103.35 75.118 187.757 167.717 187.757h472.43c92.599 0 167.716-83.894 167.716-187.757V285.477h52.59c29.038 0 52.59-21.943 52.663-49.08-0.073-27.135-23.625-49.151-52.663-49.151H726.235C723.237 83.017 631.955 0 520.192 0zM404.846 177.957c3.803-50.03 50.176-89.015 107.447-89.015 57.197 0 103.57 38.985 106.788 89.015H404.92zM284.379 933.669c-33.353 0-69.997-39.351-69.997-95.525v-549.01H833.39v549.522c0 56.247-36.645 95.525-69.998 95.525H284.379v-0.512z M357.23 800.695a48.274 48.274 0 0 0 47.616-49.006V471.7a48.274 48.274 0 0 0-47.543-49.08 48.274 48.274 0 0 0-47.69 49.006V751.69c0 27.282 20.846 49.006 47.617 49.006z m166.62 0a48.274 48.274 0 0 0 47.688-49.006V471.7a48.274 48.274 0 0 0-47.689-49.08 48.274 48.274 0 0 0-47.543 49.006V751.69c0 27.282 21.431 49.006 47.543 49.006z m142.92 0a48.274 48.274 0 0 0 47.543-49.006V471.7a48.274 48.274 0 0 0-47.543-49.08 48.274 48.274 0 0 0-47.616 49.006V751.69c0 27.282 20.773 49.006 47.543 49.006z"
''' <summary>
''' 图标按钮,禁止,1x
''' </summary>
Public Const IconButtonStop As String = "M508 990.4c-261.6 0-474.4-212-474.4-474.4S246.4 41.6 508 41.6s474.4 212 474.4 474.4S769.6 990.4 508 990.4zM508 136.8c-209.6 0-379.2 169.6-379.2 379.2 0 209.6 169.6 379.2 379.2 379.2s379.2-169.6 379.2-379.2C887.2 306.4 717.6 136.8 508 136.8zM697.6 563.2 318.4 563.2c-26.4 0-47.2-21.6-47.2-47.2 0-26.4 21.6-47.2 47.2-47.2l379.2 0c26.4 0 47.2 21.6 47.2 47.2C744.8 542.4 724 563.2 697.6 563.2z"
''' <summary>
''' 图标按钮,勾选,1x
''' </summary>
Public Const IconButtonCheck As String = "M512 0a512 512 0 1 0 512 512A512 512 0 0 0 512 0z m0 921.6a409.6 409.6 0 1 1 409.6-409.6 409.6 409.6 0 0 1-409.6 409.6z M716.8 339.968l-256 253.44L328.192 460.8A51.2 51.2 0 0 0 256 532.992l168.448 168.96a51.2 51.2 0 0 0 72.704 0l289.28-289.792A51.2 51.2 0 0 0 716.8 339.968z"
''' <summary>
''' 图标按钮,笔,1x
''' </summary>
Public Const IconButtonEdit As String = "M732.64 64.32C688.576 21.216 613.696 21.216 569.6 64.32L120.128 499.52c-17.6 12.896-26.432 30.144-30.848 51.68L32 870.048c0 25.856 8.8 56 26.432 73.248 17.632 17.216 17.632 48.704 88.64 48.704h13.248l326.08-56c22.016-4.32 39.68-12.928 52.864-30.176l449.472-435.2c22.048-21.536 35.264-47.36 35.264-77.536 0-30.176-13.216-56-35.264-77.568l-256.096-251.2zM139.712 903.776l56-326.912 311.04-295.136 267.104 269.44-310.976 295.168-323.168 57.44zM844.576 467.84l-273.984-260.672 61.856-59.84c8.832-8.512 26.528-8.512 39.776 0l234.24 226.496c4.384 4.288 8.832 12.8 8.832 17.088s-4.416 8.544-8.864 12.8l-61.856 64.128z"
@@ -158,9 +170,13 @@ Public Module ModBase
''' </summary>
Public Const IconButtonUser As String = "M660.338 528.065c63.61-46.825 105.131-121.964 105.131-206.83 0-141.7-115.29-256.987-256.997-256.987-141.706 0-256.998 115.288-256.998 256.987 0 85.901 42.52 161.887 107.456 208.562-152.1 59.92-260.185 207.961-260.185 381.077 0 21.276 17.253 38.53 38.53 38.53 21.278 0 38.53-17.254 38.53-38.53 0-183.426 149.232-332.671 332.667-332.671 1.589 0 3.113-0.207 4.694-0.244 0.8 0.056 1.553 0.244 2.362 0.244 183.434 0 332.664 149.245 332.664 332.671 0 21.276 17.255 38.53 38.533 38.53 21.277 0 38.53-17.254 38.53-38.53 0-174.885-110.354-324.13-264.917-382.809z m-331.803-206.83c0-99.22 80.72-179.927 179.935-179.927s179.937 80.708 179.937 179.927c0 99.203-80.721 179.91-179.937 179.91s-179.935-80.708-179.935-179.91z"
''' <summary>
''' 图标按钮,微软,0.9x
''' 图标按钮,盾牌,1x
''' </summary>
Public Const IconButtonMs As String = "M0,0h5v5h-5ZM6,0h5v5h-5v-5ZM0,6h5v5h-5v-5ZM6,6h5v5h-5v-5Z"
Public Const IconButtonShield As String = "M511.488256 95.184408c35.310345 22.516742 95.184408 55.78011 167.34033 84.437781 75.738131 29.681159 148.405797 40.93953 191.392304 45.033483v353.615193c0 73.691154-50.662669 164.781609-136.123938 244.101949C649.65917 901.181409 558.568716 942.12094 512 942.12094c-46.568716 0-137.65917-40.93953-222.096952-119.748126C204.441779 742.54073 153.77911 651.450275 153.77911 577.247376v-353.103448c42.474763-4.093953 116.165917-15.352324 191.904048-45.545227 75.226387-30.192904 133.565217-63.456272 165.805098-83.414293M512 0c-4.093953 0-8.187906 1.535232-11.258371 3.582209l-14.84058 10.234882c-1.023488 0.511744-67.550225 47.592204-170.410794 88.531735-100.813593 39.916042-198.556722 41.963018-199.58021 41.963018l-25.075462 0.511744c-10.746627 0.511744-18.934533 8.187906-18.934533 18.422789v414.000999c0 216.97951 286.064968 446.24088 440.09995 446.24088s440.09995-229.261369 440.09995-445.729136V163.758121c0-10.234883-8.69965-18.422789-18.934533-18.422789l-24.563718-0.511744c-1.023488 0-98.766617-2.046977-199.58021-41.963018-103.372314-40.93953-170.410795-88.01999-170.922538-88.531734L523.258371 3.582209c-3.070465-2.558721-7.164418-3.582209-11.258371-3.582209z M743.308346 410.930535l-260.477761 260.477761c-15.864068 15.864068-41.963018 15.864068-57.827087 0l-144.823588-144.823588c-15.864068-15.864068-15.864068-41.963018 0-57.827087 8.187906-8.187906 18.422789-11.770115 29.169415-11.770115 10.234883 0 20.981509 4.093953 29.169416 11.770115l115.654173 115.654173L685.993003 352.591704c15.864068-15.864068 41.963018-15.864068 57.827087 0 15.352324 16.375812 15.352324 42.474763-0.511744 58.338831z"
''' <summary>
''' 图标按钮,离线,0.85x
''' </summary>
Public Const IconButtonOffline As String = "M533.293176 788.841412a60.235294 60.235294 0 1 1 85.202824 85.202823l-42.616471 42.586353c-129.355294 129.385412-339.124706 129.385412-468.510117 0-129.385412-129.385412-129.385412-339.124706 0-468.510117l42.586353-42.616471a60.235294 60.235294 0 1 1 85.202823 85.202824l-42.61647 42.586352a210.823529 210.823529 0 1 0 298.164706 298.164706l42.586352-42.61647z m255.548236-255.548236l42.61647-42.586352a210.823529 210.823529 0 1 0-298.164706-298.164706l-42.586352 42.61647a60.235294 60.235294 0 1 1-85.202824-85.202823l42.616471-42.586353c129.355294-129.385412 339.124706-129.385412 468.510117 0 129.385412 129.385412 129.385412 339.124706 0 468.510117l-42.586353 42.616471a60.235294 60.235294 0 1 1-85.202823-85.202824zM192.542118 192.542118a60.235294 60.235294 0 0 1 85.202823 0l553.712941 553.712941a60.235294 60.235294 0 0 1-85.202823 85.202823L192.542118 277.744941a60.235294 60.235294 0 0 1 0-85.202823z"
''' <summary>
''' 图标,音符,1x
''' </summary>
@@ -467,11 +483,11 @@ Public Module ModBase
Const Digits As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/+="
'零与负数的处理
If String.IsNullOrEmpty(Input) Then Return "0"
Dim IsNegative As Boolean = Input.StartsWith("-")
Dim IsNegative As Boolean = Input.StartsWithF("-")
If IsNegative Then Input = Input.TrimStart("-")
'转换为十进制
Dim RealNum As Long = 0, Scale As Long = 1
For Each Digit In Input.Reverse.Select(Function(l) Digits.IndexOf(l))
For Each Digit In Input.Reverse.Select(Function(l) Digits.IndexOfF(l))
RealNum += Digit * Scale
Scale *= FromRadix
Next
@@ -610,82 +626,53 @@ Public Module ModBase
End Sub
'Ini 文件
Private Class IniCache
Public FileContent As String = ""
Public KVCache As New Dictionary(Of String, String)
End Class
Private ReadOnly IniCacheList As New Dictionary(Of String, IniCache)
Private ReadOnly IniCache As New Dictionary(Of String, Dictionary(Of String, String))
''' <summary>
''' 清除某 Ini 文件的运行时缓存。
''' 清除某 ini 文件的运行时缓存。
''' </summary>
''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
Public Sub IniClearCache(FileName As String)
'还原文件路径
If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
'检索缓存
If IniCacheList.ContainsKey(FileName) Then IniCacheList.Remove(FileName)
If Not FileName.Contains(":\") Then FileName = $"{Path}PCL\{FileName}.ini"
If IniCache.ContainsKey(FileName) Then IniCache.Remove(FileName)
End Sub
''' <summary>
''' 获取 Ini 文件内容,这可能会使用到缓存。
''' 获取 ini 文件缓存。如果没有,则新读取 ini 文件内容。
''' 在文件不存在或读取失败时返回 Nothing。
''' </summary>
''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
Private Function IniGetContent(FileName As String) As IniCache
Private Function IniGetContent(FileName As String) As Dictionary(Of String, String)
Try
'还原文件路径
If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
If Not FileName.Contains(":\") Then FileName = $"{Path}PCL\{FileName}.ini"
'检索缓存
If IniCacheList.ContainsKey(FileName) Then
'返回缓存中的信息
Dim Cache As New IniCache
IniCacheList.TryGetValue(FileName, Cache)
Return Cache '防止ByRef导致缓存变更
Else
Dim Ini As IniCache
If File.Exists(FileName) Then
'返回文件信息并且记入缓存
Dim Cache As String = (vbCrLf & ReadFile(FileName) & vbCrLf).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf).Replace(vbNullChar, "")
Ini = New IniCache With {.FileContent = Cache}
Else
'返回空文件信息
Ini = New IniCache With {.FileContent = ""}
End If
If Not IniCacheList.ContainsKey(FileName) Then IniCacheList.Add(FileName, Ini) '避免多线程异步执行此方法时造成多次添加项
Return Ini
End If
If IniCache.ContainsKey(FileName) Then Return IniCache(FileName)
'读取文件
If Not File.Exists(FileName) Then Return Nothing
Dim Ini As New Dictionary(Of String, String)
For Each Line In ReadFile(FileName).Split(vbCrLf.ToArray(), StringSplitOptions.RemoveEmptyEntries)
Dim Index As Integer = Line.IndexOfF(":")
If Index > 0 Then Ini(Line.Substring(0, Index)) = Line.Substring(Index + 1) '可能会有重复键,见 #3616
Next
IniCache(FileName) = Ini
Return Ini
Catch ex As Exception
Log(ex, "读取文件失败:" & FileName, LogLevel.Hint)
Return New IniCache With {.FileContent = ""}
Log(ex, $"生成 ini 文件缓存失败({FileName})", LogLevel.Hint)
Return Nothing
End Try
End Function
''' <summary>
''' 读取Ini文件,这可能会使用到缓存。
''' 读取 ini 文件。这可能会使用到缓存。
''' </summary>
''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
''' <param name="Key">键。</param>
''' <param name="DefaultValue">没有找到键时返回的默认值。</param>
Public Function ReadIni(FileName As String, Key As String, Optional DefaultValue As String = "") As String
Try
'获取目前文件
Dim NowIni As IniCache = IniGetContent(FileName)
If IsNothing(NowIni) Then Return DefaultValue
'使用缓存
If NowIni.KVCache.ContainsKey(Key) Then Return If(NowIni.KVCache(Key), DefaultValue)
'没有缓存,读取文件
If NowIni.FileContent.Contains(vbCrLf & Key & ":") Then
Dim Ret As String = Mid(NowIni.FileContent, NowIni.FileContent.IndexOf(vbCrLf & Key & ":") + 3)
Ret = If(Ret.Contains(vbCrLf), Mid(Ret, 1, Ret.IndexOf(vbCrLf)), Ret).Replace(Key & ":", "")
NowIni.KVCache.Add(Key, If(Ret = vbLf, "", Ret))
Return If(Ret = vbLf, "", Ret)
Else
Return DefaultValue
End If
Catch ex As Exception
'读取失败
Return DefaultValue
End Try
Dim Content = IniGetContent(FileName)
If Content Is Nothing OrElse Not Content.ContainsKey(Key) Then Return DefaultValue
Return Content(Key)
End Function
''' <summary>
''' 写入ini文件,这会更新缓存。
''' 写入 ini 文件,这会更新缓存。
''' </summary>
''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
''' <param name="Key">键。</param>
@@ -693,47 +680,41 @@ Public Module ModBase
''' <remarks></remarks>
Public Sub WriteIni(FileName As String, Key As String, Value As String)
Try
'还原文件路径
If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
If IsNothing(Value) Then Value = ""
Value = Value.Replace(vbCrLf, "")
'创建文件夹
If Not Directory.Exists(GetPathFromFullPath(FileName)) Then Directory.CreateDirectory(GetPathFromFullPath(FileName))
'预处理
Key = Key.Replace(vbCr, "").Replace(vbLf, "").Replace(":", "")
Value = Value.Replace(vbCr, "").Replace(vbLf, "") '允许 Value 中包含冒号
'获取目前文件
Dim NowFile As String = IniGetContent(FileName).FileContent
If Not NowFile.EndsWith(vbCrLf) Then NowFile += vbCrLf
'如果值一样就不处理
If NowFile.Contains(vbCrLf & Key & ":" & Value & vbCrLf) Then Exit Sub
'处理文件
Dim FindResult As String = ReadIni(FileName, Key)
If FindResult = "" AndAlso Not NowFile.Contains(vbCrLf & Key & ":") Then
'不存在这个键
NowFile = NowFile & vbCrLf & Key & ":" & Value & vbCrLf
Else
'存在这个键
NowFile = NowFile.Replace(vbCrLf & Key & ":" & FindResult & vbCrLf, vbCrLf & Key & ":" & Value & vbCrLf)
End If
WriteFile(FileName, NowFile)
'刷新目前缓存
IniCacheList(FileName).FileContent = NowFile
IniCacheList(FileName).KVCache.Remove(Key)
IniCacheList(FileName).KVCache.Add(Key, Value)
Dim Content As Dictionary(Of String, String) = IniGetContent(FileName)
If Content Is Nothing Then Content = New Dictionary(Of String, String)
If Content.ContainsKey(Key) AndAlso Content(Key) = Value Then Exit Sub '如果值一样就不处理
'更新缓存
Content(Key) = Value
'写入文件
Dim FileContent As New StringBuilder
For Each Pair In Content
FileContent.Append(Pair.Key)
FileContent.Append(":")
FileContent.Append(Pair.Value)
FileContent.Append(vbCrLf)
Next
If Not FileName.Contains(":\") Then FileName = $"{Path}PCL\{FileName}.ini"
WriteFile(FileName, FileContent.ToString)
Catch ex As Exception
Log(ex, "写入文件失败:" & FileName & "/" & Key & ": " & Value)
Log(ex, $"写入文件失败({FileName} -> {Key}:{Value})")
End Try
End Sub
'路径处理
''' <summary>
''' 从文件路径或者 Url 获取不包含文件名的路径,或获取文件夹的父文件夹路径。不包含路径将会抛出异常。
''' 从文件路径或者 Url 获取不包含文件名的路径,或获取文件夹的父文件夹路径。
''' 取决于原路径格式,路径以 / 或 \ 结尾。
''' 不包含路径将会抛出异常。
''' </summary>
Public Function GetPathFromFullPath(FilePath As String) As String
If Not (FilePath.Contains("\") OrElse FilePath.Contains("/")) Then Throw New Exception("不包含路径:" & FilePath)
If FilePath.EndsWith("\") OrElse FilePath.EndsWith("/") Then
If FilePath.EndsWithF("\") OrElse FilePath.EndsWithF("/") Then
'是文件夹路径
Dim IsRight As Boolean = FilePath.EndsWith("\")
Dim IsRight As Boolean = FilePath.EndsWithF("\")
FilePath = Left(FilePath, Len(FilePath) - 1)
GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"})) & If(IsRight, "\", "/")
If GetPathFromFullPath = "" Then Throw New Exception("不包含路径:" & FilePath)
@@ -748,11 +729,13 @@ Public Module ModBase
''' </summary>
Public Function GetFileNameFromPath(FilePath As String) As String
FilePath = FilePath.Replace("/", "\")
If FilePath.EndsWith("\") Then Throw New Exception("不包含文件名:" & FilePath)
Dim FileName As String = FilePath.Split("\").Last.Split("?").First '去掉网络参数后的 ?
If FileName.Length = 0 Then Throw New Exception("不包含文件名:" & FilePath)
If FileName.Length > 250 Then Throw New PathTooLongException("文件名过长:" & FilePath)
Return FileName
If FilePath.EndsWithF("\") Then Throw New Exception("不包含文件名:" & FilePath)
If FilePath.Contains("?") Then FilePath = FilePath.Substring(0, FilePath.IndexOfF("?")) '去掉网络参数后的 ?
If FilePath.Contains("\") Then FilePath = FilePath.Substring(FilePath.LastIndexOfF("\") + 1)
Dim length As Integer = FilePath.Length
If length = 0 Then Throw New Exception("不包含文件名:" & FilePath)
If length > 250 Then Throw New PathTooLongException("文件名过长:" & FilePath)
Return FilePath
End Function
''' <summary>
''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。
@@ -760,7 +743,7 @@ Public Module ModBase
Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String
Dim Name As String = GetFileNameFromPath(FilePath)
If Name.Contains(".") Then
Return Name.Substring(0, Name.LastIndexOf("."))
Return Name.Substring(0, Name.LastIndexOfF("."))
Else
Return Name
End If
@@ -769,8 +752,8 @@ Public Module ModBase
''' 从文件夹路径获取文件夹名。
''' </summary>
Public Function GetFolderNameFromPath(FolderPath As String) As String
If FolderPath.EndsWith(":\") OrElse FolderPath.EndsWith(":\\") Then Return FolderPath.Substring(0, 1)
If FolderPath.EndsWith("\") OrElse FolderPath.EndsWith("/") Then FolderPath = Left(FolderPath, FolderPath.Length - 1)
If FolderPath.EndsWithF(":\") OrElse FolderPath.EndsWithF(":\\") Then Return FolderPath.Substring(0, 1)
If FolderPath.EndsWithF("\") OrElse FolderPath.EndsWithF("/") Then FolderPath = Left(FolderPath, FolderPath.Length - 1)
Return GetFileNameFromPath(FolderPath)
End Function
@@ -1023,7 +1006,7 @@ Public Module ModBase
Public Function SelectFolder(Optional Title As String = "选择文件夹") As String
Dim folderDialog As New Ookii.Dialogs.Wpf.VistaFolderBrowserDialog With {.ShowNewFolderButton = True, .RootFolder = Environment.SpecialFolder.Desktop, .Description = Title, .UseDescriptionForTitle = True}
folderDialog.ShowDialog()
SelectFolder = If(String.IsNullOrEmpty(folderDialog.SelectedPath), "", folderDialog.SelectedPath & If(folderDialog.SelectedPath.EndsWith("\"), "", "\"))
SelectFolder = If(String.IsNullOrEmpty(folderDialog.SelectedPath), "", folderDialog.SelectedPath & If(folderDialog.SelectedPath.EndsWithF("\"), "", "\"))
Log("[UI] 选择文件夹返回:" & SelectFolder)
End Function
@@ -1034,8 +1017,8 @@ Public Module ModBase
Public Function CheckPermission(Path As String) As Boolean
Try
If Path = "" Then Return False
If Not Path.EndsWith("\") Then Path += "\"
If Path.EndsWith(":\System Volume Information\") OrElse Path.EndsWith(":\$RECYCLE.BIN\") Then Return False
If Not Path.EndsWithF("\") Then Path += "\"
If Path.EndsWithF(":\System Volume Information\") OrElse Path.EndsWithF(":\$RECYCLE.BIN\") Then Return False
If Not Directory.Exists(Path) Then Return False
Dim FileName As String = "CheckPermission" & GetUuid()
If File.Exists(Path & FileName) Then File.Delete(Path & FileName)
@@ -1052,7 +1035,7 @@ Public Module ModBase
''' </summary>
Public Sub CheckPermissionWithException(Path As String)
If String.IsNullOrWhiteSpace(Path) Then Throw New ArgumentNullException("文件夹名不能为空!")
If Not Path.EndsWith("\") Then Path += "\"
If Not Path.EndsWithF("\") Then Path += "\"
If Not Directory.Exists(Path) Then Throw New DirectoryNotFoundException("文件夹不存在!")
If File.Exists(Path & "CheckPermission") Then File.Delete(Path & "CheckPermission")
File.Create(Path & "CheckPermission").Dispose()
@@ -1236,43 +1219,35 @@ Re:
''' <summary>
''' 尝试根据后缀名判断文件种类并解压文件,支持 gz 与 zip,会尝试将 jar 以 zip 方式解压。
''' 会尝试创建,但不会清空目标文件夹。
''' 成功返回 True,并非压缩文件或失败返回 False。
''' </summary>
Public Function ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing) As Boolean
Try
Directory.CreateDirectory(DestDirectory)
If CompressFilePath.EndsWith(".gz") Then
'以 gz 方式解压
Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress)
Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write)
Dim data As Integer = stream.ReadByte()
While data <> -1
decompressedFile.WriteByte(data)
data = stream.ReadByte()
End While
decompressedFile.Close()
stream.Close()
Return True
Else
'以 zip 方式解压
Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030")))
For Each Entry As ZipArchiveEntry In Archive.Entries
Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName)
If DestinationPath.EndsWith("\") OrElse DestinationPath.EndsWith("/") Then
Continue For '不创建空文件夹
Else
Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
Entry.ExtractToFile(DestinationPath, True)
End If
Next
End Using
Return True
End If
Catch ex As Exception
Log(ex, "尝试解压文件失败")
Return False
End Try
End Function
Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing)
Directory.CreateDirectory(DestDirectory)
If CompressFilePath.EndsWithF(".gz", True) Then
'以 gz 方式解压
Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress)
Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write)
Dim data As Integer = stream.ReadByte()
While data <> -1
decompressedFile.WriteByte(data)
data = stream.ReadByte()
End While
decompressedFile.Close()
stream.Close()
Else
'以 zip 方式解压
Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030")))
For Each Entry As ZipArchiveEntry In Archive.Entries
Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName)
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then
Continue For '不创建空文件夹
Else
Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
Entry.ExtractToFile(DestinationPath, True)
End If
Next
End Using
End If
End Sub
''' <summary>
''' 删除文件夹,返回删除的文件个数。通过参数选择是否抛出异常。
@@ -1314,9 +1289,9 @@ Re:
''' </summary>
Public Sub CopyDirectory(FromPath As String, ToPath As String)
FromPath = FromPath.Replace("/", "\")
If Not FromPath.EndsWith("\") Then FromPath &= "\"
If Not FromPath.EndsWithF("\") Then FromPath &= "\"
ToPath = ToPath.Replace("/", "\")
If Not ToPath.EndsWith("\") Then ToPath &= "\"
If Not ToPath.EndsWithF("\") Then ToPath &= "\"
For Each File In EnumerateFiles(FromPath)
CopyFile(File.FullName, File.FullName.Replace(FromPath, ToPath))
Next
@@ -1363,7 +1338,7 @@ Re:
Loop
DescList = DescList.Distinct.ToList
Dim Desc As String = Join(DescList, vbCrLf & "→ ")
Dim Stack As String = If(StackList.Count > 0, vbCrLf & Join(StackList, vbCrLf), "")
Dim Stack As String = If(StackList.Any, vbCrLf & Join(StackList, vbCrLf), "")
'常见错误(记得同时修改下面的)
Dim CommonReason As String = Nothing
@@ -1562,6 +1537,48 @@ Re:
Next
Return tmp.ToString()
End Function
''' <summary>
''' 检查字符串中的字符是否均为 ASCII 字符。
''' </summary>
<Extension> Public Function IsASCII(Input As String) As Boolean
Return Input.All(Function(c) AscW(c) < 128)
End Function
''' <summary>
''' 高速的 StartsWith。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function StartsWithF(Str As String, Prefix As String, Optional IgnoreCase As Boolean = False) As Boolean
Return Str.StartsWith(Prefix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 高速的 EndsWith。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function EndsWithF(Str As String, Suffix As String, Optional IgnoreCase As Boolean = False) As Boolean
Return Str.EndsWith(Suffix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 支持可变大小写判断的 Contains。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function ContainsF(Str As String, SubStr As String, Optional IgnoreCase As Boolean = False) As Boolean
Return Str.IndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) >= 0
End Function
''' <summary>
''' 高速的 IndexOf。
''' </summary>
<Extension> <MethodImpl(MethodImplOptions.AggressiveInlining)>
Public Function IndexOfF(Str As String, SubStr As String, Optional IgnoreCase As Boolean = False) As Integer
Return Str.IndexOf(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, Optional IgnoreCase As Boolean = False) As Integer
Return Str.LastIndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal))
End Function
''' <summary>
''' 输入 And 字符不会报错的 Val。
@@ -1645,14 +1662,14 @@ Re:
Source = Source.ToLower.Replace(" ", "")
Query = Query.ToLower.Replace(" ", "")
Dim sourceLength As Integer = Source.Length, queryLength As Integer = Query.Length '用于计算最后因数的长度缓存
Do While qp < Query.Length
Do While qp < queryLength
'对 qp 作为开始位置计算
Dim sp As Integer = 0, lenMax As Integer = 0, spMax As Integer = 0
'查找以 qp 为头的最大子串
Do While sp < Source.Length
'对每个 sp 作为开始位置计算最大子串
Dim len As Integer = 0
Do While (qp + len) < Query.Length AndAlso (sp + len) < Source.Length AndAlso Source(sp + len) = Query(qp + len)
Do While (qp + len) < queryLength AndAlso (sp + len) < Source.Length AndAlso Source(sp + len) = Query(qp + len)
len += 1
Loop
'存储 len
@@ -1667,7 +1684,7 @@ Re:
Source = Source.Substring(0, spMax) & If(Source.Count > spMax + lenMax, Source.Substring(spMax + lenMax), String.Empty) '将源中的对应字段替换空
'存储 lenSum
Dim IncWeight = (Math.Pow(1.4, 3 + lenMax) - 3.6) '根据长度加成
IncWeight *= (1 + 0.3 * Math.Max(0, 3 - Math.Abs(qp - spMax))) '根据位置加成
IncWeight *= 1 + 0.3 * Math.Max(0, 3 - Math.Abs(qp - spMax)) '根据位置加成
lenSum += IncWeight
End If
'根据结果增加 qp
@@ -1717,23 +1734,24 @@ Re:
Public Function Search(Of T)(Entries As List(Of SearchEntry(Of T)), Query As String, Optional MaxBlurCount As Integer = 5, Optional MinBlurSimilarity As Double = 0.1) As List(Of SearchEntry(Of T))
'初始化
Dim ResultList As New List(Of SearchEntry(Of T))
If Entries.Count = 0 Then Return ResultList
If Not Entries.Any() Then Return ResultList
'进行搜索,获取相似信息
For Each Entry In Entries
Entry.Similarity = SearchSimilarityWeighted(Entry.SearchSource, Query)
Entry.AbsoluteRight = False
For Each Pair In Entry.SearchSource
If Pair.Key.ToLower.Replace(" ", "").Contains(Query.ToLower.Replace(" ", "")) Then Entry.AbsoluteRight = True
If Pair.Key.Replace(" ", "").ContainsF(Query.Replace(" ", ""), True) Then Entry.AbsoluteRight = True
Next
Next
'按照相似度进行排序
Entries = Sort(Entries, Function(Left As SearchEntry(Of T), Right As SearchEntry(Of T)) As Boolean
If Left.AbsoluteRight Xor Right.AbsoluteRight Then
Return Left.AbsoluteRight
Else
Return Left.Similarity > Right.Similarity
End If
End Function)
Entries = Sort(Entries,
Function(Left, Right) As Boolean
If Left.AbsoluteRight Xor Right.AbsoluteRight Then
Return Left.AbsoluteRight
Else
Return Left.Similarity > Right.Similarity
End If
End Function)
'返回结果
Dim BlurCount As Integer = 0
For Each Entry In Entries
@@ -1980,9 +1998,10 @@ NextElement:
Log("[System] 执行外部命令并等待返回结果:" & FileName & " " & Arguments)
Using Program As New Process() With {.StartInfo = Info}
Program.Start()
Dim Result As String = Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd
Program.WaitForExit(Timeout)
If Not Program.HasExited Then Program.Kill()
Return Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd
Return Result
End Using
End Function
@@ -2056,7 +2075,7 @@ NextElement:
''' <param name="SortRule">传入两个对象,若第一个对象应该排在前面,则返回 True。</param>
Public Function Sort(Of T)(List As IList(Of T), SortRule As CompareThreadStart(Of T)) As List(Of T)
Dim NewList As New List(Of T)
While List.Count > 0
While List.Any
Dim Highest = List(0)
For i = 1 To List.Count - 1
If SortRule(List(i), Highest) Then Highest = List(i)
@@ -2084,7 +2103,7 @@ NextElement:
Dim AllArguments() As String = Command.Split(" ")
For i = 0 To AllArguments.Length - 1
If AllArguments(i) = "-" & Name Then
If AllArguments.Length = i + 1 OrElse AllArguments(i + 1).StartsWith("-") Then Return True
If AllArguments.Length = i + 1 OrElse AllArguments(i + 1).StartsWithF("-") Then Return True
Return AllArguments(i + 1)
End If
Next
@@ -2111,6 +2130,7 @@ NextElement:
''' </summary>
Public Sub OpenWebsite(Url As String)
Try
If Not Url.StartsWithF("http", True) Then Throw New Exception(Url & " 不是一个有效的网址,它必须以 http 开头!")
Log("[System] 正在打开网页:" & Url)
Process.Start(Url)
Catch ex As Exception
@@ -2628,7 +2648,7 @@ Retry:
''' </summary>
Public Function Shuffle(Of T)(array As IList(Of T)) As IList(Of T)
Shuffle = New List(Of T)
Do While array.Count > 0
Do While array.Any
Dim i As Integer = RandomInteger(0, array.Count - 1)
Shuffle.Add(array(i))
array.RemoveAt(i)
@@ -490,7 +490,7 @@
Select Case Loader.State
Case LoadState.Finished
'检查是否需要重启
If Loader.GetType.Name.StartsWith("LoaderTask") Then '类型名后面带有泛型,必须用 StartsWith
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
If ModeDebug Then Log("[Loader] 由于输入条件变更,重启已完成的加载器 " & Loader.Name)
GoTo Restart
@@ -500,7 +500,7 @@
End If
Case LoadState.Loading
'检查是否需要重启
If Loader.GetType.Name.StartsWith("LoaderTask") Then
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
If ModeDebug Then Log("[Loader] 由于输入条件变更,重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
GoTo Restart
@@ -517,9 +517,9 @@ Restart:
If Input IsNot Nothing Then
'若输入类型与下一个加载器相同才继续
Dim LoaderType As String = Loader.GetType.Name
If LoaderType.StartsWith("LoaderTask") OrElse LoaderType.StartsWith("LoaderCombo") Then
If LoaderType.StartsWithF("LoaderTask") OrElse LoaderType.StartsWithF("LoaderCombo") Then
Loader.Start(If(Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IsForceRestarting)
ElseIf LoaderType.StartsWith("LoaderDownload") Then
ElseIf LoaderType.StartsWithF("LoaderDownload") Then
Loader.Start(If(TypeOf Input Is List(Of NetFile), Input, Nothing), IsForceRestarting)
Else
Throw New Exception("未知的加载器类型(" & LoaderType & ")")
@@ -545,7 +545,7 @@ Restart:
Public Shared Sub GetLoaderList(Loader As Object, ByRef List As List(Of LoaderBase), Optional RequireShow As Boolean = True)
For Each SubLoader In Loader.Loaders
If SubLoader.Show OrElse Not RequireShow Then List.Add(SubLoader)
If SubLoader.GetType.Name.StartsWith("LoaderCombo") Then GetLoaderList(SubLoader, List)
If SubLoader.GetType.Name.StartsWithF("LoaderCombo") Then GetLoaderList(SubLoader, List)
Next
End Sub
''' <summary>
@@ -571,7 +571,7 @@ Restart:
Public LoaderTaskbarProgress As Double = 0 '平滑后的进度
Private LoaderTaskbarProgressLast As Shell.TaskbarItemProgressState = Shell.TaskbarItemProgressState.None
Public Sub LoaderTaskbarAdd(Loader As LoaderBase)
Public Sub LoaderTaskbarAdd(Of T)(Loader As LoaderCombo(Of T))
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRemove(Loader)
SyncLock LoaderTaskbarLock
LoaderTaskbar.Add(Loader)
@@ -587,11 +587,11 @@ Restart:
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar
If Loader.Show AndAlso Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成,则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If (IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting) AndAlso Task.Show Then
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
@@ -606,7 +606,7 @@ Restart:
End If
RunInUi(Sub() FrmMain.BtnExtraDownload.Progress = LoaderTaskbarProgress)
'更新任务栏信息
If LoaderTaskbar.Count = 0 OrElse LoaderTaskbarProgress = 1 Then
If Not LoaderTaskbar.Any() OrElse LoaderTaskbarProgress = 1 Then
NewState = Shell.TaskbarItemProgressState.None
ElseIf LoaderTaskbarProgress < 0.015 Then
NewState = Shell.TaskbarItemProgressState.Indeterminate
@@ -628,7 +628,6 @@ Restart:
Dim Total As Double = 0, Count As Integer = 0
SyncLock LoaderTaskbarLock
For Each Task In LoaderTaskbar.ToList
If Not Task.Show Then Continue For
Total += Task.Progress
Count += 1 '避免多线程影响导致计数出错
Next
File diff suppressed because it is too large. Load diff
@@ -76,7 +76,7 @@ Public Class ValidateHttp
Public Sub New()
End Sub '用于 XAML 初始化
Public Overrides Function Validate(Str As String) As String
If Str.EndsWith("/") Then Str = Str.Substring(0, Str.Length - 1)
If Str.EndsWithF("/") Then Str = Str.Substring(0, Str.Length - 1)
If Not RegexCheck(Str, "^(http[s]?)\://") Then Return "输入的网址无效!"
Return ""
End Function
@@ -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.IndexOf(Ch, StringComparison.OrdinalIgnoreCase) >= 0 Then
If Str.IndexOfF(Ch, StringComparison.OrdinalIgnoreCase) >= 0 Then
If IsNothing(ErrorMessage) Then ErrorMessage = ""
Return ErrorMessage.Replace("%", Ch)
End If
@@ -220,13 +220,13 @@ Public Class ValidateFolderName
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
If Not LengthCheck = "" Then Return LengthCheck
'检查空格
If Str.StartsWith(" ") Then Return "文件夹名不能以空格开头!"
If Str.EndsWith(" ") Then Return "文件夹名不能以空格结尾!"
If Str.StartsWithF(" ") Then Return "文件夹名不能以空格开头!"
If Str.EndsWithF(" ") Then Return "文件夹名不能以空格结尾!"
'检查长度
LengthCheck = New ValidateLength(1, 100).Validate(Str)
If Not LengthCheck = "" Then Return LengthCheck
'检查尾部小数点
If Str.EndsWith(".") Then Return "文件夹名不能以小数点结尾!"
If Str.EndsWithF(".") Then Return "文件夹名不能以小数点结尾!"
'检查特殊字符
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "文件夹名不可包含 % 字符!").Validate(Str)
If Not CharactCheck = "" Then Return CharactCheck
@@ -273,13 +273,13 @@ Public Class ValidateFileName
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
If Not LengthCheck = "" Then Return LengthCheck
'检查空格
If Str.StartsWith(" ") Then Return "文件名不能以空格开头!"
If Str.EndsWith(" ") Then Return "文件名不能以空格结尾!"
If Str.StartsWithF(" ") Then Return "文件名不能以空格开头!"
If Str.EndsWithF(" ") Then Return "文件名不能以空格结尾!"
'检查长度
LengthCheck = New ValidateLength(1, 253).Validate(Str & If(ParentFolder, ""))
If Not LengthCheck = "" Then Return LengthCheck
'检查尾部小数点
If Str.EndsWith(".") Then Return "文件名不能以小数点结尾!"
If Str.EndsWithF(".") Then Return "文件名不能以小数点结尾!"
'检查特殊字符
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "文件名不可包含 % 字符!").Validate(Str)
If Not CharactCheck = "" Then Return CharactCheck
@@ -319,7 +319,7 @@ Public Class ValidateFolderPath
Public Overrides Function Validate(Str As String) As String
'去除尾部斜线,统一为 \
Str = Str.Replace("/", "\")
If Not Str.TrimEnd("\").EndsWith(":") Then Str = Str.TrimEnd("\")
If Not Str.TrimEnd("\").EndsWithF(":") Then Str = Str.TrimEnd("\")
'检查是否为空
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
If Not LengthCheck = "" Then Return LengthCheck
@@ -327,15 +327,15 @@ Public Class ValidateFolderPath
LengthCheck = New ValidateLength(1, 254).Validate(Str)
If Not LengthCheck = "" Then Return LengthCheck
'检查开头
If Str.StartsWith("\\Mac\") Then GoTo Fin
If Str.StartsWithF("\\Mac\") Then GoTo Fin
For Each Drive As DriveInfo In My.Computer.FileSystem.Drives
If Str.ToUpper = Drive.Name Then Return ""
If Str.ToUpper.StartsWith(Drive.Name) Then GoTo Fin
If Str.StartsWithF(Drive.Name, True) Then GoTo Fin
Next
Return "文件夹路径头存在错误!"
Fin:
'对首层以外的路径检查
For i = If(Str.StartsWith("\\Mac\"), 2, 1) To Str.Split("\").Count - 1
For i = If(Str.StartsWithF("\\Mac\"), 2, 1) To Str.Split("\").Count - 1
Dim SubStr As String = Str.Split("\")(i)
'检查是否为空
Dim SubLengthCheck As String = New ValidateNullOrWhiteSpace().Validate(SubStr)
@@ -344,10 +344,10 @@ Fin:
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "路径中存在无效字符!").Validate(SubStr)
If Not CharactCheck = "" Then Return CharactCheck
'检查头部空格
If SubStr.StartsWith(" ") Then Return "文件夹名不能以空格开头!"
If SubStr.EndsWith(" ") Then Return "文件夹名不能以空格结尾!"
If SubStr.StartsWithF(" ") Then Return "文件夹名不能以空格开头!"
If SubStr.EndsWithF(" ") Then Return "文件夹名不能以空格结尾!"
'检查尾部小数点
If SubStr.EndsWith(".") Then Return "文件夹名不能以小数点结尾!"
If SubStr.EndsWithF(".") Then Return "文件夹名不能以小数点结尾!"
'检查特殊字符串
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
@@ -55,7 +55,7 @@ Public Class MyBitmap
Public Sub New(FilePathOrResourceName As String)
Try
FilePathOrResourceName = FilePathOrResourceName.Replace("pack://application:,,,/images/", PathImage)
If FilePathOrResourceName.StartsWith(PathImage) Then
If FilePathOrResourceName.StartsWithF(PathImage) Then
'使用缓存
If BitmapCache.ContainsKey(FilePathOrResourceName) Then
Pic = BitmapCache(FilePathOrResourceName).Pic
@@ -18,6 +18,7 @@
'https://docs.curseforge.com/?http#tocS_ModLoaderType
Any = 0
Forge = 1
LiteLoader = 3
Fabric = 4
Quilt = 5
NeoForge = 6
@@ -43,10 +44,10 @@
For Each EntryData As String In Line.Split("¨")
Dim Entry = New CompDatabaseEntry
Dim SplitedLine = EntryData.Split("|")
If SplitedLine(0).StartsWith("@") Then
If SplitedLine(0).StartsWithF("@") Then
Entry.CurseForgeSlug = Nothing
Entry.ModrinthSlug = SplitedLine(0).Replace("@", "")
ElseIf SplitedLine(0).EndsWith("@") Then
ElseIf SplitedLine(0).EndsWithF("@") Then
Entry.CurseForgeSlug = SplitedLine(0).TrimEnd("@")
Entry.ModrinthSlug = Entry.CurseForgeSlug
ElseIf SplitedLine(0).Contains("@") Then
@@ -59,7 +60,6 @@
Entry.WikiId = i
If SplitedLine.Count >= 2 Then
Entry.ChineseName = SplitedLine(1)
Entry.MCBBS = If(SplitedLine.Count >= 3, SplitedLine(2), Nothing)
If Entry.ChineseName.Contains("*") Then '处理 *
Entry.ChineseName = Entry.ChineseName.Replace("*", " (" &
String.Join(" ", If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Split("-").Select(Function(w) w.Substring(0, 1).ToUpper & w.Substring(1, w.Length - 1))) & ")")
@@ -82,10 +82,6 @@
''' </summary>
Public ChineseName As String = ""
''' <summary>
''' MCBBS 发布帖编号(例如 195107)。若为 Nothing 则没有发布帖。
''' </summary>
Public MCBBS As Integer?
''' <summary>
''' CurseForge Slug(例如 advanced-solar-panels)。
''' </summary>
Public CurseForgeSlug As String = Nothing
@@ -95,7 +91,7 @@
Public ModrinthSlug As String = Nothing
Public Overrides Function ToString() As String
Return If(CurseForgeSlug, "") & "&" & If(ModrinthSlug, "") & "|" & WikiId & "|" & ChineseName & If(MCBBS Is Nothing, "", "|" & MCBBS)
Return If(CurseForgeSlug, "") & "&" & If(ModrinthSlug, "") & "|" & WikiId & "|" & ChineseName
End Function
End Class
@@ -200,14 +196,6 @@
End Get
End Property
''' <summary>
''' MCBBS 的帖子 ID。若为 0 则没有。
''' </summary>
Public ReadOnly Property MCBBS As Integer
Get
Return If(DatabaseEntry Is Nothing, 0, If(DatabaseEntry.MCBBS, 0))
End Get
End Property
''' <summary>
''' 翻译后的中文名。若数据库没有则等同于 RawName。
''' </summary>
Public ReadOnly Property TranslatedName As String
@@ -260,12 +248,26 @@
LastUpdate = Data("dateReleased") '#1194
DownloadCount = Data("downloadCount")
If Data("logo").Count > 0 Then LogoUrl = Data("logo")("thumbnailUrl")
'FileIndexes / GameVersions
Dim Files = If(CType(Data("latestFilesIndexes"), JArray), New JArray).
Where(Function(i) i("gameVersion").ToString.Contains("1."))
CurseForgeFileIds = Files.Select(Of Integer)(Function(v) v("fileId")).Distinct.ToList
GameVersions = Files.Select(Of Integer)(Function(v) Val(v("gameVersion").ToString.Split(".")(1).Split("-").First)).Where(Function(v) v > 0).
Distinct.OrderByDescending(Function(v) v).ToList
'FileIndexes / GameVersions / ModLoaders
ModLoaders = New List(Of CompModLoaderType)
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 As New CompFile(File, Type)
If Not NewFile.Available Then Continue For
ModLoaders.AddRange(NewFile.ModLoaders)
Dim GameVersions = File("gameVersions").ToObject(Of List(Of String))
If Not GameVersions.Any(Function(v) v.StartsWithF("1.")) Then Continue For
Files.Add(New KeyValuePair(Of Integer, List(Of String))(File("id"), GameVersions))
Next
For Each File In If(Data("latestFilesIndexes"), New JArray) '这俩玩意儿包含的文件不一样,见 #3599
If Not File("gameVersion").ToString.StartsWithF("1.") Then Continue For
Files.Add(New KeyValuePair(Of Integer, List(Of String))(File("fileId"), {File("gameVersion").ToString}.ToList))
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).
Distinct.OrderByDescending(Function(v) v).ToList
ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
'Type
If Website.Contains("/mc-mods/") OrElse Website.Contains("/mod/") Then
Type = CompType.Mod
@@ -322,15 +324,7 @@
'FUTURE: Res
End Select
Next
If Tags.Count = 0 Then Tags.Add("杂项")
'ModLoaders
ModLoaders = New List(Of CompModLoaderType)
For Each File In If(Data("latestFiles"), {})
Dim NewFile As New CompFile(File, Type)
If Not NewFile.Available Then Continue For
ModLoaders.AddRange(NewFile.ModLoaders)
Next
ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
If Not Tags.Any() Then Tags.Add("杂项")
#End Region
Else
#Region "Modrinth"
@@ -347,7 +341,7 @@
'GameVersions
'搜索结果的键为 versions,获取特定工程的键为 game_versions
GameVersions = If(CType(If(Data("game_versions"), Data("versions")), JArray), New JArray).
Select(Function(v) v.ToString).Where(Function(v) v.StartsWith("1.")).
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).
Distinct.OrderByDescending(Function(v) v).ToList
'Type
@@ -396,7 +390,7 @@
'FUTURE: Res
End Select
Next
If Tags.Count = 0 Then Tags.Add("杂项")
If Not Tags.Any() Then Tags.Add("杂项")
Tags.Sort()
ModLoaders.Sort()
#End Region
@@ -420,10 +414,10 @@
Json("Website") = Website
If LastUpdate IsNot Nothing Then Json("LastUpdate") = LastUpdate
Json("DownloadCount") = DownloadCount
If ModLoaders IsNot Nothing AndAlso ModLoaders.Count > 0 Then Json("ModLoaders") = New JArray(ModLoaders.Select(Function(m) CInt(m)))
If ModLoaders IsNot Nothing AndAlso ModLoaders.Any Then Json("ModLoaders") = New JArray(ModLoaders.Select(Function(m) CInt(m)))
Json("Tags") = New JArray(Tags)
If LogoUrl IsNot Nothing Then Json("LogoUrl") = LogoUrl
If GameVersions.Count > 0 Then Json("GameVersions") = New JArray(GameVersions)
If GameVersions.Any Then Json("GameVersions") = New JArray(GameVersions)
Json("CacheTime") = Date.Now '用于检查缓存时间
Return Json
End Function
@@ -575,7 +569,7 @@
End If
Next
'根据分类后的结果处理
If NormalNameList.Count = 0 OrElse SubtitleList.Count = 0 Then GoTo NoSubtitle
If Not NormalNameList.Any() OrElse Not SubtitleList.Any() Then GoTo NoSubtitle
'同时包含 NormalName 和 Subtitle
Title = NormalNameList.Join(" - ")
Else
@@ -602,7 +596,7 @@
SubtitleList = SubtitleList.Distinct().ToList()
'设置标题与描述
Dim Subtitle As String = ""
If SubtitleList.Count > 0 Then
If SubtitleList.Any Then
For Each Ex In SubtitleList
Dim IsModLoaderDescription As Boolean =
Ex.ToLower.Contains("forge") OrElse Ex.ToLower.Contains("fabric") OrElse Ex.ToLower.Contains("quilt")
@@ -696,8 +690,8 @@ NoSubtitle:
''' </summary>
Public ReadOnly Property CanContinue As Boolean
Get
If Tag.StartsWith("/") OrElse Not Source.HasFlag(CompSourceType.CurseForge) Then Storage.CurseForgeTotal = 0
If Tag.EndsWith("/") OrElse Not Source.HasFlag(CompSourceType.Modrinth) Then Storage.ModrinthTotal = 0
If Tag.StartsWithF("/") OrElse Not Source.HasFlag(CompSourceType.CurseForge) Then Storage.CurseForgeTotal = 0
If Tag.EndsWithF("/") OrElse Not Source.HasFlag(CompSourceType.Modrinth) Then Storage.ModrinthTotal = 0
If Storage.CurseForgeTotal = -1 OrElse Storage.ModrinthTotal = -1 Then Return True
Return Storage.CurseForgeOffset < Storage.CurseForgeTotal OrElse Storage.ModrinthOffset < Storage.ModrinthTotal
End Get
@@ -745,7 +739,7 @@ NoSubtitle:
''' </summary>
Public Function GetCurseForgeAddress() As String
If Not Source.HasFlag(CompSourceType.CurseForge) Then Return Nothing
If Tag.StartsWith("/") Then Storage.CurseForgeTotal = 0
If Tag.StartsWithF("/") Then Storage.CurseForgeTotal = 0
If Storage.CurseForgeTotal > -1 AndAlso Storage.CurseForgeTotal <= Storage.CurseForgeOffset Then Return Nothing
'应用筛选参数
Dim Address As String = $"https://api.curseforge.com/v1/mods/search?gameId=432&sortField=2&sortOrder=desc&pageSize={CompPageSize}"
@@ -769,7 +763,7 @@ NoSubtitle:
''' </summary>
Public Function GetModrinthAddress() As String
If Not Source.HasFlag(CompSourceType.Modrinth) Then Return Nothing
If Tag.EndsWith("/") Then Storage.ModrinthTotal = 0
If Tag.EndsWithF("/") Then Storage.ModrinthTotal = 0
If Storage.ModrinthTotal > -1 AndAlso Storage.ModrinthTotal <= Storage.ModrinthOffset Then Return Nothing
'应用筛选参数
Dim Address As String = $"https://api.modrinth.com/v2/search?limit={CompPageSize}&index=relevance"
@@ -841,7 +835,7 @@ NoSubtitle:
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果,多于所需的 {Task.Input.TargetResultCount} 个结果,结束处理")
Exit Sub
ElseIf Not Task.Input.CanContinue Then
If Task.Input.Storage.Results.Count = 0 Then
If Not Task.Input.Storage.Results.Any() Then
Throw New Exception("没有符合条件的结果")
Else
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果,少于所需的 {Task.Input.TargetResultCount} 个结果,但无法继续获取,结束处理")
@@ -880,20 +874,20 @@ NoSubtitle:
Next
'获取搜索结果
Dim SearchResults = Search(SearchEntries, Task.Input.SearchText, 3)
If SearchResults.Count = 0 Then Throw New Exception("无搜索结果,请尝试搜索英文名称")
If Not SearchResults.Any() Then Throw New Exception("无搜索结果,请尝试搜索英文名称")
Dim SearchResult As String = ""
For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的,也最多只要 5 个
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("-", " ") & " "
If SearchResults(i).Item.ModrinthSlug IsNot Nothing Then SearchResult += SearchResults(i).Item.ModrinthSlug.Replace("-", " ") & " "
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.
Replace(":", "").Replace("(", "").Replace(")", "").ToLower & " "
Replace(":", "").Replace("(", "").Replace(")", "").ToLower.Replace("/", " ") & " "
Next
Log("[Comp] 中文搜索原始关键词:" & SearchResult, LogLevel.Developer)
'去除常见连接词
Dim RealFilter As String = ""
For Each Word In SearchResult.Split(" ")
If {"the", "of", "a", "mod", "and"}.Contains(Word.ToLower) OrElse Val(Word) > 0 Then Continue For
If {"the", "of", "a", "mod", "and"}.Contains(Word.ToLowerInvariant) OrElse Val(Word) > 0 Then Continue For
If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For
RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " "
Next
@@ -911,23 +905,22 @@ NoSubtitle:
For Each Keyword In AllPossibleKeywords.Split(" ")
Keyword = Keyword.Trim("["c, "]"c)
If Keyword = "" Then Continue For
If {"forge", "fabric", "for", "mod",
"forge/fabric", "fabric/forge", "fabric/quilt", "quilt/fabric"}.Contains(Keyword) Then '#208
Log("[Comp] 已跳过搜索关键词:" & Keyword)
If {"forge", "fabric", "for", "mod", "quilt"}.Contains(Keyword) Then '#208
Log("[Comp] 已跳过搜索关键词:" & Keyword, LogLevel.Developer)
Continue For
End If
RightKeywords.Add(Keyword)
Next
If RawFilter.Length > 0 AndAlso RightKeywords.Count = 0 Then
If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then
Task.Input.SearchText = RawFilter '全都被过滤掉了
Else
Task.Input.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
End If
'例外项:OptiForge、OptiFabric(拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod)
If RawFilter.Replace(" ", "").ToLower.Contains("optiforge") Then Task.Input.SearchText = "optiforge"
If RawFilter.Replace(" ", "").ToLower.Contains("optifabric") Then Task.Input.SearchText = "optifabric"
Log("[Comp] 工程列表搜索最终文本:" & Task.Input.SearchText, LogLevel.Developer)
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Task.Input.SearchText = "optiforge"
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Task.Input.SearchText = "optifabric"
Log("[Comp] 工程列表搜索最终文本:" & Task.Input.SearchText, LogLevel.Debug)
Task.Progress = 0.1
#End Region
@@ -1017,15 +1010,15 @@ Retry:
'确保存在结果
Storage.ErrorMessage = Nothing
If RawResults.Count = 0 Then
If Not RawResults.Any() Then
If [Error] IsNot Nothing Then
Throw [Error]
Else
If IsChineseSearch AndAlso Task.Input.Type <> CompType.Mod Then
Throw New Exception($"{If(Task.Input.Type = CompType.ModPack, "整合包", "资源包")}搜索仅支持英文")
ElseIf Task.Input.Source = CompSourceType.CurseForge AndAlso Task.Input.Tag.StartsWith("/") Then
ElseIf Task.Input.Source = CompSourceType.CurseForge AndAlso Task.Input.Tag.StartsWithF("/") Then
Throw New Exception("CurseForge 不兼容所选的类型")
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWith("/") Then
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWithF("/") Then
Throw New Exception("Modrinth 不兼容所选的类型")
Else
Throw New Exception("没有符合条件的结果")
@@ -1185,7 +1178,7 @@ Retry:
''' </summary>
Public ReadOnly Property Available As Boolean
Get
Return FileName IsNot Nothing
Return FileName IsNot Nothing AndAlso DownloadUrls IsNot Nothing
End Get
End Property
''' <summary>
@@ -1195,7 +1188,11 @@ Retry:
''' <summary>
''' 文件所有可能的下载源。
''' </summary>
Private ReadOnly DownloadAddress As String()
Public DownloadUrls As List(Of String)
''' <summary>
''' 文件的 SHA1 或 MD5。
''' </summary>
Public ReadOnly Hash As String = Nothing
''' <summary>
''' 该文件的所有依赖工程的原始 ID。
''' 这些 ID 可能没有加载,在加载后会添加到 Dependencies 中(主要是因为 Modrinth 返回的是字符串 ID 而非 Slug,导致 Project.Id 查询不到)。
@@ -1210,7 +1207,7 @@ Retry:
''' </summary>
''' <param name="LocalAddress">目标本地文件夹,或完整的文件路径。会自动判断类型。</param>
Public Function ToNetFile(LocalAddress As String) As NetFile
Return New NetFile(DownloadAddress, LocalAddress & If(LocalAddress.EndsWith("\"), FileName, ""))
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True)
End Function
'实例化
@@ -1220,94 +1217,136 @@ Retry:
''' </summary>
Public Sub New(Data As JObject, Type As CompType)
Me.Type = Type
FromCurseForge = Data.ContainsKey("gameId")
If FromCurseForge Then
#Region "CurseForge"
'简单信息
Id = Data("id")
DisplayName = Data("displayName").ToString.Replace(" ", "").Trim(" ")
ReleaseDate = Data("fileDate")
Status = CType(Data("releaseType").ToObject(Of Integer), CompFileStatus)
DownloadCount = Data("downloadCount")
FileName = Data("fileName")
'DownloadAddress
Dim Url = Data("downloadUrl").ToString
If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
Url = Url.Replace(FileName, Net.WebUtility.UrlEncode(FileName)) '对文件名进行编码
DownloadAddress = {Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"),
Url}.Distinct.ToArray
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
Where(Function(d) d("relationType").ToObject(Of Integer) = 3 AndAlso '种类为依赖
d("modId").ToObject(Of Integer) <> 306612 AndAlso d("modId").ToObject(Of Integer) <> 634179). '排除 Fabric API 和 Quilt API
Select(Function(d) d("modId").ToString).ToList
End If
'GameVersions
Dim RawVersions As List(Of String) = Data("gameVersions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWith("1.")).Select(Function(v) v.Replace("-snapshot", " 快照")).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)}
ElseIf GameVersions.Count = 1 Then
GameVersions = GameVersions.ToList
Else
GameVersions = New List(Of String) From {"未知版本"}
End If
'ModLoaders
ModLoaders = New List(Of CompModLoaderType)
If RawVersions.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge)
If RawVersions.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric)
If RawVersions.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
If RawVersions.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge)
If Data.ContainsKey("FromCurseForge") Then
#Region "CompJson"
FromCurseForge = Data("FromCurseForge").ToObject(Of Boolean)
Id = Data("Id").ToString
DisplayName = Data("DisplayName").ToString
ReleaseDate = Data("ReleaseDate").ToObject(Of Date)
DownloadCount = Data("DownloadCount").ToObject(Of Integer)
Status = CType(Data("Status").ToObject(Of Integer), CompFileStatus)
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 ModLoaders = Data("ModLoaders").ToObject(Of List(Of CompModLoaderType))
If Data.ContainsKey("Hash") Then Hash = Data("Hash").ToString
If Data.ContainsKey("GameVersions") Then GameVersions = Data("GameVersions").ToObject(Of List(Of String))
If Data.ContainsKey("RawDependencies") Then RawDependencies = Data("RawDependencies").ToObject(Of List(Of String))
If Data.ContainsKey("Dependencies") Then Dependencies = Data("Dependencies").ToObject(Of List(Of String))
#End Region
Else
#Region "Modrinth"
'简单信息
Id = Data("id")
DisplayName = Data("name").ToString.Replace(" ", "").Trim(" ")
ReleaseDate = Data("date_published")
Status = If(Data("version_type").ToString = "release", CompFileStatus.Release, If(Data("version_type").ToString = "beta", CompFileStatus.Beta, CompFileStatus.Alpha))
DownloadCount = Data("downloads")
'可能为空
If CType(Data("files"), JArray).Count > 0 Then
FileName = Data("files")(0)("filename")
DownloadAddress = {Data("files")(0)("url").ToString.Replace(FileName, FileName)}
End If
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
Where(Function(d) d("dependency_type") = "required" AndAlso '种类为依赖
d("project_id") <> "P7dR8mSH" AndAlso d("project_id") <> "qvIfYCYJ" AndAlso '排除 Fabric API 和 Quilt API
d("project_id").ToString.Length > 0). '有时候真的会空……
Select(Function(d) d("project_id").ToString).ToList
End If
'GameVersions
Dim RawVersions As List(Of String) = Data("game_versions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWith("1.") OrElse v.StartsWith("b1.")).
Select(Function(v) If(v.Contains("-"), v.Split("-").First & " 快照", If(v.StartsWith("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)}
ElseIf GameVersions.Count = 1 Then
'无需处理
ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")) Then
GameVersions = RawVersions.Where(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")).ToList
Else
GameVersions = New List(Of String) From {"未知版本"}
End If
'ModLoaders
Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList
ModLoaders = New List(Of CompModLoaderType)
If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge)
If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric)
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
FromCurseForge = Data.ContainsKey("gameId")
If FromCurseForge Then
#Region "CurseForge"
'简单信息
Id = Data("id")
DisplayName = Data("displayName").ToString.Replace(" ", "").Trim(" ")
ReleaseDate = Data("fileDate")
Status = CType(Data("releaseType").ToObject(Of Integer), CompFileStatus)
DownloadCount = Data("downloadCount")
FileName = Data("fileName")
Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 1)?("value")
If Hash Is Nothing Then Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 2)?("value")
'DownloadAddress
Dim Url = Data("downloadUrl").ToString
If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
Url = Url.Replace(FileName, Net.WebUtility.UrlEncode(FileName)) '对文件名进行编码
DownloadUrls = (New List(Of String) From {Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"),
Url}).Distinct().ToList()
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
Where(Function(d) d("relationType").ToObject(Of Integer) = 3 AndAlso '种类为依赖
d("modId").ToObject(Of Integer) <> 306612 AndAlso d("modId").ToObject(Of Integer) <> 634179). '排除 Fabric API 和 Quilt API
Select(Function(d) d("modId").ToString).ToList
End If
'GameVersions
Dim RawVersions As List(Of String) = Data("gameVersions").Select(Function(t) t.ToString.Trim.ToLower).ToList
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.")).Select(Function(v) v.Replace("-snapshot", " 快照")).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)}
ElseIf GameVersions.Count = 1 Then
GameVersions = GameVersions.ToList
Else
GameVersions = New List(Of String) From {"未知版本"}
End If
'ModLoaders
ModLoaders = New List(Of CompModLoaderType)
If RawVersions.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge)
If RawVersions.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric)
If RawVersions.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
If RawVersions.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge)
#End Region
Else
#Region "Modrinth"
'简单信息
Id = Data("id")
DisplayName = Data("name").ToString.Replace(" ", "").Trim(" ")
ReleaseDate = Data("date_published")
Status = If(Data("version_type").ToString = "release", CompFileStatus.Release, If(Data("version_type").ToString = "beta", CompFileStatus.Beta, CompFileStatus.Alpha))
DownloadCount = Data("downloads")
'可能为空
If CType(Data("files"), JArray).Any() Then
Dim File As JToken = Data("files")(0)
FileName = File("filename")
DownloadUrls = New List(Of String) From {File("url")}
Hash = File("hashes")("sha1")
End If
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
Where(Function(d) d("dependency_type") = "required" AndAlso '种类为依赖
d("project_id") <> "P7dR8mSH" AndAlso d("project_id") <> "qvIfYCYJ" AndAlso '排除 Fabric API 和 Quilt API
d("project_id").ToString.Length > 0). '有时候真的会空……
Select(Function(d) d("project_id").ToString).ToList
End If
'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
If GameVersions.Count > 1 Then
GameVersions = Sort(GameVersions, AddressOf VersionSortBoolean).ToList
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
ElseIf GameVersions.Count = 1 Then
'无需处理
ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")) Then
GameVersions = RawVersions.Where(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")).ToList
Else
GameVersions = New List(Of String) From {"未知版本"}
End If
'ModLoaders
Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList
ModLoaders = New List(Of CompModLoaderType)
If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge)
If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric)
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
#End Region
End If
End If
End Sub
''' <summary>
''' 将当前实例转为可用于保存缓存的 Json。
''' </summary>
Public Function ToJson() As JObject
Dim Json As New JObject
Json.Add("FromCurseForge", FromCurseForge)
Json.Add("Id", Id)
Json.Add("DisplayName", DisplayName)
Json.Add("ReleaseDate", ReleaseDate)
Json.Add("DownloadCount", DownloadCount)
Json.Add("ModLoaders", New JArray(ModLoaders.Select(Function(m) CInt(m))))
Json.Add("GameVersions", New JArray(GameVersions))
Json.Add("Status", CInt(Status))
If FileName IsNot Nothing Then Json.Add("FileName", FileName)
If DownloadUrls IsNot Nothing Then Json.Add("DownloadUrls", New JArray(DownloadUrls))
If Hash IsNot Nothing Then Json.Add("Hash", Hash)
Json.Add("RawDependencies", New JArray(RawDependencies))
Json.Add("Dependencies", New JArray(Dependencies))
Return Json
End Function
''' <summary>
''' 将当前文件信息实例化为控件。
''' </summary>
Public Function ToListItem(OnClick As MyListItem.ClickEventHandler, Optional OnSaveClick As MyIconButton.ClickEventHandler = Nothing,
@@ -1317,9 +1356,9 @@ Retry:
Dim Info As String = ""
Select Case Type
Case CompType.Mod
Info += If(ModLoaders.Count > 0,
Info += If(ModLoaders.Any,
"适用于 " & Join(ModLoaders.Select(Function(m) GetStringFromEnum(m)).ToList, "/") & ",", "")
Info += If(ModeDebug AndAlso Dependencies.Count > 0, Dependencies.Count & " 个前置 Mod,", "")
Info += If(ModeDebug AndAlso Dependencies.Any, Dependencies.Count & " 个前置 Mod,", "")
Case CompType.ModPack
If GameVersions.All(Function(v) v.Contains("w")) Then
Info += $"游戏版本 {Join(GameVersions, "、")},"
@@ -1413,7 +1452,7 @@ Retry:
SelectMany(Function(f) f.RawDependencies).Distinct().ToList
Dim UndoneDeps = Deps.Where(Function(f) Not CompProjectCache.ContainsKey(f)).ToList
'获取前置 Mod 工程信息
If UndoneDeps.Count > 0 Then
If UndoneDeps.Any Then
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置 Mod:{Join(UndoneDeps, ",")}")
Dim Projects As JArray
If TargetProject.FromCurseForge Then
@@ -1428,7 +1467,7 @@ Retry:
Next
End If
'更新前置 Mod 信息
If Deps.Count > 0 Then
If Deps.Any Then
For Each DepProject In Deps.Select(Function(id) CompProjectCache(id))
For Each File In CompFilesCache(ProjectId)
If File.RawDependencies.Contains(DepProject.Id) AndAlso DepProject.Id <> ProjectId Then
@@ -1448,7 +1487,7 @@ Retry:
'如果为整合包就不会有 Dependencies 信息,所以不用管
Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList()
Deps.Sort()
If Deps.Count = 0 Then Exit Sub
If Not Deps.Any() Then Exit Sub
Deps = Deps.Where(Function(dep)
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置 Mod 信息", LogLevel.Debug)
Return CompProjectCache.ContainsKey(dep)
@@ -80,7 +80,7 @@
Log(ex, "确认崩溃日志时间失败(" & LogFile & ")")
End Try
Next
If RightLogs.Count = 0 Then Log("[Crash] 未发现可能可用的日志文件")
If Not RightLogs.Any() Then Log("[Crash] 未发现可能可用的日志文件")
'将可能可用的日志文件导出
For Each FilePath In RightLogs
@@ -94,7 +94,7 @@
Log(ex, "读取可能的崩溃日志文件失败(" & FilePath & ")")
End Try
Next
If LatestLog IsNot Nothing AndAlso LatestLog.Count > 0 Then
If LatestLog IsNot Nothing AndAlso LatestLog.Any Then
Dim RawOutput As String = Join(LatestLog, vbCrLf)
Log("[Crash] 以下为游戏输出的最后一段内容:" & vbCrLf & RawOutput)
WriteFile(TempFolder & "RawOutput.log", RawOutput)
@@ -110,21 +110,20 @@
Public Sub Import(FilePath As String)
Log("[Crash] 步骤 1:自主导入日志文件")
'解压压缩包
'尝试视作压缩包解压
Try
Dim Info As New FileInfo(FilePath)
If Not Info.Exists OrElse Info.Length = 0 Then Exit Try
If Not FilePath.ToLower.EndsWith(".jar") AndAlso ExtractFile(FilePath, TempFolder & "Temp\") Then
'解压成功
If Info.Exists AndAlso Info.Length > 0 AndAlso Not FilePath.EndsWithF(".jar", True) Then
ExtractFile(FilePath, TempFolder & "Temp\")
Log("[Crash] 已解压导入的日志文件:" & FilePath)
Else
'解压失败
CopyFile(FilePath, TempFolder & "Temp\" & GetFileNameFromPath(FilePath))
Log("[Crash] 已复制导入的日志文件:" & FilePath)
GoTo Extracted
End If
Catch ex As Exception
Log(ex, "解压导入文件中的压缩包失败")
Catch
End Try
'并非压缩包
CopyFile(FilePath, TempFolder & "Temp\" & GetFileNameFromPath(FilePath))
Log("[Crash] 已复制导入的日志文件:" & FilePath)
Extracted:
'导入其中的日志文件
For Each TargetFile As FileInfo In New DirectoryInfo(TempFolder & "Temp\").EnumerateFiles.ToList()
@@ -132,7 +131,7 @@
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
Dim Ext As String = TargetFile.Extension.ToLower
If Ext = ".log" OrElse Ext = ".txt" Then
If TargetFile.Name.StartsWith("crash-") Then
If TargetFile.Name.StartsWithF("crash-") Then
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
Else
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName, Encoding.UTF8).Split(vbCrLf.ToCharArray)))
@@ -169,10 +168,10 @@
For Each LogFile In AnalyzeRawFiles
Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower
Dim TargetType As AnalyzeFileType
If MatchName.StartsWith("hs_err") Then
If MatchName.StartsWithF("hs_err") Then
TargetType = AnalyzeFileType.HsErr
DirectFile = LogFile
ElseIf MatchName.StartsWith("crash-") Then
ElseIf MatchName.StartsWithF("crash-") Then
TargetType = AnalyzeFileType.CrashReport
DirectFile = LogFile
ElseIf MatchName = "latest.log" OrElse MatchName = "latest log.txt" OrElse
@@ -187,13 +186,13 @@
Else
TargetType = AnalyzeFileType.ExtraLog
End If
ElseIf MatchName.EndsWith(".log") OrElse MatchName.EndsWith(".txt") Then
ElseIf MatchName.EndsWithF(".log", True) OrElse MatchName.EndsWithF(".txt", True) Then
TargetType = AnalyzeFileType.ExtraLog
Else
Log("[Crash] " & MatchName & " 分类为 Ignore")
Continue For
End If
If LogFile.Value.Count = 0 Then
If Not LogFile.Value.Any() Then
Log("[Crash] " & MatchName & " 由于内容为空跳过")
Else
TotalFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
@@ -208,7 +207,7 @@
For Each File In TotalFiles
If SelectType = File.Key Then SelectedFiles.Add(File.Value)
Next
If SelectedFiles.Count = 0 Then Continue For
If Not SelectedFiles.Any() Then Continue For
Try
'根据文件类别判断
Select Case SelectType
@@ -389,9 +388,9 @@
'1. 精准日志匹配,中/高优先级
AnalyzeCrit1()
If CrashReasons.Count > 0 Then GoTo Done
If CrashReasons.Any Then GoTo Done
AnalyzeCrit2()
If CrashReasons.Count > 0 Then GoTo Done
If CrashReasons.Any Then GoTo Done
'2. 堆栈分析
If LogAll.Contains("orge") OrElse LogAll.Contains("abric") OrElse LogAll.Contains("uilt") OrElse LogAll.Contains("iteloader") Then
@@ -406,7 +405,7 @@
If LogMc IsNot Nothing Then
Dim Fatals = RegexSearch(LogMc, "/FATAL] [\w\W]+?(?=[\n]+\[)")
Log("[Crash] 开始进行 Minecraft 日志堆栈分析,发现 " & Fatals.Count & " 个报错项")
If Fatals.Count > 0 Then
If Fatals.Any Then
For Each Fatal In Fatals
Keywords.AddRange(AnalyzeStackKeyword(Fatal))
Next
@@ -419,7 +418,7 @@
Keywords.AddRange(AnalyzeStackKeyword(StackLogs))
End If
'Mod 名称分析
If Keywords.Count > 0 Then
If Keywords.Any Then
Dim Names = AnalyzeModName(Keywords)
If Names Is Nothing Then
AppendReason(CrashReason.堆栈分析发现关键字, Keywords)
@@ -437,12 +436,12 @@
'输出到日志
Done:
If CrashReasons.Count = 0 Then
If Not CrashReasons.Any() Then
Log("[Crash] 步骤 3:分析崩溃原因完成,未找到可能的原因")
Else
Log("[Crash] 步骤 3:分析崩溃原因完成,找到 " & CrashReasons.Count & " 条可能的原因")
For Each Reason In CrashReasons
Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Count > 0, "(" & Join(Reason.Value, ";") & ")", ""))
Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Any, "(" & Join(Reason.Value, ";") & ")", ""))
Next
End If
End Sub
@@ -458,7 +457,7 @@ Done:
Else
CrashReasons.Add(Reason, New List(Of String)(If(Additional, {})))
End If
Log("[Crash] 可能的崩溃原因:" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Count > 0, "(" & Join(Additional, ";") & ")", ""))
Log("[Crash] 可能的崩溃原因:" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Any, "(" & Join(Additional, ";") & ")", ""))
End Sub
Private Sub AppendReason(Reason As CrashReason, Additional As String)
AppendReason(Reason, If(String.IsNullOrEmpty(Additional), Nothing, New List(Of String) From {Additional}))
@@ -567,7 +566,6 @@ Done:
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("due to errors, provided by ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=due to errors, provided by ')[^']+"), "").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)})
End If
@@ -584,6 +582,8 @@ Done:
'常规信息
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, RegexSeek(LogMc, "(?<=the game will display an error screen and halt.[\n\r]+[^\n]+?Exception: )[\s\S]+?(?=\n\tat)")?.Trim(vbCrLf))
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法,这样做可能会解决你的问题:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法,这样做可能会解决你的问题:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
End If
End Sub
@@ -610,6 +610,9 @@ Done:
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "[^./ \]]+(?=.mixins.json)")
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<=mixins.)[^./ \]]+(?=.json)")
AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(If(ModId, "").TrimEnd((vbCrLf & " ").ToCharArray)))
Else
'在 #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
'极短的程序输出
If Not (LogMc.Contains("at net.") OrElse LogMc.Contains("INFO]")) AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing AndAlso LogMc.Length < 100 Then
@@ -644,14 +647,14 @@ Done:
"org.lwjgl", "com.sun", "net.minecraftforge", "paulscode.sound", "com.mojang", "net.minecraft", "cpw.mods", "com.google", "org.apache", "org.spongepowered", "net.fabricmc", "com.mumfrey",
"com.electronwill.nightconfig", "it.unimi.dsi",
"MojangTricksIntelDriversForPerformance_javaw"}
If Stack.StartsWith(IgnoreStack) Then GoTo NextStack
If Stack.StartsWithF(IgnoreStack) Then GoTo NextStack
Next
PossibleStacks.Add(Stack.Trim) '.Split("$").First)
NextStack:
Next
PossibleStacks = PossibleStacks.Distinct.ToList
Log("[Crash] 找到 " & PossibleStacks.Count & " 条可能的堆栈信息")
If PossibleStacks.Count = 0 Then Return New List(Of String)
If Not PossibleStacks.Any() Then Return New List(Of String)
For Each Stack As String In PossibleStacks
Log("[Crash] - " & Stack)
Next
@@ -662,7 +665,7 @@ NextStack:
Dim Splited = Stack.Split(".")
For i = 0 To Math.Min(3, Splited.Count - 1) '最多取前 4 节
Dim Word As String = Splited(i)
If Word.Length <= 2 OrElse Word.StartsWith("func_") Then Continue For
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",
@@ -676,7 +679,7 @@ NextStack:
Next
PossibleWords = PossibleWords.Distinct.ToList
Log("[Crash] 从堆栈信息中找到 " & PossibleWords.Count & " 个可能的 Mod ID 关键词")
If PossibleWords.Count > 0 Then Log("[Crash] - " & Join(PossibleWords, ", "))
If PossibleWords.Any Then Log("[Crash] - " & Join(PossibleWords, ", "))
If PossibleWords.Count > 10 Then
Log("[Crash] 关键词过多,考虑匹配出错,不纳入考虑")
Return New List(Of String)
@@ -715,8 +718,8 @@ NextStack:
'[Fabric] 获取所有包含 Mod 信息的行
Dim ModNameLines As New List(Of String)
For Each Line In Details.Split(vbLf)
If Line.ToLower.Contains(".jar") OrElse
(IsFabricDetail AndAlso Line.StartsWith(vbTab & vbTab) AndAlso Not RegexCheck(Line, "\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
If Line.ContainsF(".jar", True) OrElse
(IsFabricDetail AndAlso Line.StartsWithF(vbTab & vbTab) AndAlso Not RegexCheck(Line, "\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
Next
Log("[Crash] 崩溃报告中找到 " & ModNameLines.Count & " 个可能的 Mod 项目行")
@@ -781,7 +784,7 @@ NextStack:
'输出
ModFileNames = ModFileNames.Distinct.ToList
If ModFileNames.Count = 0 Then
If Not ModFileNames.Any() Then
Return Nothing
Else
Log("[Crash] 找到 " & ModFileNames.Count & " 个可能的崩溃 Mod 文件名")
@@ -845,7 +848,7 @@ NextStack:
FileName = "游戏崩溃前的输出.txt"
End Select
If File.Exists(OutputFile) Then
WriteFile(TempFolder & "Report\" & FileName, SecretFilter(ReadFile(OutputFile)))
WriteFile(TempFolder & "Report\" & FileName, SecretFilter(ReadFile(OutputFile), If(FileName = "启动脚本.bat", "F", "*")))
End If
Next
'导出报告
@@ -865,7 +868,7 @@ NextStack:
Private Function GetAnalyzeResult(IsHandAnalyze As Boolean) As String
'没有结果的处理
If CrashReasons.Count = 0 Then
If Not CrashReasons.Any() Then
If IsHandAnalyze Then
Return "很抱歉,PCL 无法确定错误原因。"
Else
@@ -901,7 +904,7 @@ NextStack:
Results.Add("你正在使用 32 位的操作系统,这会导致 Minecraft 无法使用所需的内存,进而造成崩溃。\n\n你或许只能重装 64 位的操作系统来解决此问题。\n如果你的电脑内存在 2GB 以内,那或许只能换台电脑了……\h")
End If
Case CrashReason.Mod缺少前置或MC版本错误
If Additional.Count > 0 Then
If Additional.Any Then
Results.Add("由于未满足 Mod 的依赖项,导致游戏退出。\n未满足的依赖项:\n - " & Join(Additional, "\n - ") & "\n\n请根据上述信息进行对应处理,如果看不懂英文可以使用翻译软件。")
Else
Results.Add("由于未满足 Mod 的依赖项,导致游戏退出。\n请根据错误报告中的日志信息进行对应处理,如果看不懂英文可以使用翻译软件。\h")
@@ -1033,7 +1036,7 @@ NextStack:
Replace("\e", If(IsHandAnalyze, "", vbCrLf & "你可以查看错误报告了解错误具体是如何发生的。")).
Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf).
Trim(vbCrLf.ToCharArray) &
If(Not Results.Any(Function(r) r.EndsWith("\h")) OrElse IsHandAnalyze, "",
If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "",
vbCrLf & "如果要寻求帮助,请向他人发送错误报告文件,而不是发送这个窗口的截图。" &
If(If(PageSetupSystem.IsLauncherNewest(), True), "",
vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新到最新版可能会修复这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。"))
@@ -57,9 +57,9 @@
#Region "下载支持库文件"
Dim LoadersLib As New List(Of LoaderBase) From {
New LoaderTask(Of String, List(Of NetFile))("分析缺失支持库文件", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(Version)) With {.ProgressWeight = 1},
New LoaderDownload("下载支持库文件", New List(Of NetFile)) With {.ProgressWeight = 15}
}
New LoaderTask(Of String, List(Of NetFile))("分析缺失支持库文件", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(Version)) With {.ProgressWeight = 1},
New LoaderDownload("下载支持库文件", New List(Of NetFile)) With {.ProgressWeight = 15}
}
'构造加载器
Loaders.Add(New LoaderCombo(Of String)("下载支持库文件(主加载器)", LoadersLib) With {.Block = False, .Show = False, .ProgressWeight = 16})
#End Region
@@ -71,19 +71,19 @@
Dim LoadersAssets As New List(Of LoaderBase)
'获取资源文件索引地址
LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析资源文件索引地址",
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Try
Dim IndexFile = DlClientAssetIndexGet(Version)
Dim IndexFileInfo As New FileInfo(IndexFile.LocalPath)
If AssetsIndexBehaviour <> AssetsIndexExistsBehaviour.AlwaysDownload AndAlso IndexFile.Check.Check(IndexFile.LocalPath) Is Nothing Then
Task.Output = New List(Of NetFile)
Else
Task.Output = New List(Of NetFile) From {IndexFile}
End If
Catch ex As Exception
Throw New Exception("分析资源文件索引地址失败", ex)
End Try
End Sub) With {.ProgressWeight = 0.5, .Show = False})
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Try
Dim IndexFile = DlClientAssetIndexGet(Version)
Dim IndexFileInfo As New FileInfo(IndexFile.LocalPath)
If AssetsIndexBehaviour <> AssetsIndexExistsBehaviour.AlwaysDownload AndAlso IndexFile.Check.Check(IndexFile.LocalPath) Is Nothing Then
Task.Output = New List(Of NetFile)
Else
Task.Output = New List(Of NetFile) From {IndexFile}
End If
Catch ex As Exception
Throw New Exception("分析资源文件索引地址失败", ex)
End Try
End Sub) With {.ProgressWeight = 0.5, .Show = False})
'下载资源文件索引
LoadersAssets.Add(New LoaderDownload("下载资源文件索引", New List(Of NetFile)) With {.ProgressWeight = 2})
'要求独立更新索引
@@ -91,27 +91,29 @@
Dim LoadersAssetsUpdate As New List(Of LoaderBase)
Dim TempAddress As String = Nothing
Dim RealAddress As String = Nothing
LoadersAssetsUpdate.Add(New LoaderTask(Of String, List(Of NetFile))("后台分析资源文件索引地址", Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Version)
RealAddress = BackAssetsFile.LocalPath
TempAddress = PathTemp & "Cache\" & BackAssetsFile.LocalName
BackAssetsFile.LocalPath = TempAddress
Task.Output = New List(Of NetFile) From {BackAssetsFile}
End Sub))
LoadersAssetsUpdate.Add(New LoaderTask(Of String, List(Of NetFile))("后台分析资源文件索引地址",
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Version)
RealAddress = BackAssetsFile.LocalPath
TempAddress = PathTemp & "Cache\" & BackAssetsFile.LocalName
BackAssetsFile.LocalPath = TempAddress
Task.Output = New List(Of NetFile) From {BackAssetsFile}
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)
McLaunchLog("后台更新资源文件索引成功:" & TempAddress)
End Sub))
LoadersAssetsUpdate.Add(New LoaderTask(Of List(Of NetFile), String)("后台复制资源文件索引",
Sub(Task As LoaderTask(Of List(Of NetFile), String))
CopyFile(TempAddress, RealAddress)
McLaunchLog("后台更新资源文件索引成功:" & TempAddress)
End Sub))
Dim Updater As New LoaderCombo(Of String)("后台更新资源文件索引", LoadersAssetsUpdate)
Log("[Download] 开始后台更新资源文件索引")
Updater.Start()
End If
'获取资源文件地址
LoadersAssets.Add(New LoaderTask(Of String, List(Of NetFile))("分析缺失资源文件",
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Task.Output = McAssetsFixList(McAssetsGetIndexName(Version), CheckAssetsHash, Task)
End Sub) With {.ProgressWeight = 3})
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Task.Output = McAssetsFixList(McAssetsGetIndexName(Version), CheckAssetsHash, Task)
End Sub) With {.ProgressWeight = 3})
'下载资源文件
LoadersAssets.Add(New LoaderDownload("下载资源文件", New List(Of NetFile)) With {.ProgressWeight = 25})
'构造加载器
@@ -221,9 +223,7 @@
''' </summary>
Public DlClientListBmclapiLoader As New LoaderTask(Of Integer, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of Integer, DlClientListResult))
Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json",
BackupUrl:="https://download.mcbbs.net/mc/game/version_manifest.json",
IsJson:=True)
Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", IsJson:=True)
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
@@ -250,7 +250,7 @@
End Select
'确认版本格式标准
Id = Id.Replace("_", "-") '1.7.10_pre4 在版本列表中显示为 1.7.10-pre4
If Id <> "1.0" AndAlso Id.EndsWith(".0") Then Id = Left(Id, Id.Length - 2) 'OptiFine 1.8 的下载会触发此问题,显示版本为 1.8.0
If Id <> "1.0" AndAlso Id.EndsWithF(".0") Then Id = Left(Id, Id.Length - 2) 'OptiFine 1.8 的下载会触发此问题,显示版本为 1.8.0
'查找版本并开始
For Each Version As JObject In DlClientListLoader.Output.Value("versions")
If Version("id") = Id Then
@@ -308,7 +308,7 @@
Return _inherit
End Get
Set(value As String)
If value.EndsWith(".0") Then value = Left(value, value.Length - 2)
If value.EndsWithF(".0") Then value = Left(value, value.Length - 2)
_inherit = value
End Set
End Property
@@ -368,9 +368,9 @@
Dim Entry As New DlOptiFineListEntry With {
.NameDisplay = Name(i).Replace("HD U ", "").Replace(".0 ", " "),
.ReleaseTime = Join({ReleaseTime(i).Split(".")(2), ReleaseTime(i).Split(".")(1), ReleaseTime(i).Split(".")(0)}, "/"),
.IsPreview = Name(i).ToLower.Contains("pre"),
.IsPreview = Name(i).ContainsF("pre", True),
.Inherit = Name(i).ToString.Split(" ")(0),
.NameFile = If(Name(i).ToLower.Contains("pre"), "preview_", "") & "OptiFine_" & Name(i).Replace(" ", "_") & ".jar",
.NameFile = If(Name(i).ContainsF("pre", True), "preview_", "") & "OptiFine_" & Name(i).Replace(" ", "_") & ".jar",
.RequiredForgeVersion = Forge(i).Replace("Forge ", "").Replace("#", "")}
If Entry.RequiredForgeVersion.Contains("N/A") Then Entry.RequiredForgeVersion = Nothing
Entry.NameVersion = Entry.Inherit & "-OptiFine_" & Name(i).ToString.Replace(" ", "_").Replace(Entry.Inherit & "_", "")
@@ -384,15 +384,14 @@
''' </summary>
Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain)
Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/optifine/versionList",
BackupUrl:="https://download.mcbbs.net/optifine/versionList", IsJson:=True)
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/optifine/versionList", IsJson:=True)
Try
Dim Versions As New List(Of DlOptiFineListEntry)
For Each Token As JObject In Json
Dim Entry As New DlOptiFineListEntry With {
.NameDisplay = (Token("mcversion").ToString & Token("type").ToString.Replace("HD_U", "").Replace("_", " ") & " " & Token("patch").ToString).Replace(".0 ", " "),
.ReleaseTime = "",
.IsPreview = Token("patch").ToString.ToLower.Contains("pre"),
.IsPreview = Token("patch").ToString.ContainsF("pre", True),
.Inherit = Token("mcversion").ToString,
.NameFile = Token("filename").ToString,
.RequiredForgeVersion = If(Token("forge"), "").ToString.Replace("Forge ", "").Replace("#", "")
@@ -455,7 +454,7 @@
''' </summary>
Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain)
Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html")
Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html", UseBrowserUserAgent:=True)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)")
@@ -469,8 +468,7 @@
''' </summary>
Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain)
Private Sub DlForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Dim Result As String = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding.Default,
BackupUrl:="https://download.mcbbs.net/forge/minecraft")
Dim Result As String = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding.Default)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?")
@@ -593,7 +591,7 @@
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Result As String
Try
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input & ".html")
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input & ".html", UseBrowserUserAgent:=True)
Catch ex As Exception
If GetExceptionSummary(ex).Contains("(404)") Then
Throw New Exception("没有可用版本")
@@ -605,7 +603,7 @@
Dim Versions As New List(Of DlForgeVersionEntry)
Try
'分割版本信息
Dim VersionCodes = Mid(Result, 1, Result.LastIndexOf("</table>")).Split("<td class=""download-version")
Dim VersionCodes = Mid(Result, 1, Result.LastIndexOfF("</table>")).Split("<td class=""download-version")
'获取所有版本信息
For i = 1 To VersionCodes.Count - 1
Dim VersionCode = VersionCodes(i)
@@ -630,17 +628,17 @@
Dim MD5 As String, Category As String
If VersionCode.Contains("classifier-installer""") Then
'类型为 installer.jar,支持范围 ~753 (~ 1.6.1 部分), 738~684 (1.5.2 全部)
VersionCode = VersionCode.Substring(VersionCode.IndexOf("installer.jar"))
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("installer.jar"))
MD5 = RegexSeek(VersionCode, "(?<=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.IndexOf("universal.zip"))
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("universal.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
Category = "universal"
ElseIf VersionCode.Contains("client.zip") Then
'类型为 client.zip,支持范围 182~ (1.3.2 部分 ~)
VersionCode = VersionCode.Substring(VersionCode.IndexOf("client.zip"))
VersionCode = VersionCode.Substring(VersionCode.IndexOfF("client.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
Category = "client"
Else
@@ -656,7 +654,7 @@
Catch ex As Exception
Throw New Exception("版本列表解析失败(" & Result & ")", ex)
End Try
If Versions.Count = 0 Then Throw New Exception("没有可用版本")
If Not Versions.Any() Then Throw New Exception("没有可用版本")
Loader.Output = Versions
End Sub
@@ -664,8 +662,7 @@
''' Forge 版本列表,BMCLAPI。
''' </summary>
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & Loader.Input,
BackupUrl:="https://download.mcbbs.net/forge/minecraft/" & Loader.Input, IsJson:=True)
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & Loader.Input, IsJson:=True)
Dim Versions As New List(Of DlForgeVersionEntry)
Try
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
@@ -713,7 +710,7 @@
Catch ex As Exception
Throw New Exception("版本列表解析失败(" & Json.ToString & ")", ex)
End Try
If Versions.Count = 0 Then Throw New Exception("没有可用版本")
If Not Versions.Any() Then Throw New Exception("没有可用版本")
Loader.Output = Versions
End Sub
@@ -804,7 +801,7 @@
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
For Each Pair As KeyValuePair(Of String, JToken) In Json
If Pair.Key.StartsWith("1.6") OrElse Pair.Key.StartsWith("1.5") Then Continue For
If Pair.Key.StartsWithF("1.6") OrElse Pair.Key.StartsWithF("1.5") Then Continue For
Dim RealEntry As JToken = If(Pair.Value("artefacts"), Pair.Value("snapshots"))("com.mumfrey:liteloader")("latest")
Versions.Add(New DlLiteLoaderListEntry With {
.Inherit = Pair.Key,
@@ -827,13 +824,12 @@
''' </summary>
Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain)
Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json",
BackupUrl:="https://download.mcbbs.net/maven/com/mumfrey/liteloader/versions.json", IsJson:=True)
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", IsJson:=True)
Try
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
For Each Pair As KeyValuePair(Of String, JToken) In Json
If Pair.Key.StartsWith("1.6") OrElse Pair.Key.StartsWith("1.5") Then Continue For
If Pair.Key.StartsWithF("1.6") OrElse Pair.Key.StartsWithF("1.5") Then Continue For
Dim RealEntry As JToken = If(Pair.Value("artefacts"), Pair.Value("snapshots"))("com.mumfrey:liteloader")("latest")
Versions.Add(New DlLiteLoaderListEntry With {
.Inherit = Pair.Key,
@@ -914,8 +910,7 @@
''' </summary>
Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain)
Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions",
BackupUrl:="https://download.mcbbs.net/fabric-meta/v2/versions", IsJson:=True)
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", IsJson:=True)
Try
Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result}
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -943,26 +938,25 @@
Public Function DlSourceResourceGet(MojangBase As String) As String()
MojangBase = MojangBase.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
Return {MojangBase.Replace("https://piston-data.mojang.com", "https://download.mcbbs.net/assets").Replace("https://piston-meta.mojang.com", "https://download.mcbbs.net/assets").Replace("https://resources.download.minecraft.net", "https://download.mcbbs.net/assets"),
MojangBase,
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
MojangBase
}
End Function
Public Function DlSourceLibraryGet(MojangBase As String) As String()
Return {MojangBase.Replace("https://piston-data.mojang.com", "https://download.mcbbs.net/maven").Replace("https://piston-meta.mojang.com", "https://download.mcbbs.net/maven").Replace("https://libraries.minecraft.net", "https://download.mcbbs.net/maven"),
MojangBase.Replace("https://piston-data.mojang.com", "https://download.mcbbs.net/libraries").Replace("https://piston-meta.mojang.com", "https://download.mcbbs.net/libraries").Replace("https://libraries.minecraft.net", "https://download.mcbbs.net/libraries"),
MojangBase,
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries")
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
MojangBase
}
End Function
Public Function DlSourceLauncherOrMetaGet(MojangBase As String) As String()
If MojangBase Is Nothing Then Throw New Exception("无对应的 json 下载地址")
Return {MojangBase.Replace("https://piston-data.mojang.com", "https://download.mcbbs.net").Replace("https://piston-meta.mojang.com", "https://download.mcbbs.net").Replace("https://launcher.mojang.com", "https://download.mcbbs.net").Replace("https://launchermeta.mojang.com", "https://download.mcbbs.net"),
MojangBase,
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
MojangBase
}
End Function
@@ -62,7 +62,7 @@
Public ReadOnly Property HasEnvironment As Boolean
Get
If PathFolder Is Nothing OrElse PathEnv Is Nothing Then Return False
Return PathEnv.Replace("\", "").Replace("/", "").ToLower.Contains(PathFolder.Replace("\", "").ToLower)
Return PathEnv.Replace("\", "").Replace("/", "").ContainsF(PathFolder.Replace("\", ""), True)
End Get
End Property
@@ -78,8 +78,8 @@
''' </summary>
Public Overrides Function ToString() As String
Dim VersionString = Version.ToString
If VersionString.StartsWith("1.") Then VersionString = Mid(VersionString, 3)
Return If(IsJre, "JRE ", "JDK ") & VersionCode & " (" & VersionString & ")," & If(Is64Bit, "64", "32") & " 位" & If(IsUserImport, ",手动导入", "") & ":" & PathFolder
If VersionString.StartsWithF("1.") Then VersionString = Mid(VersionString, 3)
Return If(IsJre, "JRE ", "JDK ") & VersionCode & " (" & VersionString & ")" & If(Is64Bit, "", ",32 位") & If(IsUserImport, ",手动导入", "") & ":" & PathFolder
End Function
'构造
@@ -87,7 +87,7 @@
''' 输入 javaw.exe 文件所在文件夹的路径,不限制结尾。
''' </summary>
Public Sub New(Folder As String, IsUserImport As Boolean)
If Not Folder.EndsWith("\") Then Folder += "\"
If Not Folder.EndsWithF("\") Then Folder += "\"
PathFolder = Folder.Replace("/", "\")
Me.IsUserImport = IsUserImport
End Sub
@@ -116,8 +116,9 @@
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java,请在删除 Java 文件夹中的 /lib/ext 文件夹后再试")
'获取详细信息
Dim VersionString = If(RegexSeek(Output, "(?<=version "")[^""]+"), If(RegexSeek(Output, "(?<=openjdk )[0-9]+"), "")).Replace("_", ".").Split("-").First
If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493,VersionString = "21.0.2.0.2"
Do While VersionString.Split(".").Count < 4
If VersionString.StartsWith("1.") Then
If VersionString.StartsWithF("1.") Then
VersionString = VersionString & ".0"
Else
VersionString = "1." & VersionString
@@ -184,7 +185,7 @@
JavaList.Add(JavaEntry.FromJson(JsonEntry))
Next
End If
If JavaList.Count = 0 Then
If Not JavaList.Any() Then
Log("[Java] 初始化未找到可用的 Java,将自动触发搜索", LogLevel.Developer)
JavaSearchLoader.Start(0)
Else
@@ -219,7 +220,7 @@
Next
'检查特定的 Java
If TargetJavaList.Count > 0 Then
If TargetJavaList.Any Then
TargetJavaList = JavaCheckList(TargetJavaList)
Log("[Java] 检查后找到 " & TargetJavaList.Count & " 个特定路径下的 Java:")
For Each Java In TargetJavaList
@@ -232,7 +233,7 @@
Dim UserJava As JavaEntry = Nothing
'获取版本独立设置中指定的 Java
If RelatedVersion IsNot Nothing AndAlso Setup.Get("VersionArgumentJavaSelect", Version:=RelatedVersion).ToString.StartsWith("{") Then
If RelatedVersion IsNot Nothing AndAlso Setup.Get("VersionArgumentJavaSelect", Version:=RelatedVersion).ToString.StartsWithF("{") Then
Try
UserJava = JavaEntry.FromJson(GetJson(Setup.Get("VersionArgumentJavaSelect", Version:=RelatedVersion)))
UserJava.Check()
@@ -291,7 +292,7 @@ RetryGet:
Next
'若未找到适合的 Java,尝试触发搜索
If AllowedJavaList.Count = 0 AndAlso JavaSearchLoader.State = LoadState.Waiting Then
If Not AllowedJavaList.Any() AndAlso JavaSearchLoader.State = LoadState.Waiting Then
Log("[Java] 未找到满足条件的 Java,尝试进行搜索")
JavaSearchLoader.Start(IsForceRestart:=True)
GoTo RetryGet
@@ -352,7 +353,7 @@ ExitUserJavaCheck:
#End Region
'若依然未找到适合的 Java,直接返回
If AllowedJavaList.Count = 0 Then Return Nothing
If Not AllowedJavaList.Any() Then Return Nothing
'优先使用特定目录下的 Java
For Each Java In AllowedJavaList
@@ -445,11 +446,11 @@ NoUserJava:
Dim ProgramPathParent As String, MinecraftPathParent As String = ""
ProgramPathParent = If(New DirectoryInfo(Path).Parent, New DirectoryInfo(Path)).FullName
If PathMcFolder <> "" Then MinecraftPathParent = If(New DirectoryInfo(PathMcFolder).Parent, New DirectoryInfo(PathMcFolder)).FullName
If Left.PathFolder.StartsWith(ProgramPathParent) AndAlso Not Right.PathFolder.StartsWith(ProgramPathParent) Then Return True
If Not Left.PathFolder.StartsWith(ProgramPathParent) AndAlso Right.PathFolder.StartsWith(ProgramPathParent) Then Return False
If Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Not Right.PathFolder.StartsWithF(ProgramPathParent) Then Return True
If Not Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Right.PathFolder.StartsWithF(ProgramPathParent) Then Return False
If PathMcFolder <> "" Then
If Left.PathFolder.StartsWith(MinecraftPathParent) AndAlso Not Right.PathFolder.StartsWith(MinecraftPathParent) Then Return True
If Not Left.PathFolder.StartsWith(MinecraftPathParent) AndAlso Right.PathFolder.StartsWith(MinecraftPathParent) Then Return False
If Left.PathFolder.StartsWithF(MinecraftPathParent) AndAlso Not Right.PathFolder.StartsWithF(MinecraftPathParent) Then Return True
If Not Left.PathFolder.StartsWithF(MinecraftPathParent) AndAlso Right.PathFolder.StartsWithF(MinecraftPathParent) Then Return False
End If
'2. 尽量使用 64 位
If Left.Is64Bit AndAlso Not Right.Is64Bit Then Return True
@@ -459,7 +460,7 @@ 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...
' 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}
Return Weight.ElementAtOrDefault(Left.VersionCode) >= Weight.ElementAtOrDefault(Right.VersionCode)
End If
@@ -500,7 +501,7 @@ NoUserJava:
For Each PathInEnv As String In Split((PathEnv & ";" & PathJavaHome).Replace("\\", "\").Replace("/", "\"), ";")
PathInEnv = PathInEnv.Trim(" """.ToCharArray())
If PathInEnv = "" Then Continue For
If Not PathInEnv.EndsWith("\") Then PathInEnv += "\"
If Not PathInEnv.EndsWithF("\") Then PathInEnv += "\"
'粗略检查有效性
If File.Exists(PathInEnv & "javaw.exe") Then JavaPreList(PathInEnv) = False
Next
@@ -533,7 +534,7 @@ NoUserJava:
Log("[Java] 位于 " & Folder & " 的 Java 不含符号链接")
JavaWithoutReparse.Add(Pair.Key, Pair.Value)
Next
If JavaWithoutReparse.Count > 0 Then JavaPreList = JavaWithoutReparse
If JavaWithoutReparse.Any Then JavaPreList = JavaWithoutReparse
'若不全为特殊引用,则清除特殊引用的地址
Dim JavaWithoutInherit As New Dictionary(Of String, Boolean)
@@ -545,7 +546,7 @@ NoUserJava:
JavaWithoutInherit.Add(Pair.Key, Pair.Value)
End If
Next
If JavaWithoutInherit.Count > 0 Then JavaPreList = JavaWithoutInherit
If JavaWithoutInherit.Any Then JavaPreList = JavaWithoutInherit
#End Region
@@ -652,7 +653,7 @@ Wait:
'确认目录存在
If Not OriginalPath.Exists Then Exit Sub
Dim Path As String = OriginalPath.FullName.Replace("\\", "\")
If Not Path.EndsWith("\") Then Path += "\"
If Not Path.EndsWithF("\") Then Path += "\"
'若该目录有 Java,则加入结果
If File.Exists(Path & "javaw.exe") Then Results(Path) = Source
'查找其下的所有文件夹
@@ -715,7 +716,7 @@ Wait:
End Function
''' <summary>
''' 获取下载 Java 8/14/17 的加载器。需要开启 IsForceRestart 以正常刷新 Java 列表。
''' 获取下载 Java 8/14/17/21 的加载器。需要开启 IsForceRestart 以正常刷新 Java 列表。
''' </summary>
Public Function JavaFixLoaders(Version As Integer) As LoaderCombo(Of Integer)
Return New LoaderCombo(Of Integer)($"下载 Java {Version}", {
@@ -727,21 +728,19 @@ Wait:
Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile)))
Log("[Java] 开始获取 Java 下载信息")
Dim IndexFileStr As String = NetGetCodeByDownload(
{"https://download.mcbbs.net/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json",
"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json",
{"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json",
"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"},
IsJson:=True)
'获取下载地址
Dim MainEntry As JObject = CType(GetJson(IndexFileStr), JObject)($"windows-x{If(Is32BitSystem, "86", "64")}")
Dim Entries = MainEntry.Children.Reverse. '选择最靠后的一项(最新)
SelectMany(Function(e As JProperty) CType(e.Value, JArray).Select(Function(v) New KeyValuePair(Of String, JObject)(e.Name, v)))
Dim TargetEntry = Entries.First(Function(t) t.Value("version")("name").ToString.StartsWith(Loader.Input))
Dim TargetEntry = Entries.First(Function(t) t.Value("version")("name").ToString.StartsWithF(Loader.Input))
Dim Address As String = TargetEntry.Value("manifest")("url")
Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}({TargetEntry.Key}):{Address}")
'获取文件列表
Dim ListFileStr As String = NetGetCodeByDownload(
{Address.Replace("piston-meta.mojang.com", "download.mcbbs.net"),
Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com"),
{Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com"),
Address},
IsJson:=True)
Dim BaseDir As String = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Key & "\"
@@ -753,8 +752,7 @@ Wait:
If Checker.Check(BaseDir & File.Name) Is Nothing Then Continue For '跳过已存在的文件
Dim Url As String = Info("url")
Results.Add(New NetFile(
{Url.Replace("piston-data.mojang.com", "download.mcbbs.net"),
Url.Replace("piston-data.mojang.com", "bmclapi2.bangbang93.com"),
{Url.Replace("piston-data.mojang.com", "bmclapi2.bangbang93.com"),
Url},
BaseDir & File.Name, Checker))
Next
@@ -62,7 +62,7 @@ Public Module ModLaunch
''' 记录启动日志。
''' </summary>
Public Sub McLaunchLog(Text As String)
Text = SecretFilter(Text)
Text = SecretFilter(Text, "*")
RunInUi(Sub() FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text)
Log("[Launch] " & Text)
End Sub
@@ -101,10 +101,10 @@ Public Module ModLaunch
'正式加载
Try
'构造主加载器
Dim LaunchLoader As New LoaderCombo(Of Object)("Minecraft 启动", {
New LoaderTask(Of Integer, Integer)("获取 Java", AddressOf McLaunchJava) With {.ProgressWeight = 4, .Block = False, .Show = False},
Dim Loaders As New List(Of LoaderBase) From {
New LoaderTask(Of Integer, Integer)("获取 Java", AddressOf McLaunchJava) With {.ProgressWeight = 4, .Block = False},
McLoginLoader,
New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground, True)) With {.ProgressWeight = 15, .Show = False, .Block = True},
New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground, True)) With {.ProgressWeight = 15, .Show = False},
New LoaderTask(Of String, List(Of McLibToken))("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2},
New LoaderTask(Of List(Of McLibToken), Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2},
New LoaderTask(Of Integer, Integer)("预启动处理", AddressOf McLaunchPrerun) With {.ProgressWeight = 1},
@@ -112,7 +112,12 @@ Public Module ModLaunch
New LoaderTask(Of Integer, Process)("启动进程", AddressOf McLaunchRun) With {.ProgressWeight = 2},
New LoaderTask(Of Process, Integer)("等待游戏窗口出现", AddressOf McLaunchWait) With {.ProgressWeight = 1},
New LoaderTask(Of Integer, Integer)("结束处理", AddressOf McLaunchEnd) With {.ProgressWeight = 1}
}) With {.Show = False}
}
If Setup.Get("LaunchArgumentRam") Then
CType(Loaders(2), LoaderCombo(Of String)).Block = False
Loaders.Insert(3, New LoaderTask(Of Integer, Integer)("内存优化", AddressOf McLaunchMemoryOptimize) With {.ProgressWeight = 30})
End If
Dim LaunchLoader As New LoaderCombo(Of Object)("Minecraft 启动", Loaders) With {.Show = False}
If McLoginLoader.State = LoadState.Finished Then McLoginLoader.State = LoadState.Waiting '要求重启登录主加载器,它会自行决定是否启动副加载器
'等待加载器执行并更新 UI
McLaunchLoaderReal = LaunchLoader
@@ -143,7 +148,7 @@ Public Module ModLaunch
Catch ex As Exception
Dim CurrentEx = ex
NextInner:
If CurrentEx.Message.StartsWith("$") Then
If CurrentEx.Message.StartsWithF("$") Then
'若有以 $ 开头的错误信息,则以此为准显示提示
'若错误信息为 $$,则不提示
If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(Loader.Input.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
@@ -163,6 +168,28 @@ NextInner:
#End Region
#Region "内存优化"
Private Sub McLaunchMemoryOptimize(Loader As LoaderTask(Of Integer, Integer))
McLaunchLog("内存优化开始")
Dim Finished As Boolean = False
RunInNewThread(
Sub()
PageOtherTest.MemoryOptimize(False)
Finished = True
End Sub, "Launch Memory Optimize")
Do While Not Finished AndAlso Not Loader.IsAborted
If Loader.Progress < 0.7 Then
Loader.Progress += 0.007 '10s
Else
Loader.Progress += (0.95 - Loader.Progress) * 0.02 '最快 += 0.005
End If
Thread.Sleep(100)
Loop
End Sub
#End Region
#Region "预检测"
Private Sub McLaunchPrecheck()
@@ -247,7 +274,7 @@ NextInner:
''' </summary>
Public BaseUrl As String
''' <summary>
''' 登录所使用的标识符,如 “Mojang”、“Nide”,用于存储缓存等。
''' 登录所使用的标识符,目前只可能为 “Auth” 或 “Nide”,用于存储缓存等。
''' </summary>
Public Token As String
''' <summary>
@@ -526,7 +553,13 @@ SkipLogin:
McLaunchLog("登录方式:" & Input.Description & "(" & LogUsername & ")")
Data.Progress = 0.05
'尝试登录
If (Not Data.Input.ForceReselectProfile) AndAlso Setup.Get("Cache" & Input.Token & "Username") = Data.Input.UserName AndAlso Setup.Get("Cache" & Input.Token & "Pass") = Data.Input.Password AndAlso Not Setup.Get("Cache" & Input.Token & "Access") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Client") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Uuid") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Name") = "" Then
If (Not Data.Input.ForceReselectProfile) AndAlso
Setup.Get("Cache" & Input.Token & "Username") = Data.Input.UserName AndAlso
Setup.Get("Cache" & Input.Token & "Pass") = Data.Input.Password AndAlso
Setup.Get("Cache" & Input.Token & "Access") <> "" AndAlso
Setup.Get("Cache" & Input.Token & "Client") <> "" AndAlso
Setup.Get("Cache" & Input.Token & "Uuid") <> "" AndAlso
Setup.Get("Cache" & Input.Token & "Name") <> "" Then
'尝试验证登录
Try
If Data.IsAborted Then Throw New ThreadInterruptedException
@@ -752,7 +785,7 @@ LoginFinish:
End Select
ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then
Throw New Exception("$登录失败:连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!")
ElseIf ex.Message.StartsWith("$") Then
ElseIf ex.Message.StartsWithF("$") Then
Throw
Else
Throw New Exception("登录失败:" & ex.Message, ex)
@@ -990,14 +1023,14 @@ SystemBrowser:
Case 1
'Steve
Do Until McSkinSex(Uuid) = "Steve"
If Uuid.EndsWith("FFFFF") Then Uuid = Mid(Uuid, 1, 32 - 5) & "00000"
Uuid = Mid(Uuid, 1, 32 - 5) & (Long.Parse(Right(Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
If Uuid.EndsWithF("FFFFF") Then Uuid = Uuid.Substring(0, 27) & "00000"
Uuid = Uuid.Substring(0, 27) & (Long.Parse(Uuid.Substring(27), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X").PadLeft(5, "0")
Loop
Case 2
'Alex
Do Until McSkinSex(Uuid) = "Alex"
If Uuid.EndsWith("FFFFF") Then Uuid = Mid(Uuid, 1, 32 - 5) & "00000"
Uuid = Mid(Uuid, 1, 32 - 5) & (Long.Parse(Right(Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
If Uuid.EndsWithF("FFFFF") Then Uuid = Uuid.Substring(0, 27) & "00000"
Uuid = Uuid.Substring(0, 27) & (Long.Parse(Uuid.Substring(27), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X").PadLeft(5, "0")
Loop
Case 3
'使用正版用户名
@@ -1013,7 +1046,7 @@ SystemBrowser:
Case 4
'自定义
Do Until McSkinSex(Uuid) = If(Setup.Get("LaunchSkinSlim"), "Alex", "Steve")
If Uuid.EndsWith("FFFFF") Then Uuid = Mid(Uuid, 1, 32 - 5) & "00000"
If Uuid.EndsWithF("FFFFF") Then Uuid = Mid(Uuid, 1, 32 - 5) & "00000"
Uuid = Mid(Uuid, 1, 32 - 5) & (Long.Parse(Right(Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
Loop
End Select
@@ -1057,7 +1090,12 @@ SystemBrowser:
Dim MinVer As New Version(0, 0, 0, 0), MaxVer As New Version(999, 999, 999, 999)
'MC 大版本检测
If (McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
If (McVersionCurrent.ReleaseTime >= New Date(2024, 4, 2) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
(McVersionCurrent.Version.McCodeMain > 20 AndAlso McVersionCurrent.Version.McCodeMain <> 99) OrElse
(McVersionCurrent.Version.McCodeMain = 20 AndAlso McVersionCurrent.Version.McCodeSub >= 5) Then
'1.20.5+(24w14a+):至少 Java 21
MinVer = New Version(1, 21, 0, 0)
ElseIf (McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
(McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain <> 99) Then
'1.18 pre2+:至少 Java 17
MinVer = New Version(1, 17, 0, 0)
@@ -1091,22 +1129,25 @@ SystemBrowser:
If McVersionCurrent.Version.HasForge Then
If McVersionCurrent.Version.McName = "1.7.2" Then
'1.7.2:必须 Java 7
MinVer = New Version(1, 7, 0, 0) : MaxVer = New Version(1, 7, 999, 999)
MinVer = If(New Version(1, 7, 0, 0) > MinVer, New Version(1, 7, 0, 0), MinVer)
MaxVer = If(New Version(1, 7, 999, 999) < MaxVer, New Version(1, 7, 999, 999), MaxVer)
ElseIf McVersionCurrent.Version.McCodeMain <= 12 AndAlso McVersionCurrent.Version.McCodeMain > 0 Then
'<=1.12:Java 8
MaxVer = New Version(1, 8, 999, 999)
ElseIf McVersionCurrent.Version.McCodeMain <= 14 AndAlso McVersionCurrent.Version.McCodeMain >= 13 Then
'1.13 - 1.14:Java 8 - 10
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 10, 999, 999)
MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer)
MaxVer = If(New Version(1, 10, 999, 999) < MaxVer, New Version(1, 10, 999, 999), MaxVer)
ElseIf McVersionCurrent.Version.McCodeMain = 15 Then
'1.15:Java 8 - 15
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 15, 999, 999)
MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer)
MaxVer = If(New Version(1, 15, 999, 999) < MaxVer, New Version(1, 15, 999, 999), MaxVer)
ElseIf VersionSortBoolean(McVersionCurrent.Version.ForgeVersion, "34.0.0") AndAlso VersionSortBoolean("36.2.25", McVersionCurrent.Version.ForgeVersion) Then
'1.16,Forge 34.X ~ 36.2.25:最高 Java 8u320
MaxVer = New Version(1, 8, 0, 320)
MaxVer = If(New Version(1, 8, 0, 320) < MaxVer, New Version(1, 8, 0, 320), MaxVer)
ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 19 AndAlso McVersionCurrent.Version.HasOptiFine Then '#305
'1.18:若安装了 OptiFine,最高 Java 18
MaxVer = New Version(1, 18, 999, 999)
MaxVer = If(New Version(1, 18, 999, 999) < MaxVer, New Version(1, 18, 999, 999), MaxVer)
End If
End If
@@ -1114,10 +1155,10 @@ SystemBrowser:
If McVersionCurrent.Version.HasFabric Then
If McVersionCurrent.Version.McCodeMain >= 15 AndAlso McVersionCurrent.Version.McCodeMain <= 16 AndAlso McVersionCurrent.Version.McCodeMain <> -1 Then
'1.15 - 1.16:Java 8+
MinVer = New Version(1, 8, 0, 0)
MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer)
ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 99 Then
'1.18+:Java 17+
MinVer = New Version(1, 17, 0, 0)
MinVer = If(New Version(1, 17, 0, 0) > MinVer, New Version(1, 17, 0, 0), MinVer)
End If
End If
@@ -1140,7 +1181,10 @@ SystemBrowser:
If Task.IsAborted Then Exit Sub '中断加载会导致 JavaSelect 异常地返回空值,误判找不到 Java
McLaunchLog("无合适的 Java,需要确认是否自动下载")
Dim JavaCode As String
If MinVer >= New Version(1, 9, 0, 0) Then
If MinVer >= New Version(1, 21, 0, 0) Then
JavaCode = 21
If Not JavaDownloadConfirm("Java 21") Then Throw New Exception("$$")
ElseIf MinVer >= New Version(1, 9, 0, 0) Then
JavaCode = 17
If Not JavaDownloadConfirm("Java 17") Then Throw New Exception("$$")
ElseIf MaxVer < New Version(1, 8, 0, 0) Then
@@ -1194,17 +1238,20 @@ SystemBrowser:
''' </summary>
Public Function ExtractJavaWrapper() As String
Dim WrapperPath As String = GetJavaWrapperDir() & "\JavaWrapper.jar"
WriteFile(WrapperPath, GetResources("JavaWrapper"))
SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突
WriteFile(WrapperPath, GetResources("JavaWrapper"))
End SyncLock
Log("[Java] 已释放 Java Wrapper:" & WrapperPath)
Return WrapperPath
End Function
Private ExtractJavaWrapperLock As New Object
''' <summary>
''' 获取 Java Wrapper 所在的文件夹,不以 \ 结尾。
''' </summary>
Public Function GetJavaWrapperDir() As String
If Encoding.UTF8.GetByteCount(PathAppdata) = PathAppdata.Length Then
If PathAppdata.IsASCII() Then
Return PathAppdata.TrimEnd("\")
ElseIf Encoding.UTF8.GetByteCount(PathTemp) = PathTemp.Length Then
ElseIf PathTemp.IsASCII() Then
Log("[Java] Wrapper:AppData 路径中包含非 ASCII 字符,换用 Temp 目录")
Return PathTemp.TrimEnd("\")
Else
@@ -1268,9 +1315,7 @@ SystemBrowser:
'不包含端口号
Arguments += " --server " & Server & " --port 25565"
End If
If McVersionCurrent.Version.HasOptiFine Then 'OptiFine 警告
Hint("OptiFine 与自动进入服务器可能不兼容,有概率导致材质丢失甚至游戏崩溃!", HintType.Critical)
End If
If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容,有概率导致材质丢失甚至游戏崩溃!", HintType.Critical)
End If
End If
'自定义
@@ -1292,10 +1337,11 @@ SystemBrowser:
Dim ArgumentJvm As String = Setup.Get("VersionAdvanceJvm", Version:=McVersionCurrent)
If ArgumentJvm = "" Then ArgumentJvm = Setup.Get("LaunchAdvanceJvm")
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("-Xmn256m")
DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024 * 0.5) & "m")
DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & "m")
DataList.Add("""-Djava.library.path=" & Version.Path & Version.Name & "-natives""")
DataList.Add("""-Djava.library.path=" & GetNativesFolder() & """")
DataList.Add("-cp ${classpath}") '把支持库添加进启动参数表
'统一通行证
@@ -1394,9 +1440,9 @@ NextVersion:
Dim DeDuplicateDataList As New List(Of String)
For i = 0 To DataList.Count - 1
Dim CurrentEntry As String = DataList(i)
If DataList(i).StartsWith("-") Then
If DataList(i).StartsWithF("-") Then
Do While i < DataList.Count - 1
If DataList(i + 1).StartsWith("-") Then
If DataList(i + 1).StartsWithF("-") Then
Exit Do
Else
i += 1
@@ -1407,6 +1453,9 @@ NextVersion:
DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu="))
Next
'#3511 的清理
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M")
'去重
Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ")
@@ -1487,9 +1536,9 @@ NextVersion:
Dim DeDuplicateDataList As New List(Of String)
For i = 0 To DataList.Count - 1
Dim CurrentEntry As String = DataList(i)
If DataList(i).StartsWith("-") Then
If DataList(i).StartsWithF("-") Then
Do While i < DataList.Count - 1
If DataList(i + 1).StartsWith("-") Then
If DataList(i + 1).StartsWithF("-") Then
Exit Do
Else
i += 1
@@ -1527,7 +1576,7 @@ NextVersion:
'基础参数
GameArguments.Add("${classpath_separator}", ";")
GameArguments.Add("${natives_directory}", Version.Path & Version.Name & "-natives")
GameArguments.Add("${natives_directory}", GetNativesFolder())
GameArguments.Add("${library_directory}", PathMcFolder & "libraries")
GameArguments.Add("${libraries_directory}", PathMcFolder & "libraries")
GameArguments.Add("${launcher_name}", "PCL")
@@ -1544,9 +1593,26 @@ NextVersion:
GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken)
GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken)
GameArguments.Add("${user_type}", "msa") '#1221
Dim GameSize As Size = Setup.GetLaunchArgumentWindowSize()
GameArguments.Add("${resolution_width}", GameSize.Width)
GameArguments.Add("${resolution_height}", GameSize.Height)
'窗口尺寸参数
Dim GameSize As Size
Select Case Setup.Get("LaunchArgumentWindowType")
Case 2
Dim Result As Size
RunInUiWait(Sub() Result = New Size(GetPixelSize(FrmMain.PanForm.ActualWidth), GetPixelSize(FrmMain.PanForm.ActualHeight)))
GameSize = Result
Case 3
GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth") - 2), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight") - 2))
Case Else
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% 倍
GameSize.Width /= DPI / 96
GameSize.Height /= DPI / 96
End If
GameArguments.Add("${resolution_width}", Math.Round(GameSize.Width))
GameArguments.Add("${resolution_height}", Math.Round(GameSize.Height))
'Assets 相关参数
GameArguments.Add("${game_assets}", PathMcFolder & "assets\virtual\legacy") '1.5.2 的 pre-1.6 资源索引应与 legacy 合并
@@ -1578,7 +1644,8 @@ NextVersion:
Private Sub McLaunchNatives(Loader As LoaderTask(Of List(Of McLibToken), Integer))
'创建文件夹
Directory.CreateDirectory(McVersionCurrent.Path & McVersionCurrent.Name & "-natives")
Dim Target As String = GetNativesFolder() & "\"
Directory.CreateDirectory(Target)
'解压文件
McLaunchLog("正在解压 Natives 文件")
@@ -1595,9 +1662,9 @@ NextVersion:
End Try
For Each Entry In Zip.Entries
Dim FileName As String = Entry.FullName
If FileName.EndsWith(".dll") Then
If FileName.EndsWithF(".dll", True) Then
'实际解压文件的步骤
Dim FilePath As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives\" & FileName
Dim FilePath As String = Target & FileName
ExistFiles.Add(FilePath)
Dim OriginalFile As New FileInfo(FilePath)
If OriginalFile.Exists Then
@@ -1623,7 +1690,7 @@ NextVersion:
Next
'删除多余文件
For Each FileName As String In Directory.GetFiles(McVersionCurrent.Path & McVersionCurrent.Name & "-natives")
For Each FileName As String In Directory.GetFiles(Target)
If ExistFiles.Contains(FileName) Then Continue For
Try
McLaunchLog("删除:" & FileName)
@@ -1636,6 +1703,16 @@ NextVersion:
Next
End Sub
''' <summary>
''' 获取 Natives 文件夹路径,不以 \ 结尾。
''' </summary>
Private Function GetNativesFolder() As String
Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives"
If IsGBKEncoding OrElse Result.IsASCII() Then Return Result
Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives"
If Result.IsASCII() Then Return Result
Return OsDrive & "ProgramData\PCL\natives"
End Function
#End Region
@@ -1750,7 +1827,7 @@ NextVersion:
Select Case Setup.Get("LaunchArgumentWindowType")
Case 0 '全屏
WriteIni(SetupFileAddress, "fullscreen", "true")
Case 5 '保持默认
Case 1 '默认
Case Else '其他
WriteIni(SetupFileAddress, "fullscreen", "false")
End Select
@@ -1911,9 +1988,9 @@ IgnoreCustomSkin:
'获取自定义命令
Dim CustomCommandGlobal As String = Setup.Get("LaunchAdvanceRun")
If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal)
If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal, True)
Dim CustomCommandVersion As String = Setup.Get("VersionAdvanceRun", Version:=McVersionCurrent)
If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion)
If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion, True)
'输出 bat
Try
@@ -1928,7 +2005,7 @@ IgnoreCustomSkin:
"""" & McLaunchJavaSelected.PathJava & """ " & McLaunchArgument & vbCrLf &
"echo 游戏已退出。" & vbCrLf &
"pause"
WriteFile(If(McLaunchLoader.Input.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString),
WriteFile(If(McLaunchLoader.Input.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"),
Encoding:=If(Encoding.Default.Equals(Encoding.UTF8), Encoding.UTF8, Encoding.GetEncoding("GB18030")))
If McLaunchLoader.Input.SaveBatch IsNot Nothing Then
McLaunchLog("导出启动脚本完成,强制结束启动过程")
@@ -2050,7 +2127,7 @@ IgnoreCustomSkin:
McLaunchLog("")
McLaunchLog("~ 基础参数 ~")
McLaunchLog("PCL 版本:" & VersionDisplayName & " (" & VersionCode & ")")
McLaunchLog("游戏版本:" & McVersionCurrent.Version.ToString & "(" & McVersionCurrent.Version.McCodeMain & "." & McVersionCurrent.Version.McCodeSub & ")")
McLaunchLog("游戏版本:" & McVersionCurrent.Version.ToString & "(识别为 1." & McVersionCurrent.Version.McCodeMain & "." & McVersionCurrent.Version.McCodeSub & ")")
McLaunchLog("资源版本:" & McAssetsGetIndexName(McVersionCurrent))
McLaunchLog("版本继承:" & If(McVersionCurrent.InheritVersion = "", "无", McVersionCurrent.InheritVersion))
McLaunchLog("分配的内存:" & PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) & " GB(" & Math.Round(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & " MB)")
@@ -2060,6 +2137,7 @@ IgnoreCustomSkin:
McLaunchLog("HMCL 格式:" & McVersionCurrent.IsHmclFormatJson)
McLaunchLog("Java 信息:" & If(McLaunchJavaSelected IsNot Nothing, McLaunchJavaSelected.ToString, "无可用 Java"))
McLaunchLog("环境变量:" & If(McLaunchJavaSelected IsNot Nothing, If(McLaunchJavaSelected.HasEnvironment, "已设置", "未设置"), "未设置"))
McLaunchLog("Natives 文件夹:" & GetNativesFolder())
McLaunchLog("")
McLaunchLog("~ 登录参数 ~")
McLaunchLog("玩家用户名:" & McLoginLoader.Output.Name)
@@ -2072,7 +2150,7 @@ IgnoreCustomSkin:
'获取窗口标题
Dim WindowTitle As String = Setup.Get("VersionArgumentTitle", Version:=McVersionCurrent)
If WindowTitle = "" Then WindowTitle = Setup.Get("LaunchArgumentTitle")
WindowTitle = ArgumentReplace(WindowTitle)
WindowTitle = ArgumentReplace(WindowTitle, False)
'初始化等待
Dim Watcher As New Watcher(Loader, McVersionCurrent, WindowTitle)
@@ -2124,7 +2202,7 @@ IgnoreCustomSkin:
''' <summary>
''' 在启动结束时,对 PCL 约定的替换标记进行处理。
''' </summary>
Private Function ArgumentReplace(Raw As String) As String
Private Function ArgumentReplace(Raw As String, ReplaceTimeAndDate As Boolean) As String
If Raw Is Nothing Then Return Nothing
'路径替换
Raw = Raw.Replace("{minecraft}", PathMcFolder)
@@ -2134,6 +2212,10 @@ IgnoreCustomSkin:
'普通替换
Raw = Raw.Replace("{user}", McLoginLoader.Output.Name)
Raw = Raw.Replace("{uuid}", McLoginLoader.Output.Uuid)
If ReplaceTimeAndDate Then '设置窗口标题时需要动态替换日期和时间
Raw = Raw.Replace("{date}", Date.Now.ToString("yyyy/M/d"))
Raw = Raw.Replace("{time}", Date.Now.ToString("HH:mm:ss"))
End If
Select Case McLoginLoader.Input.Type
Case McLoginType.Legacy
If PageLinkHiper.HiperState = LoadState.Finished Then
@@ -42,15 +42,19 @@
#Region "读取默认(Original)文件夹,即当前、官启文件夹,可能没有结果"
'扫描当前文件夹
If CheckPermission(Path) AndAlso Directory.Exists(Path & "versions\") Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Path, .Type = McFolderType.Original})
For Each Folder As DirectoryInfo In New DirectoryInfo(Path).GetDirectories
If CheckPermission(Folder.FullName) AndAlso Directory.Exists(Folder.FullName & "versions\") OrElse Folder.Name = ".minecraft" Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Folder.FullName & "\", .Type = McFolderType.Original})
Next
Try
If Directory.Exists(Path & "versions\") Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Path, .Type = McFolderType.Original})
For Each Folder As DirectoryInfo In New DirectoryInfo(Path).GetDirectories
If Directory.Exists(Folder.FullName & "versions\") OrElse Folder.Name = ".minecraft" Then CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Folder.FullName & "\", .Type = McFolderType.Original})
Next
Catch ex As Exception
Log(ex, "扫描 PCL 所在文件夹中是否有 MC 文件夹失败")
End Try
'扫描官启文件夹
Dim MojangPath As String = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\"
If (CacheMcFolderList.Count = 0 OrElse MojangPath <> CacheMcFolderList(0).Path) AndAlso '当前文件夹不是官启文件夹
CheckPermission(MojangPath) AndAlso Directory.Exists(MojangPath & "versions\") Then '具有权限且存在 versions 文件夹
If (Not CacheMcFolderList.Any OrElse MojangPath <> CacheMcFolderList(0).Path) AndAlso '当前文件夹不是官启文件夹
Directory.Exists(MojangPath & "versions\") Then '具有权限且存在 versions 文件夹
CacheMcFolderList.Add(New McFolder With {.Name = "官方启动器文件夹", .Path = MojangPath, .Type = McFolderType.Original})
End If
@@ -61,7 +65,7 @@
'格式:TMZ 12>C://xxx/xx/|Test>D://xxx/xx/|名称>路径
For Each Folder As String In Setup.Get("LaunchFolders").Split("|")
If Folder = "" Then Continue For
If Not Folder.Contains(">") OrElse Not Folder.EndsWith("\") Then
If Not Folder.Contains(">") OrElse Not Folder.EndsWithF("\") Then
Hint("无效的 Minecraft 文件夹:" & Folder, HintType.Critical)
Continue For
End If
@@ -88,13 +92,13 @@
For Each Folder As McFolder In CacheMcFolderList
If Not Folder.Type = McFolderType.Original Then NewSetup.Add(Folder.Name & ">" & Folder.Path)
Next
If NewSetup.Count = 0 Then NewSetup.Add("") '防止 0 元素 Join 返回 Nothing
If Not NewSetup.Any() Then NewSetup.Add("") '防止 0 元素 Join 返回 Nothing
Setup.Set("LaunchFolders", Join(NewSetup, "|"))
#End Region
'若没有可用文件夹,则创建 .minecraft
If CacheMcFolderList.Count = 0 Then
If Not CacheMcFolderList.Any() Then
Directory.CreateDirectory(Path & ".minecraft\versions\")
CacheMcFolderList.Add(New McFolder With {.Name = "当前文件夹", .Path = Path & ".minecraft\", .Type = McFolderType.Original})
End If
@@ -145,7 +149,7 @@
#Region "版本处理"
Public Const McVersionCacheVersion As Integer = 26
Public Const McVersionCacheVersion As Integer = 27
Private _McVersionCurrent As McVersion
Private _McVersionLast = 0 '为 0 以保证与 Nothing 不相同,使得 UI 显示可以正常初始化
@@ -177,7 +181,7 @@
If AniControlEnabled = 0 AndAlso
Setup.Get("VersionServerAuthServer", Version:=value) <> Setup.Get("CacheAuthServerServer") AndAlso
Setup.Get("VersionServerLogin", Version:=value) = 4 Then
Setup.Set("CacheNideServer", "")
Setup.Set("CacheAuthAccess", "")
Log("[Launch] 服务器改变,要求重新登录 Authlib-Injector")
End If
If Setup.Get("VersionServerLogin", Version:=value) = 4 Then
@@ -212,8 +216,8 @@
'尚未判断
Dim ModFolder As New DirectoryInfo(Path & "mods\")
Dim SaveFolder As New DirectoryInfo(Path & "saves\")
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Count > 0) OrElse
(SaveFolder.Exists AndAlso SaveFolder.EnumerateFiles.Count > 0) Then
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Any) OrElse
(SaveFolder.Exists AndAlso SaveFolder.EnumerateFiles.Any) Then
'自动开启
Setup.Set("VersionArgumentIndie", 1, Version:=Me)
Log("[Setup] 已自动开启单版本隔离:" & Name)
@@ -406,7 +410,7 @@
End If
'无法获取
_Version.McName = "Unknown"
Info = "PCL 无法识别该版本,请向作者反馈此问题"
Info = "PCL 无法识别该版本的 MC 版本号"
Catch ex As Exception
Log(ex, "识别 Minecraft 版本时出错")
_Version.McName = "Unknown"
@@ -414,7 +418,7 @@
End Try
VersionSearchFinish:
'获取版本号
If _Version.McName.StartsWith("1.") Then
If _Version.McName.StartsWithF("1.") Then
Dim SplitVersion = _Version.McName.Split(" "c, "_"c, "-"c, "."c)
Dim SplitResult As String
'分割获取信息
@@ -542,8 +546,8 @@ Recheck:
'处理 JumpLoader
If Text.Contains("minecraftforge") AndAlso File.Exists(PathIndie & "config\jumploader.json") Then
For Each ModFile In Directory.EnumerateFiles(PathIndie & "mods")
Dim FileName As String = GetFileNameFromPath(ModFile).ToLower
If FileName.EndsWith(".jar") AndAlso FileName.Contains("jumploader") Then
Dim FileName As String = GetFileNameFromPath(ModFile)
If FileName.EndsWithF(".jar", True) AndAlso FileName.ContainsF("jumploader", True) Then
Log("[Minecraft] 发现 JumpLoader 分支项:" & FileName)
HasJumpLoader = True
Exit For
@@ -608,7 +612,7 @@ Recheck:
Public Sub New(Path As String)
Me.Path = If(Path.Contains(":"), "", PathMcFolder & "versions\") & '补全完整路径
Path &
If(Path.EndsWith("\"), "", "\") '补全右划线
If(Path.EndsWithF("\"), "", "\") '补全右划线
End Sub
''' <summary>
@@ -680,7 +684,7 @@ Recheck:
'愚人节与快照版本
If If(JsonObject("type"), "").ToString = "fool" OrElse GetMcFoolName(Version.McName) <> "" Then
State = McVersionState.Fool
ElseIf Version.McName.ToLower.Contains("w") OrElse Name.ToLower.Contains("combat") OrElse Version.McName.ToLower.Contains("rc") OrElse Version.McName.ToLower.Contains("pre") OrElse Version.McName.Contains("experimental") OrElse If(JsonObject("type"), "").ToString = "snapshot" OrElse If(JsonObject("type"), "").ToString = "pending" Then
ElseIf Version.McName.ContainsF("w", True) OrElse Name.ContainsF("combat", True) OrElse Version.McName.ContainsF("rc", True) OrElse Version.McName.ContainsF("pre", True) OrElse Version.McName.ContainsF("experimental", True) OrElse If(JsonObject("type"), "").ToString = "snapshot" OrElse If(JsonObject("type"), "").ToString = "pending" Then
State = McVersionState.Snapshot
End If
'OptiFine
@@ -740,9 +744,9 @@ ExitDataLoad:
If CustomInfo = "" Then
Select Case State
Case McVersionState.Snapshot
If Version.McName.ToLower.Contains("pre") Then
If Version.McName.ContainsF("pre", True) Then
Info = "预发布版 " & Version.McName
ElseIf Version.McName.ToLower.Contains("rc") Then
ElseIf Version.McName.ContainsF("rc", True) Then
Info = "发布候选 " & Version.McName
ElseIf Version.McName.Contains("experimental") OrElse Version.McName = "pending" Then
Info = "实验性快照"
@@ -944,8 +948,8 @@ ExitDataLoad:
(Asc(CType(Left(OptiFineVersion.ToUpper, 1), Char)) - Asc("A"c) + 1) * 10000 + '第二段:字母编号(2 位),如 G2 中的 G(7)
Val(RegexSeek(Right(OptiFineVersion, OptiFineVersion.Length - 1), "[0-9]+")) * 100 '第三段:末尾数字(2 位),如 C5 beta4 中的 5
'第三段:测试标记
If OptiFineVersion.ToLower.Contains("pre") Then _SortCode += 50
If OptiFineVersion.ToLower.Contains("pre") OrElse OptiFineVersion.ToLower.Contains("beta") Then
If OptiFineVersion.ContainsF("pre", True) Then _SortCode += 50
If OptiFineVersion.ContainsF("pre", True) OrElse OptiFineVersion.ContainsF("beta", True) Then
If Val(Right(OptiFineVersion, 1)) = 0 AndAlso Right(OptiFineVersion, 1) <> "0" Then
_SortCode += 1 '为 pre 或 beta 结尾,视作 1
Else
@@ -977,9 +981,9 @@ ExitDataLoad:
''' </summary>
Public Function GetMcFoolName(Name As String) As String
Name = Name.ToLower
If Name.StartsWith("2.0") Then
If Name.StartsWithF("2.0") Then
Return "这个秘密计划了两年的更新将游戏推向了一个新高度!"
ElseIf Name.StartsWith("20w14inf") OrElse Name = "20w14∞" Then
ElseIf Name.StartsWithF("20w14inf") OrElse Name = "20w14∞" Then
Return "我们加入了 20 亿个新的维度,让无限的想象变成了现实!"
ElseIf Name = "15w14a" Then
Return "作为一款全年龄向的游戏,我们需要和平,需要爱与拥抱。"
@@ -990,7 +994,9 @@ ExitDataLoad:
ElseIf Name = "22w13oneblockatatime" Then
Return "一次一个方块更新!迎接全新的挖掘、合成与骑乘玩法吧!"
ElseIf Name = "23w13a_or_b" Then
Return "研究表明玩家喜欢作出选择——越多越好!"
Return "研究表明:玩家喜欢作出选择——越多越好!"
ElseIf Name = "24w14potato" Then
Return "毒马铃薯一直都被大家忽视和低估,于是我们超级加强了它!"
Else
Return ""
End If
@@ -1014,6 +1020,12 @@ ExitDataLoad:
''' </summary>
Public McVersionListLoader As New LoaderTask(Of String, Integer)("Minecraft Version List", AddressOf McVersionListLoad) With {.ReloadTimeout = 1}
''' <summary>
''' 是否为本次打开 PCL 后第一次加载版本列表。
''' 这会清理所有 .pclignore 文件,而非跳过这些对应版本。
''' </summary>
Private IsFirstMcVersionListLoad As Boolean = True
''' <summary>
''' 开始加载当前 Minecraft 文件夹的版本列表。
''' </summary>
@@ -1036,7 +1048,7 @@ ExitDataLoad:
End Try
End If
'没有可用版本
If FolderList.Count = 0 Then
If Not FolderList.Any() Then
WriteIni(Path & "PCL.ini", "VersionCache", "") '清空缓存
GoTo OnLoaded
End If
@@ -1058,6 +1070,7 @@ Reload:
WriteIni(Path & "PCL.ini", "VersionCache", FolderListCheck)
McVersionList = McVersionListLoadNoCache(Path)
End If
IsFirstMcVersionListLoad = False
If Loader.IsAborted Then Exit Sub
'改变当前选择的版本
@@ -1110,14 +1123,20 @@ OnLoaded:
'循环读取版本
For Each Folder As String In ReadIni(Path & "PCL.ini", "CardValue" & (i + 1), ":").Split(":")
If Folder = "" Then Continue For
If File.Exists(Path & "versions\" & Folder & "\.pclignore") Then
Log("[Minecraft] 跳过要求忽略的项目:" & Path & "versions\" & Folder)
Continue For
Dim VersionFolder As String = $"{Path}versions\{Folder}\"
If File.Exists(VersionFolder & ".pclignore") Then
If IsFirstMcVersionListLoad Then
Log("[Minecraft] 清理残留的忽略项目:" & VersionFolder) '#2781
File.Delete(VersionFolder & ".pclignore")
Else
Log("[Minecraft] 跳过要求忽略的项目:" & VersionFolder)
Continue For
End If
End If
Try
'读取单个版本
Dim Version As New McVersion(Path & "versions\" & Folder & "\")
Dim Version As New McVersion(VersionFolder)
VersionList.Add(Version)
Version.Info = ReadIni(Version.Path & "PCL\Setup.ini", "CustomInfo", "")
If Version.Info = "" Then Version.Info = ReadIni(Version.Path & "PCL\Setup.ini", "Info", Version.Info)
@@ -1189,11 +1208,17 @@ OnLoaded:
Log("[Minecraft] 跳过可能不是版本文件夹的项目:" & Folder.FullName)
Continue For
End If
If File.Exists(Folder.FullName & "\.pclignore") Then
Log("[Minecraft] 跳过要求忽略的项目:" & Folder.FullName)
Continue For
Dim VersionFolder As String = Folder.FullName & "\"
If File.Exists(VersionFolder & ".pclignore") Then
If IsFirstMcVersionListLoad Then
Log("[Minecraft] 清理残留的忽略项目:" & VersionFolder) '#2781
File.Delete(VersionFolder & ".pclignore")
Else
Log("[Minecraft] 跳过要求忽略的项目:" & VersionFolder)
Continue For
End If
End If
Dim Version As New McVersion(Folder.FullName & "\")
Dim Version As New McVersion(VersionFolder)
VersionList.Add(Version)
Version.Load()
Next
@@ -1209,7 +1234,7 @@ OnLoaded:
For Each Version As McVersion In VersionList
If Version.IsStar AndAlso Not Version.DisplayType = McVersionCardType.Hidden Then StaredVersions.Add(Version)
Next
If StaredVersions.Count > 0 Then VersionListOriginal.Add(McVersionCardType.Star, StaredVersions)
If StaredVersions.Any Then VersionListOriginal.Add(McVersionCardType.Star, StaredVersions)
'预先筛选出愚人节的版本
McVersionFilter(VersionList, VersionListOriginal, {McVersionState.Error}, McVersionCardType.Error)
@@ -1283,8 +1308,8 @@ OnLoaded:
'将剩余的东西添加进去
VersionRubbish.AddRange(VersionList)
If VersionUseful.Count > 0 Then VersionListOriginal.Add(McVersionCardType.OriginalLike, VersionUseful)
If VersionRubbish.Count > 0 Then VersionListOriginal.Add(McVersionCardType.Rubbish, VersionRubbish)
If VersionUseful.Any Then VersionListOriginal.Add(McVersionCardType.OriginalLike, VersionUseful)
If VersionRubbish.Any Then VersionListOriginal.Add(McVersionCardType.Rubbish, VersionRubbish)
'按照自定义版本分类重新添加
For Each VersionPair In VersionListOriginal
@@ -1404,7 +1429,7 @@ OnLoaded:
NextVersion:
Next
'加入版本列表,并从剩余中删除
If KeepList.Count > 0 Then
If KeepList.Any Then
Target.Add(CardType, KeepList)
For Each Version As McVersion In KeepList
VersionList.Remove(Version)
@@ -1425,7 +1450,7 @@ NextVersion:
Next
NextVersion:
Next
If KeepList.Count > 0 Then
If KeepList.Any Then
For Each Version As McVersion In KeepList
VersionList.Remove(Version)
Next
@@ -1490,7 +1515,7 @@ NextVersion:
''' </summary>
Public Function McSkinGetAddress(Uuid As String, Type As String) As String
If Uuid = "" Then Throw New Exception("Uuid 为空。")
If Uuid.StartsWith("000000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。")
If Uuid.StartsWithF("00000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。")
'尝试读取缓存
Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid)
If Not CacheSkinAddress = "" Then Return CacheSkinAddress
@@ -1915,7 +1940,7 @@ NextVersion:
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByDownload({"https://download.mcbbs.net/mirrors/authlib-injector/artifact/latest.json", "https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"}, IsJson:=True))
DownloadInfo = GetJson(NetGetCodeByDownload({"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
@@ -1926,9 +1951,7 @@ NextVersion:
'开始下载
Dim DownloadAddress As String = DownloadInfo("download_url")
Log("[Minecraft] Authlib-Injector 需要更新:" & DownloadAddress, LogLevel.Developer)
Result.Add(New NetFile({
DownloadAddress.Replace("bmclapi2.bangbang93.com", "download.mcbbs.net"), DownloadAddress
}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
Result.Add(New NetFile({DownloadAddress}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
End If
End If
End If
@@ -1958,7 +1981,7 @@ NextVersion:
'获取 Url 的真实地址
Urls.Add(Token.Url)
If Token.Url.Contains("launcher.mojang.com/v1/objects") Then Urls = DlSourceLauncherOrMetaGet(Token.Url).ToList() 'Mappings
If Token.Url.Contains("maven") Then Urls.Insert(0, Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOf("maven")), "https://download.mcbbs.net/").Replace("maven.fabricmc.net", "maven").Replace("maven.minecraftforge.net", "maven"))
If Token.Url.Contains("maven") Then Urls.Insert(0, Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOfF("maven")), "https://bmclapi2.bangbang93.com/").Replace("maven.fabricmc.net", "maven").Replace("maven.minecraftforge.net", "maven"))
End If
If Token.LocalPath.Contains("transformer-discovery-service") Then
'Transformer 文件释放
@@ -1970,7 +1993,6 @@ NextVersion:
Dim OptiFineBase As String = Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries\optifine\OptiFine\", "").Split("_")(0) & "/" & GetFileNameFromPath(Token.LocalPath).Replace("-", "_")
OptiFineBase = "/maven/com/optifine/" & OptiFineBase
If OptiFineBase.Contains("_pre") Then OptiFineBase = OptiFineBase.Replace("com/optifine/", "com/optifine/preview_")
Urls.Add("https://download.mcbbs.net" & OptiFineBase)
Urls.Add("https://bmclapi2.bangbang93.com" & OptiFineBase)
ElseIf Urls.Count <= 2 Then
'普通文件
@@ -1989,10 +2011,6 @@ NextVersion:
Public Function McLibGet(Original As String, Optional WithHead As Boolean = True, Optional IgnoreLiteLoader As Boolean = False, Optional CustomMcFolder As String = Nothing) As String
CustomMcFolder = If(CustomMcFolder, PathMcFolder)
Dim Splited = Original.Split(":")
'If Original.ToLower.Contains("xray") OrElse Original.ToLower.Contains("rift") OrElse Original.ToLower.Contains("mixin") OrElse Original.Contains("net.minecraftforge:forge") OrElse Splited(2).Contains("beta") OrElse (IgnoreLiteLoader AndAlso Original.Contains("liteloader")) Then
'ElseIf Splited(2).Contains("-") Then
' Log("[Launch] 可能存在分段问题的支持库:" & Original)
'End If
McLibGet = If(WithHead, CustomMcFolder & "libraries\", "") &
Splited(0).Replace(".", "\") & "\" & Splited(1) & "\" & Splited(2) & "\" & Splited(1) & "-" & Splited(2) & ".jar"
'判断 OptiFine 是否应该使用 installer
@@ -2030,8 +2048,7 @@ NextVersion:
If Version.InheritVersion = "" Then Exit Do
Version = New McVersion(PathMcFolder & "versions\" & Version.InheritVersion)
Loop
Catch ex As Exception
Log(ex, "获取资源文件索引下载地址失败")
Catch
End Try
'无法获取到下载地址
If ReturnLegacyOnError Then
@@ -2221,10 +2238,11 @@ NextVersion:
'弹窗结果
If MsgResult = 2 Then
'下载
RunInUi(Sub()
PageDownloadInstall.McVersionWaitingForSelect = VersionName
FrmMain.PageChange(FormMain.PageType.Download, FormMain.PageSubType.DownloadInstall)
End Sub)
RunInUi(
Sub()
PageDownloadInstall.McVersionWaitingForSelect = VersionName
FrmMain.PageChange(FormMain.PageType.Download, FormMain.PageSubType.DownloadInstall)
End Sub)
End If
Catch ex As Exception
@@ -2249,8 +2267,10 @@ NextVersion:
If Left = "未知版本" AndAlso Right = "未知版本" Then Return 0
If Left <> "未知版本" AndAlso Right = "未知版本" Then Return -1
End If
Dim Lefts = RegexSearch(Left.ToLower.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Dim Rights = RegexSearch(Right.ToLower.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Left = Left.ToLowerInvariant
Right = Right.ToLowerInvariant
Dim Lefts = RegexSearch(Left.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Dim Rights = RegexSearch(Right.Replace("快照", "snapshot"), "[a-z]+|[0-9]+")
Dim i As Integer = 0
While True
'两边均缺失,感觉是一个东西
+322 -207
View File
@@ -13,6 +13,14 @@ Public Module ModMod
Public Sub New(Path As String)
Me.Path = If(Path, "")
End Sub
''' <summary>
''' Mod 的完整路径,去除最后的 .disabled 和 .old。
''' </summary>
Public ReadOnly Property RawPath As String
Get
Return GetPathFromFullPath(Path) & RawFileName
End Get
End Property
''' <summary>
''' Mod 的完整文件名。
@@ -40,7 +48,7 @@ Public Module ModMod
Load()
If Not IsFileAvailable Then
Return McModState.Unavaliable
ElseIf Path.EndsWith(".disabled") OrElse Path.EndsWith(".old") Then
ElseIf Path.EndsWithF(".disabled", True) OrElse Path.EndsWithF(".old", True) Then
Return McModState.Disabled
Else
Return McModState.Fine
@@ -68,7 +76,7 @@ Public Module ModMod
Return _Name
End Get
Set(value As String)
If _Name Is Nothing AndAlso value IsNot Nothing AndAlso
If _Name Is Nothing AndAlso value IsNot Nothing AndAlso Not value.Contains("modname") AndAlso
value.ToLower <> "name" AndAlso value.Count > 1 AndAlso Val(value).ToString <> value Then
_Name = value
End If
@@ -105,12 +113,12 @@ Public Module ModMod
Return _Version
End Get
Set(value As String)
If _Version IsNot Nothing AndAlso (_Version.Contains(".") OrElse _Version.Contains("-")) Then Exit Property
If value IsNot Nothing AndAlso value.ToLower.Contains("version") Then value = "version" '需要修改的标识
If _Version IsNot Nothing AndAlso RegexCheck(_Version, "[0-9.\-]+") Then Return
If value?.ContainsF("version", True) Then value = "version" '需要修改的标识
_Version = value
End Set
End Property
Private _Version As String = Nothing
Public _Version As String = Nothing
''' <summary>
''' 用于依赖检查的 ModID。
@@ -121,12 +129,12 @@ Public Module ModMod
Return _ModId
End Get
Set(value As String)
If value Is Nothing Then Exit Property
value = RegexSeek(value.ToLower, "[0-9a-z_-]+")
If value IsNot Nothing AndAlso value.ToLower <> "name" AndAlso value.Count > 1 AndAlso Val(value).ToString <> value Then
If Not PossibleModId.Contains(value) Then PossibleModId.Add(value)
If _ModId Is Nothing Then _ModId = value
End If
If value Is Nothing Then Return
value = RegexSeek(value, "[0-9a-zA-Z_-]+")
If value Is Nothing OrElse value.Count <= 1 OrElse Val(value).ToString = value Then Return
If value.ContainsF("name", True) OrElse value.ContainsF("modid", True) Then Return
If Not PossibleModId.Contains(value) Then PossibleModId.Add(value)
If _ModId Is Nothing Then _ModId = value
End Set
End Property
Private _ModId As String = Nothing
@@ -144,7 +152,7 @@ Public Module ModMod
Return _Url
End Get
Set(value As String)
If _Url Is Nothing AndAlso value IsNot Nothing AndAlso value.StartsWith("http") Then
If _Url Is Nothing AndAlso value IsNot Nothing AndAlso value.StartsWithF("http") Then
_Url = value
End If
End Set
@@ -185,7 +193,7 @@ Public Module ModMod
If VersionRequirement Is Nothing OrElse ((Not VersionRequirement.Contains(".")) AndAlso (Not VersionRequirement.Contains("-"))) OrElse VersionRequirement.Contains("$") Then
VersionRequirement = Nothing
Else
If (Not VersionRequirement.StartsWith("[")) AndAlso (Not VersionRequirement.StartsWith("(")) AndAlso (Not VersionRequirement.EndsWith("]")) AndAlso (Not VersionRequirement.EndsWith(")")) Then VersionRequirement = "[" & VersionRequirement & ",)"
If (Not VersionRequirement.StartsWithF("[")) AndAlso (Not VersionRequirement.StartsWithF("(")) AndAlso (Not VersionRequirement.EndsWithF("]")) AndAlso (Not VersionRequirement.EndsWithF(")")) Then VersionRequirement = "[" & VersionRequirement & ",)"
End If
'向依赖项中添加
If _Dependencies.ContainsKey(ModID) Then
@@ -262,7 +270,6 @@ Public Module ModMod
_Dependencies = New Dictionary(Of String, String)
IsLoaded = False
_FileUnavailableReason = Nothing
IsInfoWithoutClassAvailable = False
IsInfoWithClassLoaded = False
IsInfoWithClassAvailable = False
End Sub
@@ -276,15 +283,12 @@ Public Module ModMod
Init()
Dim Jar As ZipArchive = Nothing
Try
'阶段 1:基础可用性检查、打开 Jar 文件
'基础可用性检查、打开 Jar 文件
If Path.Length < 2 Then Throw New FileNotFoundException("错误的 Mod 文件路径(" & If(Path, "null") & ")")
If Not File.Exists(Path) Then Throw New FileNotFoundException("未找到 Mod 文件(" & Path & ")")
Jar = New ZipArchive(New FileStream(Path, FileMode.Open))
If Jar.Entries.Count = 0 Then Throw New FileFormatException("文件内容为空")
'阶段 2:信息获取
LoadWithoutClass(Jar)
'阶段 3: Class 信息获取
If Not IsInfoWithoutClassAvailable Then LoadWithClass(Jar)
'信息获取
LookupMetadata(Jar)
Catch ex As UnauthorizedAccessException
Log(ex, "Mod 文件由于无权限无法打开(" & Path & ")", LogLevel.Developer)
_FileUnavailableReason = New UnauthorizedAccessException("没有读取此文件的权限,请尝试右键以管理员身份运行 PCL", ex)
@@ -299,9 +303,9 @@ Public Module ModMod
End Sub
''' <summary>
''' 进行不使用 .class 文件的信息获取。
''' 从 jar 文件中获取 Mod 信息。
''' </summary>
Private Sub LoadWithoutClass(Jar As ZipArchive)
Private Sub LookupMetadata(Jar As ZipArchive)
#Region "尝试使用 mcmod.info"
Try
@@ -333,13 +337,13 @@ Public Module ModMod
For Each Token In AuthorJson
Author.Add(Token.ToString)
Next
If Author.Count > 0 Then Authors = Join(Author, ", ")
If Author.Any Then Authors = Join(Author, ", ")
End If
Dim Reqs As JArray = InfoObject("requiredMods")
If Reqs IsNot Nothing Then
For Each Token As String In Reqs
If Not String.IsNullOrEmpty(Token) Then
Token = Token.Substring(Token.IndexOf(":") + 1)
Token = Token.Substring(Token.IndexOfF(":") + 1)
If Token.Contains("@") Then
AddDependency(Token.Split("@")(0), Token.Split("@")(1))
Else
@@ -352,7 +356,7 @@ Public Module ModMod
If Reqs IsNot Nothing Then
For Each Token As String In Reqs
If Not String.IsNullOrEmpty(Token) Then
Token = Token.Substring(Token.IndexOf(":") + 1)
Token = Token.Substring(Token.IndexOfF(":") + 1)
If Token.Contains("@") Then
AddDependency(Token.Split("@")(0), Token.Split("@")(1))
Else
@@ -389,7 +393,7 @@ GotFabric:
For Each Token In AuthorJson
Author.Add(Token.ToString)
Next
If Author.Count > 0 Then Authors = Join(Author, ", ")
If Author.Any Then Authors = Join(Author, ", ")
End If
'If (Not FabricObject.ContainsKey("serverSideOnly")) OrElse FabricObject("serverSideOnly")("value").ToObject(Of Boolean) = False Then
' '添加 Minecraft 依赖
@@ -399,8 +403,8 @@ GotFabric:
' Dim Deps As String = If(If(FabricObject("dependencies") IsNot Nothing, FabricObject("dependencies")("value"), ""), "")
' If Deps <> "" Then
' For Each Dep In Deps.Split(";")
' If Dep = "" OrElse Not Dep.StartsWith("required-") Then Continue For
' Dep = Dep.Substring(Dep.IndexOf(":") + 1)
' If Dep = "" OrElse Not Dep.StartsWithF("required-") Then Continue For
' Dep = Dep.Substring(Dep.IndexOfF(":") + 1)
' If Dep.Contains("@") Then
' AddDependency(Dep.Split("@")(0), Dep.Split("@")(1))
' Else
@@ -428,40 +432,40 @@ GotFabric:
'文件标准化:统一换行符为 vbLf,去除注释、头尾的空格、空行
Dim Lines As New List(Of String)
For Each Line In TomlText.Replace(vbCrLf, vbLf).Replace(vbCr, vbLf).Split(vbLf) '统一换行符
If Line.StartsWith("#") Then '去除注释
If Line.StartsWithF("#") Then '去除注释
Continue For
ElseIf Line.Contains("#") Then
Line = Line.Substring(0, Line.IndexOf("#"))
Line = Line.Substring(0, Line.IndexOfF("#"))
End If
Line = Line.Trim(New Char() {" "c, " "c, " "c}) '去除头尾的空格
If Line.Count > 0 Then Lines.Add(Line) '去除空行
If Line.Any Then Lines.Add(Line) '去除空行
Next
'读取文件数据
Dim TomlData As New List(Of KeyValuePair(Of String, Dictionary(Of String, Object))) From {New KeyValuePair(Of String, Dictionary(Of String, Object))("", New Dictionary(Of String, Object))}
For i = 0 To Lines.Count - 1
Dim Line As String = Lines(i)
If Line.StartsWith("[") AndAlso Line.EndsWith("]") Then
If Line.StartsWithF("[") AndAlso Line.EndsWithF("]") Then
'段落标记
Dim Header = Line.Trim("[]".ToCharArray)
TomlData.Add(New KeyValuePair(Of String, Dictionary(Of String, Object))(Header, New Dictionary(Of String, Object)))
ElseIf Line.Contains("=") Then
'字段标记
Dim Key As String = Line.Substring(0, Line.IndexOf("=")).TrimEnd(New Char() {" "c, " "c, " "c})
Dim RawValue As String = Line.Substring(Line.IndexOf("=") + 1).TrimStart(New Char() {" "c, " "c, " "c})
Dim Key As String = Line.Substring(0, Line.IndexOfF("=")).TrimEnd(New Char() {" "c, " "c, " "c})
Dim RawValue As String = Line.Substring(Line.IndexOfF("=") + 1).TrimStart(New Char() {" "c, " "c, " "c})
Dim Value As Object
If RawValue.StartsWith("""") AndAlso RawValue.EndsWith("""") Then
If RawValue.StartsWithF("""") AndAlso RawValue.EndsWithF("""") Then
'单行字符串
Value = RawValue.Trim("""")
ElseIf RawValue.StartsWith("'''") Then
ElseIf RawValue.StartsWithF("'''") Then
'多行字符串
Dim ValueLines As New List(Of String) From {RawValue.TrimStart("'")}
If ValueLines(0).EndsWith("'''") Then '把多行字符串按单行写法写的错误处理(#2732)
If ValueLines(0).EndsWithF("'''") Then '把多行字符串按单行写法写的错误处理(#2732)
ValueLines(0) = ValueLines(0).TrimEnd("'")
Else
Do Until i >= Lines.Count - 1
i += 1
Dim ValueLine As String = Lines(i)
If ValueLine.EndsWith("'''") Then
If ValueLine.EndsWithF("'''") Then
ValueLines.Add(ValueLine.TrimEnd("'"))
Exit Do
Else
@@ -567,8 +571,8 @@ Got:
Dim Deps As String = If(If(FmlObject("dependencies") IsNot Nothing, FmlObject("dependencies")("value"), ""), "")
If Deps <> "" Then
For Each Dep In Deps.Split(";")
If Dep = "" OrElse Not Dep.StartsWith("required-") Then Continue For
Dep = Dep.Substring(Dep.IndexOf(":") + 1)
If Dep = "" OrElse Not Dep.StartsWithF("required-") Then Continue For
Dep = Dep.Substring(Dep.IndexOfF(":") + 1)
If Dep.Contains("@") Then
AddDependency(Dep.Split("@")(0), Dep.Split("@")(1))
Else
@@ -589,7 +593,7 @@ Finished:
If MetaEntry IsNot Nothing Then
Dim MetaString As String = ReadFile(MetaEntry.Open()).Replace(" :", ":").Replace(": ", ":")
If MetaString.Contains("Implementation-Version:") Then
MetaString = MetaString.Substring(MetaString.IndexOf("Implementation-Version:") + "Implementation-Version:".Count)
MetaString = MetaString.Substring(MetaString.IndexOfF("Implementation-Version:") + "Implementation-Version:".Count)
MetaString = MetaString.Substring(0, MetaString.IndexOfAny(vbCrLf.ToCharArray)).Trim
Version = MetaString
End If
@@ -602,97 +606,17 @@ Finished:
If _Version IsNot Nothing AndAlso Not (_Version.Contains(".") OrElse _Version.Contains("-")) Then Version = Nothing
#End Region
IsInfoWithoutClassAvailable = _ModId IsNot Nothing AndAlso _Version IsNot Nothing
End Sub
''' <summary>
''' 进行使用 .class 文件的信息获取。
''' </summary>
Private Sub LoadWithClass(Jar As ZipArchive)
Try
'查找入口点文件
Dim ModClass As String = Nothing
Dim ModClassNotBest As String = Nothing '非完美匹配
For Each Entry In Jar.Entries
If Entry.Name.EndsWith(".class") Then
Dim Temp As String = ReadFile(Entry.Open()).ToLower
If Temp.Contains("#lnet/minecraftforge/fml/common/mod;") Then
ModClass = Temp
Exit For
ElseIf Temp.Contains("modid") Then
ModClassNotBest = Temp
End If
End If
Next
If ModClass Is Nothing Then ModClass = ModClassNotBest
If ModClass Is Nothing Then Throw New FileNotFoundException("未找到 Mod 入口点")
ModClass = ModClass.Replace("ljava/lang/string;", "")
If ModClass.Count > 3000 Then ModClass = ModClass.Substring(0, 3000) '如果文件过大,截取前 3000 Byte
Dim IndexHead As Integer, IndexTail As Integer, IncreaseCount As Integer
'获取 ModID
If _ModId Is Nothing Then
IndexHead = ModClass.IndexOf("modid") + "modid".Length + 1
IncreaseCount = 0
Do While Convert.ToInt32(ModClass(IndexHead)) < 32
IndexHead += 1
IncreaseCount += 1
If IncreaseCount > 10 Then Throw New Exception("ModID 头匹配失败")
Loop
IndexTail = IndexHead + 1
IncreaseCount = 0
Do Until Convert.ToInt32(ModClass(IndexTail)) < 32
IndexTail += 1
IncreaseCount += 1
If IncreaseCount > 50 Then Throw New Exception("ModID 尾匹配失败")
Loop
ModId = ModClass.Substring(IndexHead, IndexTail - IndexHead)
End If
'获取 Version
If _Version Is Nothing AndAlso ModClass.Contains("version") Then
IndexHead = ModClass.IndexOf("version") + "version".Length + 1
IncreaseCount = 0
Do While Convert.ToInt32(ModClass(IndexHead)) < 32
IndexHead += 1
IncreaseCount += 1
If IncreaseCount > 10 Then GoTo VersionFindFail
Loop
IndexTail = IndexHead + 1
IncreaseCount = 0
Do While ModClass(IndexTail) = "."c OrElse ModClass(IndexTail) = "-"c OrElse
(ModClass(IndexTail) >= "0"c AndAlso ModClass(IndexTail) <= "9"c) OrElse
(ModClass(IndexTail) >= "a"c AndAlso ModClass(IndexTail) <= "z"c)
IndexTail += 1
IncreaseCount += 1
If IncreaseCount > 50 Then GoTo VersionFindFail
Loop
_Version = ModClass.Substring(IndexHead, IndexTail - IndexHead)
End If
VersionFindFail:
'获取 Dependencies
IndexHead = ModClass.IndexOf("dependencies")
If IndexHead > 0 Then
If ModClass.Count >= IndexHead + 300 Then ModClass = ModClass.Substring(IndexHead, 299)
Dim Deps As List(Of String) = RegexSearch(ModClass, "(?<=required-((before|after|before-client|after-client)?):)[0-9a-z]+(@[\(\[]{1}[0-9.,]+[\)\]]{1})?")
For Each Token As String In Deps
If Not String.IsNullOrEmpty(Token) Then
If Token.Contains("@") Then
AddDependency(Token.Split("@")(0), Token.Split("@")(1))
Else
AddDependency(Token)
End If
End If
Next
End If
Catch ex As Exception
Log(ex, "Mod Class 信息不可用(" & If(Path, "null") & ")", LogLevel.Normal)
End Try
IsInfoWithClassAvailable = _ModId IsNot Nothing AndAlso _Version IsNot Nothing
End Sub
#End Region
#Region "网络信息"
''' <summary>
''' 当任何网络信息更新时触发。
''' </summary>
Public Event OnCompUpdate(sender As McMod)
''' <summary>
''' 该 Mod 关联的网络项目。
''' </summary>
@@ -702,12 +626,70 @@ VersionFindFail:
End Get
Set(value As CompProject)
_Comp = value
RaiseEvent OnGetCompProject(Me)
RaiseEvent OnCompUpdate(Me)
End Set
End Property
Private _Comp As CompProject
Public IsCompFromModrinth = False
Public Event OnGetCompProject(sender As McMod)
''' <summary>
''' 本地文件对应的联网文件信息。
''' </summary>
Public CompFile As CompFile
''' <summary>
''' 该 Mod 对应的联网最新版本。
''' </summary>
Public Property UpdateFile As CompFile
Get
Return _UpdateFile
End Get
Set(value As CompFile)
_UpdateFile = value
RaiseEvent OnCompUpdate(Me)
End Set
End Property
Private _UpdateFile As CompFile
''' <summary>
''' 该 Mod 的更新日志网址。
''' </summary>
Public ChangelogUrls As New List(Of String)
''' <summary>
''' 所有网络信息是否已成功加载。
''' </summary>
Public CompLoaded As Boolean = False
''' <summary>
''' 将网络信息保存为 Json。
''' </summary>
Public Function ToJson() As JObject
Dim Json As New JObject
If Comp IsNot Nothing Then Json.Add("Comp", Comp.ToJson())
Json.Add("ChangelogUrls", New JArray(ChangelogUrls))
Json.Add("CompLoaded", CompLoaded)
If CompFile IsNot Nothing Then Json.Add("CompFile", CompFile.ToJson())
If UpdateFile IsNot Nothing Then Json.Add("UpdateFile", UpdateFile.ToJson())
Return Json
End Function
''' <summary>
''' 从 Json 中读取网络信息。
''' </summary>
Public Sub FromJson(Json As JObject)
CompLoaded = Json("CompLoaded")
If Json.ContainsKey("Comp") Then Comp = New CompProject(Json("Comp"))
If Json.ContainsKey("ChangelogUrls") Then ChangelogUrls = Json("ChangelogUrls").ToObject(Of List(Of String))
If Json.ContainsKey("CompFile") Then CompFile = New CompFile(Json("CompFile"), CompType.Mod)
If Json.ContainsKey("UpdateFile") Then UpdateFile = New CompFile(Json("UpdateFile"), CompType.Mod)
End Sub
''' <summary>
''' 该文件是否可以更新。
''' </summary>
Public ReadOnly Property CanUpdate As Boolean
Get
Return ChangelogUrls.Any()
End Get
End Property
''' <summary>
''' 获取用于 CurseForge 信息获取的 Hash 值(MurmurHash2)。
@@ -715,6 +697,14 @@ VersionFindFail:
Public ReadOnly Property CurseForgeHash As UInteger
Get
If _CurseForgeHash Is Nothing Then
'读取缓存
Dim Info As New FileInfo(Path)
Dim CacheKey As String = GetHash($"{RawPath}-{Info.LastWriteTime.ToLongTimeString}-{Info.Length}-C")
Dim Cached As String = ReadIni(PathTemp & "Cache\ModHash.ini", CacheKey)
If Cached <> "" Then
_CurseForgeHash = Cached
Return _CurseForgeHash
End If
'读取文件
Dim data As New List(Of Byte)
For Each b As Byte In File.ReadAllBytes(Path)
@@ -749,6 +739,8 @@ VersionFindFail:
h = (h * &H5BD1E995L) And &HFFFFFFFFL
h = h Xor (h >> 15)
_CurseForgeHash = h
'写入缓存
WriteIni(PathTemp & "Cache\ModHash.ini", CacheKey, h.ToString)
End If
Return _CurseForgeHash
End Get
@@ -761,20 +753,43 @@ VersionFindFail:
Public ReadOnly Property ModrinthHash As String
Get
If _ModrinthHash Is Nothing Then
'读取缓存
Dim Info As New FileInfo(Path)
Dim CacheKey As String = GetHash($"{RawPath}-{Info.LastWriteTime.ToLongTimeString}-{Info.Length}-M")
Dim Cached As String = ReadIni(PathTemp & "Cache\ModHash.ini", CacheKey)
If Cached <> "" Then
_ModrinthHash = Cached
Return _ModrinthHash
End If
'计算 SHA1
_ModrinthHash = GetFileSHA1(Path)
'写入缓存
WriteIni(PathTemp & "Cache\ModHash.ini", CacheKey, _ModrinthHash)
End If
Return _ModrinthHash
End Get
End Property
Private _ModrinthHash As String
#End Region
#Region "API"
Public Overrides Function ToString() As String
Return $"{State} - {Path}"
End Function
Public Overrides Function Equals(obj As Object) As Boolean
Dim target = TryCast(obj, McMod)
Return target IsNot Nothing AndAlso Path = target.Path
End Function
#End Region
''' <summary>
''' 是否可能为前置 Mod。
''' </summary>
Public Function IsPresetMod() As Boolean
Return Dependencies.Count = 0 AndAlso Name IsNot Nothing AndAlso (Name.ToLower.Contains("core") OrElse Name.ToLower.Contains("lib"))
Return Not Dependencies.Any() AndAlso Name IsNot Nothing AndAlso (Name.ToLower.Contains("core") OrElse Name.ToLower.Contains("lib"))
End Function
''' <summary>
@@ -783,9 +798,9 @@ VersionFindFail:
Public Shared Function IsModFile(Path As String)
If Path Is Nothing OrElse Not Path.Contains(".") Then Return False
Path = Path.ToLower
If Path.EndsWith(".jar") OrElse Path.EndsWith(".zip") OrElse Path.EndsWith(".litemod") OrElse
Path.EndsWith(".jar.disabled") OrElse Path.EndsWith(".zip.disabled") OrElse Path.EndsWith(".litemod.disabled") OrElse
Path.EndsWith(".jar.old") OrElse Path.EndsWith(".zip.old") OrElse Path.EndsWith(".litemod.old") Then Return True
If Path.EndsWithF(".jar", True) OrElse Path.EndsWithF(".zip", True) OrElse Path.EndsWithF(".litemod", True) OrElse
Path.EndsWithF(".jar.disabled", True) OrElse Path.EndsWithF(".zip.disabled", True) OrElse Path.EndsWithF(".litemod.disabled", True) OrElse
Path.EndsWithF(".jar.old", True) OrElse Path.EndsWithF(".zip.old", True) OrElse Path.EndsWithF(".litemod.old", True) Then Return True
Return False
End Function
@@ -797,6 +812,20 @@ VersionFindFail:
Try
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.ShowProgress = False)
'等待 Mod 更新完成
If PageVersionMod.UpdatingVersions.Contains(Loader.Input) Then
Log($"[Mod] 等待 Mod 更新完成后才能继续加载 Mod 列表")
Try
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod")
Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input)
If Loader.IsAborted Then Exit Sub
Thread.Sleep(100)
Loop
Finally
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在加载 Mod 列表")
End Try
End If
'获取 Mod 文件夹下的可用文件列表
Dim ModFileList As New List(Of FileInfo)
If Directory.Exists(Loader.Input) Then
@@ -826,7 +855,7 @@ VersionFindFail:
If CacheContent <> "" Then
Cache = GetJson(CacheContent)
If Not Cache.ContainsKey("version") OrElse Cache("version").ToObject(Of Integer) <> LocalModCacheVersion Then
Log($"[Mod] 本地 Mod 信息缓存版本已过期,将弃用这些缓存信息")
Log($"[Mod] 本地 Mod 信息缓存版本已过期,将弃用这些缓存信息", LogLevel.Debug)
Cache = New JObject
End If
End If
@@ -839,20 +868,30 @@ VersionFindFail:
Dim ModList As New List(Of McMod)
Dim ModUpdateList As New List(Of McMod)
For Each ModFile As FileInfo In ModFileList
Loader.Progress += 0.95 / ModFileList.Count
Loader.Progress += 0.94 / ModFileList.Count
If Loader.IsAborted Then Exit Sub
'加载 McMod 对象
Dim ModEntry As New McMod(ModFile.FullName)
ModEntry.Load()
Dim DumpMod As McMod = ModList.FirstOrDefault(Function(m) m.RawFileName = ModEntry.RawFileName)
If DumpMod IsNot Nothing Then
Dim DisabledMod As McMod = If(DumpMod.State = McMod.McModState.Disabled, DumpMod, ModEntry)
Log($"[Mod] 重复的 Mod 文件:{DumpMod.FileName} 与 {ModEntry.FileName},已忽略 {DisabledMod.FileName}", LogLevel.Debug)
If DisabledMod Is ModEntry Then
Continue For
Else
ModList.Remove(DisabledMod)
ModUpdateList.Remove(DisabledMod)
End If
End If
ModList.Add(ModEntry)
'读取 Comp 缓存
If ModEntry.State = McMod.McModState.Unavaliable Then Continue For
Dim Hash = ModEntry.ModrinthHash
If Cache.ContainsKey(Hash) Then
ModEntry.Comp = New CompProject(Cache(Hash))
ModEntry.IsCompFromModrinth = Not ModEntry.Comp.FromCurseForge
ModEntry.FromJson(Cache(Hash))
'如果缓存中的信息在 6 小时以内更新过,则无需重新获取
If Date.Now - Cache(Hash)("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For
If ModEntry.CompLoaded AndAlso Date.Now - Cache(Hash)("Comp")("CacheTime").ToObject(Of Date) < New TimeSpan(6, 0, 0) Then Continue For
End If
ModUpdateList.Add(ModEntry)
Next
@@ -860,13 +899,14 @@ VersionFindFail:
Log($"[Mod] 共有 {ModList.Count} 个 Mod,其中 {ModUpdateList.Where(Function(m) m.Comp Is Nothing).Count} 个需要联网获取信息,{ModUpdateList.Where(Function(m) m.Comp IsNot Nothing).Count} 个需要更新信息")
'排序
ModList = Sort(ModList, Function(Left As McMod, Right As McMod) As Boolean
If (Left.State = McMod.McModState.Unavaliable) <> (Right.State = McMod.McModState.Unavaliable) Then
Return Left.State = McMod.McModState.Unavaliable
Else
Return Not Right.FileName.CompareTo(Left.FileName)
End If
End Function)
ModList = Sort(ModList,
Function(Left As McMod, Right As McMod) As Boolean
If (Left.State = McMod.McModState.Unavaliable) <> (Right.State = McMod.McModState.Unavaliable) Then
Return Left.State = McMod.McModState.Unavaliable
Else
Return Not Right.FileName.CompareTo(Left.FileName)
End If
End Function)
'回设
If Loader.IsAborted Then Exit Sub
@@ -874,10 +914,10 @@ VersionFindFail:
'开始联网加载
If ModUpdateList.Any() Then
'TODO: 添加信息获取中提示
McModDetailLoader.Start(New KeyValuePair(Of List(Of McMod), JObject)(ModUpdateList, Cache), IsForceRestart:=True)
End If
Loader.Progress = 1
Catch ex As Exception
Log(ex, "Mod 列表加载失败", LogLevel.Debug)
Throw
@@ -885,29 +925,31 @@ VersionFindFail:
End Sub
'联网加载 Mod 详情
Private Const LocalModCacheVersion As Integer = 1
Private Const LocalModCacheVersion As Integer = 3
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
Dim Cache As JObject = Loader.Input.Value
'获取作为检查目标的加载器和版本
Dim TargetMcVersion As McVersionInfo = PageVersionLeft.Version.Version
Dim ModLoaders As New List(Of String)
If TargetMcVersion.HasForge Then ModLoaders.Add("forge")
If TargetMcVersion.HasFabric Then ModLoaders.Add("fabric")
If TargetMcVersion.HasLiteLoader Then ModLoaders.Add("liteloader")
If Not ModLoaders.Any() Then ModLoaders.AddRange({"forge", "fabric", "liteloader"})
Dim ModLoaders As New List(Of CompModLoaderType)
If TargetMcVersion.HasForge Then ModLoaders.Add(CompModLoaderType.Forge)
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}
If TargetMcVersion.McCodeMain > 0 AndAlso TargetMcVersion.McCodeMain < 99 Then
McVersions.Add($"1.{TargetMcVersion.McCodeMain}")
For i = 1 To TargetMcVersion.McCodeSub
McVersions.Add($"1.{TargetMcVersion.McCodeMain}.{i}")
Next
End If
McVersions = McVersions.Distinct().ToList()
'暂不向下扩展检查的 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
' McVersions.Add($"1.{TargetMcVersion.McCodeMain}")
' For i = 1 To TargetMcVersion.McCodeSub
' McVersions.Add($"1.{TargetMcVersion.McCodeMain}.{i}")
' Next
'End If
'McVersions = McVersions.Distinct().ToList()
'开始网络获取
Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersions.Join("/")}")
Dim CompletedThread As Integer = 0
Dim EndedThreadCount As Integer = 0, SucceedThreadCount As Integer = 0
Dim MainThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息
RunInNewThread(
@@ -915,25 +957,25 @@ VersionFindFail:
Try
'步骤 1:获取 Hash 与对应的工程 ID
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
Dim ModrinthUpdate = CType(GetJson(NetRequestRetry("https://api.modrinth.com/v2/version_files/update", "POST",
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1"",
""loaders"": [""{ModLoaders.Join(""",""")}""],""game_versions"": [""{McVersions.Join(""",""")}""]}}", "application/json")), JObject)
Log($"[Mod] 从 Modrinth 获取到 {ModrinthUpdate.Count} 个本地 Mod 的对应信息")
Dim ModrinthVersion = CType(GetJson(NetRequestRetry("https://api.modrinth.com/v2/version_files", "POST",
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject)
Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 Mod 的对应关系
If ModrinthUpdate.Count = 0 Then Exit Sub
If ModrinthVersion.Count = 0 Then Exit Sub
Dim ModrinthMapping As New Dictionary(Of String, List(Of McMod))
For Each ModEntity In Mods
If Not ModrinthUpdate.ContainsKey(ModEntity.ModrinthHash) Then Continue For
Dim ProjectId = ModrinthUpdate(ModEntity.ModrinthHash)("project_id").ToString
If CompProjectCache.ContainsKey(ProjectId) Then
ModEntity.Comp = CompProjectCache(ProjectId)
Else
If Not ModrinthMapping.ContainsKey(ProjectId) Then ModrinthMapping(ProjectId) = New List(Of McMod)
ModrinthMapping(ProjectId).Add(ModEntity)
End If
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 CompProjectCache.ContainsKey(ProjectId) AndAlso Entry.Comp Is Nothing Then Entry.Comp = CompProjectCache(ProjectId) '读取已加载的缓存,加快结果出现速度
If Not ModrinthMapping.ContainsKey(ProjectId) Then ModrinthMapping(ProjectId) = New List(Of McMod)
ModrinthMapping(ProjectId).Add(Entry)
'记录对应的 CompFile
Dim File As New CompFile(ModrinthVersion(Entry.ModrinthHash), CompType.Mod)
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
Next
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Log($"[Mod] 读取缓存后还需要从 Modrinth 获取 {ModrinthMapping.Count} 类本地 Mod 的工程信息")
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息
If Not ModrinthMapping.Any() Then Exit Sub
Dim ModrinthProject = CType(GetJson(NetRequestRetry(
@@ -942,18 +984,37 @@ VersionFindFail:
For Each ProjectJson In ModrinthProject
Dim Project As New CompProject(ProjectJson)
For Each Entry In ModrinthMapping(Project.Id)
If Entry.Comp IsNot Nothing AndAlso Not Entry.IsCompFromModrinth Then
Project.LogoUrl = Entry.Comp.LogoUrl 'Modrinth 的部分 Logo 加载不出来
End If
Entry.IsCompFromModrinth = True
If Entry.Comp IsNot Nothing AndAlso Entry.Comp.FromCurseForge Then Project.LogoUrl = Entry.Comp.LogoUrl 'Modrinth 的部分 Logo 不是图片,如果可能,使用 CurseForge 的 Logo
Entry.Comp = Project
Next
Next
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)
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)
If Not UpdateFile.Available Then Continue For
If ModeDebug Then Log($"[Mod] 本地文件 {Entry.CompFile.FileName} 在 Modrinth 上的最新版为 {UpdateFile.FileName}")
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("")}")
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.UpdateFile = UpdateFile
End If
Next
Log($"[Mod] 从 Modrinth 获取本地 Mod 信息结束")
SucceedThreadCount += 1
Catch ex As Exception
Log(ex, "从 Modrinth 获取本地 Mod 信息失败")
Finally
CompletedThread += 1
EndedThreadCount += 1
End Try
End Sub, "Mod List Detail Loader Modrinth")
'从 CurseForge 获取信息
@@ -962,57 +1023,110 @@ VersionFindFail:
Try
'步骤 1:获取 Hash 与对应的工程 ID
Dim CurseForgeHashes As New List(Of UInteger)
For Each ModEntity In Mods
CurseForgeHashes.Add(ModEntity.CurseForgeHash)
For Each Entry In Mods
CurseForgeHashes.Add(Entry.CurseForgeHash)
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Next
Dim CurseForgeRaw = CType(CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/fingerprints/432/", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 Mod 的对应关系
If CurseForgeRaw.Count = 0 Then Exit Sub
If Not CurseForgeRaw.Any() Then Exit Sub
Dim CurseForgeMapping As New Dictionary(Of Integer, List(Of McMod))
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 CompProjectCache.ContainsKey(ProjectId) Then
Entry.Comp = CompProjectCache(ProjectId)
Else
If Not CurseForgeMapping.ContainsKey(ProjectId) Then CurseForgeMapping(ProjectId) = New List(Of McMod)
CurseForgeMapping(ProjectId).Add(Entry)
End If
If CompProjectCache.ContainsKey(ProjectId) AndAlso Entry.Comp Is Nothing Then Entry.Comp = CompProjectCache(ProjectId) '读取已加载的缓存,加快结果出现速度
If Not CurseForgeMapping.ContainsKey(ProjectId) Then CurseForgeMapping(ProjectId) = New List(Of McMod)
CurseForgeMapping(ProjectId).Add(Entry)
'记录对应的 CompFile
Dim File As New CompFile(Project("file"), CompType.Mod)
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
Next
Next
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Log($"[Mod] 读取缓存后还需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息
If Not CurseForgeMapping.Any() Then Exit Sub
Dim CurseForgeProject = CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods", "POST",
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject
If Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
'设置 Entry 中的工程信息
Dim Project As New CompProject(ProjectJson)
For Each Entry In CurseForgeMapping(Project.Id) '倒查防止 CurseForge 返回的内容有漏
If Entry.Comp IsNot Nothing AndAlso Entry.IsCompFromModrinth Then
If Entry.Comp IsNot Nothing AndAlso Not Entry.Comp.FromCurseForge Then
Entry.Comp.LogoUrl = Project.LogoUrl 'Modrinth 部分 Logo 加载不出来
Entry.Comp = Entry.Comp '再次触发修改事件
Continue For
End If
Entry.IsCompFromModrinth = False
Entry.Comp = Project
Next
'查找或许版本更新的文件列表
If ModLoaders.Count = 1 Then 'TODO: 结果有多个 ModLoader 时提示无法检测更新
Dim NewestVersion As String = Nothing
Dim NewestFileIds As New List(Of Integer)
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 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的,所以只需取第一个;如果需要检查多个 releaseType 下的文件,将 > -1 改为 = 1,但这应当并不会获取到更新的文件
If NewestVersion IsNot Nothing AndAlso VersionSortInteger(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 McMod)
UpdateFileIds(FileId).AddRange(CurseForgeMapping(Project.Id))
FileIdToProjectSlug(FileId) = Project.Slug
Next
End If
Next
Log($"[Mod] 从 CurseForge 获取本地 Mod 信息结束")
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息,需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
'步骤 4:获取更新文件信息
If Not UpdateFileIds.Any() Then Exit Sub
Dim CurseForgeFiles = CType(GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST",
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data")
Dim UpdateFiles As New Dictionary(Of McMod, CompFile)
For Each FileJson In CurseForgeFiles
Dim File As New CompFile(FileJson, CompType.Mod)
If Not File.Available Then Continue For
For Each Entry As McMod 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 McMod = Pair.Key
Dim UpdateFile As CompFile = Pair.Value
If ModeDebug Then Log($"[Mod] 本地文件 {Entry.CompFile.FileName} 在 CurseForge 上的最新版为 {UpdateFile.FileName}")
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://www.curseforge.com/minecraft/mc-mods/{FileIdToProjectSlug(UpdateFile.Id)}/files/{UpdateFile.Id}")
Entry.UpdateFile.DownloadUrls.AddRange(UpdateFile.DownloadUrls) '合并下载源
ElseIf Entry.UpdateFile Is Nothing OrElse UpdateFile.ReleaseDate > Entry.UpdateFile.ReleaseDate Then '替换
Entry.ChangelogUrls = New List(Of String) From {$"https://www.curseforge.com/minecraft/mc-mods/{FileIdToProjectSlug(UpdateFile.Id)}/files/{UpdateFile.Id}"}
Entry.UpdateFile = UpdateFile
End If
Next
Log($"[Mod] 从 CurseForge 获取 Mod 更新信息结束")
SucceedThreadCount += 1
Catch ex As Exception
Log(ex, "从 CurseForge 获取本地 Mod 信息失败")
Finally
CompletedThread += 1
EndedThreadCount += 1
End Try
End Sub, "Mod List Detail Loader CurseForge")
'等待线程结束
Do Until CompletedThread = 2
Do Until EndedThreadCount = 2
If Loader.IsAborted Then Exit Sub
Thread.Sleep(10)
Loop
@@ -1020,8 +1134,9 @@ VersionFindFail:
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
Log($"[Mod] 联网获取本地 Mod 信息完成,为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Exit Sub
For Each ModEntity In Mods
Cache(ModEntity.ModrinthHash) = ModEntity.Comp.ToJson()
For Each Entry In Mods 'TODO: Bookshelf 的 Logo 会在两个网站间横跳
Entry.CompLoaded = SucceedThreadCount = 2
Cache(Entry.ModrinthHash) = Entry.ToJson()
Next
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
End Sub
@@ -1051,12 +1166,12 @@ VersionFindFail:
If CurrentDependencies.ContainsKey(PossibleModId) Then
If CurrentDependencies(PossibleModId)(2) = 1 Then
Result.Add("重复添加了相同的 Mod,请尝试删除其中一个(ModID:" & PossibleModId & ")。" & vbCrLf &
" - " & ModEntity.FileName & vbCrLf &
" - " & CurrentDependencies(PossibleModId)(1))
" - " & ModEntity.FileName & vbCrLf &
" - " & CurrentDependencies(PossibleModId)(1))
Else
Log("[Minecraft] 由于可能有多个 ModID,跳过疑似的重复项(ModID:" & PossibleModId & ")。" & vbCrLf &
" - " & ModEntity.FileName & vbCrLf &
" - " & CurrentDependencies(PossibleModId)(1), LogLevel.Developer)
" - " & ModEntity.FileName & vbCrLf &
" - " & CurrentDependencies(PossibleModId)(1), LogLevel.Developer)
End If
Else
CurrentDependencies.Add(PossibleModId, {ModEntity.Version, ModEntity.FileName, ModEntity.PossibleModId.Count})
@@ -1074,8 +1189,8 @@ VersionFindFail:
If Dependency.Value IsNot Nothing Then
'获取分段后的详细版本信息
Dim ReqVersion As String = Dependency.Value
Dim ReqVersionHeadCanEqual As Boolean = ReqVersion.StartsWith("[")
Dim ReqVersionTailCanEqual As Boolean = ReqVersion.EndsWith("]")
Dim ReqVersionHeadCanEqual As Boolean = ReqVersion.StartsWithF("[")
Dim ReqVersionTailCanEqual As Boolean = ReqVersion.EndsWithF("]")
Dim ReqVersionHead As String
Dim ReqVersionTail As String
If ReqVersion.Contains(",") Then
@@ -1089,8 +1204,8 @@ VersionFindFail:
ReqVersionTailCanEqual = False
End If
End If
If ReqVersionHead.StartsWith("1.") AndAlso ReqVersionHead.Contains("-") Then ReqVersionHead = ReqVersionHead.Substring(ReqVersionHead.LastIndexOf("-") + 1)
If ReqVersionTail.StartsWith("1.") AndAlso ReqVersionTail.Contains("-") Then ReqVersionTail = ReqVersionTail.Substring(ReqVersionTail.LastIndexOf("-") + 1)
If ReqVersionHead.StartsWithF("1.") AndAlso ReqVersionHead.Contains("-") Then ReqVersionHead = ReqVersionHead.Substring(ReqVersionHead.LastIndexOfF("-") + 1)
If ReqVersionTail.StartsWithF("1.") AndAlso ReqVersionTail.Contains("-") Then ReqVersionTail = ReqVersionTail.Substring(ReqVersionTail.LastIndexOfF("-") + 1)
'获取报错描述文本
Dim VersionRequire As String
If ReqVersionHead = ReqVersionTail Then
@@ -1118,7 +1233,7 @@ VersionFindFail:
Continue For
End If
Dim CurrentVersion As String = If(CurrentDependencies(ReqId)(0), "0.0")
If CurrentVersion.StartsWith("1.") AndAlso CurrentVersion.Contains("-") Then CurrentVersion = CurrentVersion.Substring(CurrentVersion.LastIndexOf("-") + 1)
If CurrentVersion.StartsWithF("1.") AndAlso CurrentVersion.Contains("-") Then CurrentVersion = CurrentVersion.Substring(CurrentVersion.LastIndexOfF("-") + 1)
'对比前置 Mod 头部版本
If ReqVersionHead.Contains(".") Then
If VersionSortInteger(ReqVersionHead, CurrentVersion) > If(ReqVersionHeadCanEqual, 0, -1) Then
@@ -1147,7 +1262,7 @@ VersionFindFail:
Log(ex, "检查 Mod 时出错")
End Try
Next
If Result.Count = 0 Then
If Not Result.Any() Then
Log("[Minecraft] Mod 检查未发现异常")
Else
Log("[Minecraft] Mod 检查异常结果:" & vbCrLf & Join(Result, vbCrLf))
@@ -40,7 +40,7 @@ Public Module ModModpack
For Each Entry In Archive.Entries
Dim FullNames As String() = Entry.FullName.Split("/")
ArchiveBaseFolder = FullNames(0) & "/"
If Entry.FullName.EndsWith("/versions/") AndAlso FullNames.Count = 3 Then PackType = 9 : Exit Try '压缩包
If Entry.FullName.EndsWithF("/versions/") AndAlso FullNames.Count = 3 Then PackType = 9 : Exit Try '压缩包
'确定为一级目录下
If FullNames.Count <> 2 Then Continue For
'判断是否为关键文件
@@ -61,7 +61,7 @@ Public Module ModModpack
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
Log(ex, "打开整合包文件失败", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
ElseIf File.ToLower.EndsWith(".rar") Then
ElseIf File.EndsWithF(".rar", True) Then
Log(ex, "PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Else
@@ -186,7 +186,7 @@ Retry:
Dim FabricVersion As String = Nothing
For Each Entry In If(Json("minecraft")("modLoaders"), {})
Dim Id As String = If(Entry("id"), "").ToString.ToLower
If Id.StartsWith("forge-") Then
If Id.StartsWithF("forge-") Then
'Forge 指定
If Id.Contains("recommended") Then
Log("[ModPack] 该整合包版本过老,已不支持进行安装!", LogLevel.Hint)
@@ -199,7 +199,7 @@ Retry:
Catch ex As Exception
Log(ex, "读取整合包 Forge 版本失败:" & Id)
End Try
ElseIf Id.StartsWith("fabric-") Then
ElseIf Id.StartsWithF("fabric-") Then
'Fabric 指定
Try
Log("[ModPack] 整合包 Fabric 版本:" & Id)
@@ -244,16 +244,17 @@ Retry:
ModList.Add(ModEntry("fileID"))
If ModEntry("required") IsNot Nothing AndAlso Not ModEntry("required").ToObject(Of Boolean) Then ModOptionalList.Add(ModEntry("fileID"))
Next
If ModList.Count > 0 Then
If ModList.Any Then
Dim ModDownloadLoaders As New List(Of LoaderBase)
'获取 Mod 下载信息
InstallLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
Sub(Task As LoaderTask(Of Integer, JArray))
Task.Output = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data")
'如果文件已被删除,则 API 会跳过那一项
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包所需要的部分 Mod 版本已被 Mod 作者删除,因此无法完成整合包安装,请联系整合包作者更新整合包中的 Mod 版本")
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
'构造 NetFile
InstallLoaders.Add(New LoaderTask(Of JArray, List(Of NetFile))("构造 Mod 下载信息",
ModDownloadLoaders.Add(New LoaderTask(Of JArray, List(Of NetFile))("构造 Mod 下载信息",
Sub(Task As LoaderTask(Of JArray, List(Of NetFile)))
Dim FileList As New Dictionary(Of Integer, NetFile)
For Each ModJson In Task.Input
@@ -277,7 +278,7 @@ Retry:
IsResourcePack =
(Not ModuleNames.Contains("META-INF")) AndAlso (Not ModuleNames.Contains("mcmod.info")) AndAlso '不包含 META-INF 或 mcmod.info
ModuleNames.Contains("pack.mcmeta") AndAlso '包含 pack.mcmeta
(Not File.FileName.EndsWith(".jar")) '文件后缀不是 .jar
(Not File.FileName.EndsWithF(".jar", True)) '文件后缀不是 .jar
Else
IsResourcePack = False
End If
@@ -288,7 +289,10 @@ Retry:
Task.Output = FileList.Values.ToList
End Sub) With {.ProgressWeight = ModList.Count / 200, .Show = False}) '每 200 Mod 需要 1s
'下载 Mod 文件
InstallLoaders.Add(New LoaderDownload("下载 Mod", New List(Of NetFile)) With {.ProgressWeight = ModList.Count * 1.5}) '每个 Mod 需要 1.5s
ModDownloadLoaders.Add(New LoaderDownload("下载 Mod", New List(Of NetFile)) With {.ProgressWeight = ModList.Count * 1.5}) '每个 Mod 需要 1.5s
'构造加载器
InstallLoaders.Add(New LoaderCombo(Of Integer)("下载 Mod(主加载器)", ModDownloadLoaders) With
{.Show = False, .ProgressWeight = ModDownloadLoaders.Sum(Function(l) l.ProgressWeight)})
End If
'构造加载器
@@ -299,43 +303,35 @@ Retry:
.ForgeVersion = ForgeVersion,
.FabricVersion = FabricVersion
}
Dim InstallExpectTime As Double = 0
For Each InstallLoader In InstallLoaders
InstallExpectTime += InstallLoader.ProgressWeight
Next
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
Dim MergeExpectTime As Double = 0
For Each MergeLoader In MergeLoaders
MergeExpectTime += MergeLoader.ProgressWeight
Next
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
'构造 Libraries 加载器
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(VersionName))) With {.ProgressWeight = 1, .Show = False})
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
'构造总加载器
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallExpectTime})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeExpectTime})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
Loaders.Add(New LoaderTask(Of String, String)("最终整理文件",
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo:" & Logo)
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
End Sub) With {.ProgressWeight = 0.1, .Show = False})
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo:" & Logo)
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
End Sub) With {.ProgressWeight = 0.1, .Show = False})
'重复任务检查
Dim LoaderName As String = "CurseForge 整合包安装:" & VersionName & " "
@@ -438,10 +434,10 @@ Retry:
End If
'添加下载文件
FileList.Add(New NetFile(File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToArray, '修复 #2390
PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString)))
PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString), True))
Next
If FileList.Count > 0 Then
If FileList.Any Then
InstallLoaders.Add(New LoaderDownload("下载额外文件", FileList) With {.ProgressWeight = FileList.Count * 1.5}) '每个 Mod 需要 1.5s
End If
@@ -453,43 +449,35 @@ Retry:
.ForgeVersion = ForgeVersion,
.FabricVersion = FabricVersion
}
Dim InstallExpectTime As Double = 0
For Each InstallLoader In InstallLoaders
InstallExpectTime += InstallLoader.ProgressWeight
Next
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
Dim MergeExpectTime As Double = 0
For Each MergeLoader In MergeLoaders
MergeExpectTime += MergeLoader.ProgressWeight
Next
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
'构造 Libraries 加载器
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(VersionName))) With {.ProgressWeight = 1, .Show = False})
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
'构造总加载器
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallExpectTime})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeExpectTime})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
Loaders.Add(New LoaderTask(Of String, String)("最终整理文件",
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo:" & Logo)
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
End Sub) With {.ProgressWeight = 0.1, .Show = False})
Sub(Task As LoaderTask(Of String, String))
'设置图标
Dim VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\"
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
WriteIni(VersionFolder & "PCL\Setup.ini", "LogoCustom", "True")
Log("[ModPack] 已设置整合包 Logo:" & Logo)
End If
'删除原始整合包文件
For Each Target As String In {VersionFolder & "原始整合包.zip", VersionFolder & "原始整合包.mrpack"}
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[ModPack] 根据设置要求删除原始整合包文件:" & Target)
File.Delete(Target)
End If
Next
End Sub) With {.ProgressWeight = 0.1, .Show = False})
'重复任务检查
Dim LoaderName As String = "Modrinth 整合包安装:" & VersionName & " "
@@ -554,16 +542,8 @@ Retry:
.TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\",
.MinecraftName = Json("gameVersion").ToString
}
Dim InstallExpectTime As Double = 0
For Each InstallLoader In InstallLoaders
InstallExpectTime += InstallLoader.ProgressWeight
Next
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
Dim MergeExpectTime As Double = 0
For Each MergeLoader In MergeLoaders
MergeExpectTime += MergeLoader.ProgressWeight
Next
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json(副加载器)",
@@ -584,8 +564,8 @@ Retry:
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
'构造总加载器
Dim Loaders As New List(Of LoaderBase) From {
New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime},
New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime},
New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)},
New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)},
New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8}
}
@@ -704,24 +684,16 @@ Retry:
End Select
Next
'构造加载器
Dim InstallExpectTime As Double = 0
For Each InstallLoader In InstallLoaders
InstallExpectTime += InstallLoader.ProgressWeight
Next
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
Dim MergeExpectTime As Double = 0
For Each MergeLoader In MergeLoaders
MergeExpectTime += MergeLoader.ProgressWeight
Next
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
'构造 Libraries 加载器
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(VersionName))) With {.ProgressWeight = 1, .Show = False})
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
'构造总加载器
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
'重复任务检查
@@ -802,24 +774,16 @@ Retry:
.ForgeVersion = If(Addons.ContainsKey("forge"), Addons("forge"), Nothing),
.FabricVersion = If(Addons.ContainsKey("fabric"), Addons("fabric"), Nothing)
}
Dim InstallExpectTime As Double = 0
For Each InstallLoader In InstallLoaders
InstallExpectTime += InstallLoader.ProgressWeight
Next
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
Dim MergeExpectTime As Double = 0
For Each MergeLoader In MergeLoaders
MergeExpectTime += MergeLoader.ProgressWeight
Next
'构造 Libraries 加载器(为了使得 Mods 下载结束后再构造,这样才会下载 JumpLoader 文件)
'构造 Libraries 加载器
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(VersionName))) With {.ProgressWeight = 1, .Show = False})
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件(副加载器)", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
'构造总加载器
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
'重复任务检查
@@ -96,7 +96,7 @@
'设置窗口标题
For i = 1 To 3
If IsWindowFinished AndAlso IsWindowAppeared AndAlso WindowTitle <> "" AndAlso State = MinecraftState.Running AndAlso Not GameProcess.HasExited Then
Dim RealTitle As String = WindowTitle.Replace("{time}", Date.Now.ToShortTimeString)
Dim RealTitle As String = WindowTitle.Replace("{date}", Date.Now.ToString("yyyy/M/d")).Replace("{time}", Date.Now.ToString("HH:mm:ss"))
SetWindowText(WindowHandle, RealTitle.ToCharArray)
End If
Thread.Sleep(64)
@@ -143,7 +143,7 @@
'输出文本
Dim Copyed As New List(Of String)
SyncLock WaitingLogLock
If WaitingLog.Count = 0 Then Exit Sub
If Not WaitingLog.Any() Then Exit Sub
Copyed = WaitingLog
WaitingLog = New List(Of String)(1000)
End SyncLock
@@ -192,7 +192,7 @@
If LogProgress < 2 AndAlso Text.Contains("Setting user:") Then
WatcherLog("日志 2/5:游戏用户已设置") '仅确保支持 Minecraft 1.7+
LogProgress = 2
ElseIf LogProgress < 3 AndAlso Text.ToLower.Contains("lwjgl version") Then
ElseIf LogProgress < 3 AndAlso Text.ContainsF("lwjgl version", True) Then
WatcherLog("日志 3/5:LWJGL 版本已确认")
LogProgress = 3
ElseIf LogProgress < 4 AndAlso (Text.Contains("OpenAL initialized") OrElse Text.Contains("Starting up SoundSystem")) Then
@@ -269,24 +269,25 @@
If MinecraftWindow Is Nothing Then Exit Sub
Dim MinecraftWindowName = MinecraftWindow.Value.Value, MinecraftWindowHandle = MinecraftWindow.Value.Key
'已找到窗口
If Not MinecraftWindowName.StartsWith("FML") Then
If Not MinecraftWindowName.StartsWithF("FML") Then
'已找到 Minecraft 窗口
WindowHandle = MinecraftWindowHandle
WatcherLog($"Minecraft 窗口已加载:{MinecraftWindowName}({MinecraftWindowHandle.ToInt64})")
IsWindowFinished = True
'最大化
If Setup.Get("LaunchArgumentWindowType") = 4 Then
RunInNewThread(Sub()
Try
'如果最大化导致屏幕渲染大小不对,那是 MC 的 Bug,不是我的 Bug
'……虽然我很想这样说,但总有人反馈,算了
Thread.Sleep(2000)
ShowWindow(WindowHandle, 3)
WatcherLog($"已最大化 Minecraft 窗口:{MinecraftWindowHandle.ToInt64}")
Catch ex As Exception
Log(ex, "最大化 Minecraft 窗口时出现错误")
End Try
End Sub, "MinecraftWindowMaximize")
RunInNewThread(
Sub()
Try
'如果最大化导致屏幕渲染大小不对,那是 MC 的 Bug,不是我的 Bug
'……虽然我很想这样说,但总有人反馈,算了
Thread.Sleep(2000)
ShowWindow(WindowHandle, 3)
WatcherLog($"已最大化 Minecraft 窗口:{MinecraftWindowHandle.ToInt64}")
Catch ex As Exception
Log(ex, "最大化 Minecraft 窗口时出现错误")
End Try
End Sub, "MinecraftWindowMaximize")
End If
ElseIf Not IsWindowAppeared Then
'已找到 FML 窗口
@@ -317,7 +318,7 @@
Dim WindowText As String = str.ToString
'有的 Mod 可以修改窗口标题,所以不能检测是否为 Minecraft 打头,这并不准确
'部分版本会搞个 GLFW message window 出来所以得反选
If Not (WindowText.StartsWith("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWith("GLFW")) Then Exit Sub
If Not (WindowText.StartsWithF("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWithF("GLFW")) Then Exit Sub
'获取窗口关联的进程
Dim ProcessId As Integer
GetWindowThreadProcessId(hwnd, ProcessId)
@@ -14,11 +14,11 @@
_Logo = value
Dim FileAddress = PathTemp & "CompLogo\" & GetHash(_Logo) & ".png"
Try
If _Logo.ToLower.StartsWith("http") Then
If _Logo.StartsWithF("http", True) Then
'网络图片
If File.Exists(FileAddress) Then
PathLogo.Source = New MyBitmap(FileAddress)
ElseIf _Logo.ToLower.EndsWith(".webp") Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
ElseIf _Logo.EndsWithF(".webp", True) Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
Log($"[Comp] 发现不支持的 WebP 格式图标,已更改为默认图标:{_Logo}")
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
Else
@@ -57,7 +57,7 @@ RetryStart:
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd)
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
@@ -1,8 +1,9 @@
<Grid x:Class="MyLocalModItem"
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
x:Name="PanBack" Height="44"
RenderTransformOrigin="0.5,0.5" Background="{StaticResource ColorBrushSemiTransparent}" SnapsToDevicePixels="True">
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:local="clr-namespace:PCL;assembly="
x:Name="PanBack" Height="44"
RenderTransformOrigin="0.5,0.5" Background="{StaticResource ColorBrushSemiTransparent}" SnapsToDevicePixels="True">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="6" />
<ColumnDefinition Width="34" />
@@ -19,7 +20,7 @@
</Grid.RowDefinitions>
<!-- Logo -->
<Border Grid.Column="1" Grid.Row="1" Grid.RowSpan="2" IsHitTestVisible="False" SnapsToDevicePixels="True" UseLayoutRounding="True"
HorizontalAlignment="Right" VerticalAlignment="Center" Width="34" Height="34">
HorizontalAlignment="Right" VerticalAlignment="Center" Width="34" Height="34">
<Border.Clip>
<RectangleGeometry Rect="0,0,34,34" RadiusX="6" RadiusY="6" />
</Border.Clip>
@@ -27,10 +28,26 @@
</Border>
<!-- 标题 -->
<StackPanel Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" Orientation="Horizontal"
IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False">
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" />
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
SnapsToDevicePixels="False" UseLayoutRounding="False">
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" IsHitTestVisible="False" />
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" IsHitTestVisible="False"
Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
<!-- 更新按钮 -->
<local:MyIconButton Width="21" Height="21" Margin="-2,-1.6,0,0" x:Name="BtnUpdate" Theme="Black" Opacity="0.4" Visibility="Collapsed"
ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="100" ToolTipService.VerticalOffset="-9"
Logo="M640 768H384l-32-32V509H213L190 454l298-298h45l298 298L810 509h-138v226z m-224-64h192V477l32-32h93L512 223 290 445H384l32 32zM352 831h320v64h-320z" />
</StackPanel>
<!--<Grid Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" />
<ColumnDefinition Width="Auto" />
</Grid.ColumnDefinitions>
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" Grid.Column="0" />
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" Grid.Column="1"
Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
<local:MyIconTextButton Grid.Column="2" Text="更新" />
</Grid>-->
<!-- Tag 与 详情 -->
<StackPanel x:Name="PanTags" Grid.Row="2" Grid.Column="3" Orientation="Horizontal" VerticalAlignment="Bottom" Margin="-1,0,1,0" Visibility="Collapsed" IsHitTestVisible="False">
<!--<Border Background="{DynamicResource ColorBrush6}" Padding="3,1" CornerRadius="3" Margin="0,0,4,0" SnapsToDevicePixels="True" UseLayoutRounding="False">
@@ -16,11 +16,11 @@ Public Class MyLocalModItem
_Logo = value
Dim FileAddress = PathTemp & "CompLogo\" & GetHash(_Logo) & ".png"
Try
If _Logo.ToLower.StartsWith("http") Then
If _Logo.StartsWithF("http", True) Then
'网络图片
If File.Exists(FileAddress) Then
PathLogo.Source = New MyBitmap(FileAddress)
ElseIf _Logo.ToLower.EndsWith(".webp") Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
ElseIf _Logo.EndsWithF(".webp", True) Then 'Modrinth 林业 Mod 使用了不支持的 WebP 格式 Logo
Log($"[LocalModItem] 发现不支持的 WebP 格式图标,已更改为默认图标:{_Logo}")
PathLogo.Source = New MyBitmap(PathImage & "Icons/NoIcon.png")
Else
@@ -59,7 +59,7 @@ RetryStart:
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd)
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
@@ -190,6 +190,39 @@ RetryStart:
If ButtonStack IsNot Nothing Then ButtonStack.IsHitTestVisible = True
End Sub
'滑动选中
Private Shared SwipeStart As Integer, SwipeEnd As Integer
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
'开始滑动
Dim Index = CType(Parent, StackPanel).Children.IndexOf(Me)
SwipeStart = Index
SwipeEnd = Index
Swiping = True
SwipToState = Not Checked
FrmVersionMod.CardSelect.IsHitTestVisible = False '暂时禁用下边栏
End Sub
Private Sub Button_MouseSwipe(sender As Object, e As Object) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonUp
'结束滑动
If Mouse.LeftButton <> MouseButtonState.Pressed OrElse Not Swiping Then
Swiping = False
FrmVersionMod.CardSelect.IsHitTestVisible = True
Exit Sub
End If
'计算滑动范围
Dim Index = CType(Parent, StackPanel).Children.IndexOf(Me)
SwipeStart = Math.Min(SwipeStart, Index)
SwipeEnd = Math.Max(SwipeEnd, Index)
'勾选所有范围中的项
If SwipeStart = SwipeEnd Then Exit Sub
For i = SwipeStart To SwipeEnd
Dim Item As MyLocalModItem = CType(Parent, StackPanel).Children(i)
Item.InitLate(Item, e)
Item.Checked = SwipToState
Next
End Sub
'勾选状态
Public Event Check(sender As Object, e As RouteEventArgs)
Public Event Changed(sender As Object, e As RouteEventArgs)
@@ -201,10 +234,10 @@ RetryStart:
Set(value As Boolean)
Try
'触发属性值修改
Dim ChangedEventArgs As New RouteEventArgs(False)
Dim RawValue = _Checked
If value = _Checked Then Exit Property
_Checked = value
Dim ChangedEventArgs As New RouteEventArgs(False)
If IsInitialized Then
RaiseEvent Changed(Me, ChangedEventArgs)
If ChangedEventArgs.Handled Then
@@ -310,7 +343,7 @@ RetryStart:
Children.Remove(ButtonStack)
ButtonStack = Nothing
End If
If value.Count = 0 Then Exit Property
If Not value.Any() Then Exit Property
'添加新 Stack
ButtonStack = New StackPanel With {.Opacity = 0, .Margin = New Thickness(0, 0, 5, 0), .SnapsToDevicePixels = False, .Orientation = Orientation.Horizontal,
.HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Center, .UseLayoutRounding = False}
@@ -347,6 +380,30 @@ RetryStart:
Public Sub Refresh()
RunInUi(
Sub()
'更新
If Entry.CanUpdate Then
BtnUpdate.Visibility = Visibility.Visible
Dim CurrentName = Entry.CompFile.FileName.Replace(".jar", "")
Dim NewestName = Entry.UpdateFile.FileName.Replace(".jar", "")
'简化名称对比
Dim CurrentSegs = CurrentName.Split("-"c).ToList()
Dim NewestSegs = NewestName.Split("-"c).ToList()
Dim Shortened As Boolean = False
For Each Seg In CurrentSegs.ToList()
If Not NewestSegs.Contains(Seg) Then Continue For
CurrentSegs.Remove(Seg)
NewestSegs.Remove(Seg)
Shortened = True
Next
If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then
CurrentName = Join(CurrentSegs, "-")
NewestName = Join(NewestSegs, "-")
Entry._Version = CurrentName '使用网络信息作为显示的版本号
End If
BtnUpdate.ToolTip = $"当前版本:{CurrentName} ({Entry.CompFile.ReleaseDate:yyyy/MM/dd HH:mm:ss}){vbCrLf}最新版本:{NewestName} ({Entry.UpdateFile.ReleaseDate:yyyy/MM/dd HH:mm:ss}){vbCrLf}点击以更新,右键查看更新日志。"
Else
BtnUpdate.Visibility = Visibility.Collapsed
End If
'标题
If Entry.Comp Is Nothing Then
Title = Entry.Name
@@ -390,9 +447,9 @@ RetryStart:
Else
If ImgState Is Nothing Then
ImgState = New Image With {
.Width = 20, .Height = 20, .Margin = New Thickness(0, 0, -5, -3), .IsHitTestVisible = False,
.HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Bottom
}
.Width = 20, .Height = 20, .Margin = New Thickness(0, 0, -5, -3), .IsHitTestVisible = False,
.HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Bottom
}
RenderOptions.SetBitmapScalingMode(ImgState, BitmapScalingMode.HighQuality)
SetColumn(ImgState, 1) : SetRow(ImgState, 1) : SetRowSpan(ImgState, 2)
Children.Add(ImgState)
@@ -409,11 +466,7 @@ RetryStart:
End Sub
Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp, Me.Changed
'按钮虚拟化检测
If ButtonHandler IsNot Nothing Then
ButtonHandler(sender, e)
ButtonHandler = Nothing
End If
InitLate(sender, e)
'触发颜色动画
Dim Time As Integer = If(IsMouseOver, 120, 180)
Dim Ani As New List(Of AniData)
@@ -422,19 +475,19 @@ RetryStart:
If IsMouseOver Then
Ani.Add(AaOpacity(ButtonStack, 1 - ButtonStack.Opacity, Time * 0.7, Time * 0.3))
Ani.Add(AaDouble(Sub(i) ColumnPaddingRight.Width = New GridLength(Math.Max(0, ColumnPaddingRight.Width.Value + i)),
5 + Buttons.Count * 25 - ColumnPaddingRight.Width.Value, Time * 0.3, Time * 0.7))
5 + Buttons.Count * 25 - ColumnPaddingRight.Width.Value, Time * 0.3, Time * 0.7))
Else
Ani.Add(AaOpacity(ButtonStack, -ButtonStack.Opacity, Time * 0.4))
Ani.Add(AaDouble(Sub(i) ColumnPaddingRight.Width = New GridLength(Math.Max(0, ColumnPaddingRight.Width.Value + i)),
4 - ColumnPaddingRight.Width.Value, Time * 0.4))
4 - ColumnPaddingRight.Width.Value, Time * 0.4))
End If
End If
'RectBack
If IsMouseOver OrElse Checked Then
Ani.AddRange({
AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time),
AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent)
})
AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time),
AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent)
})
If IsMouseDown Then
Ani.Add(AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent))
Else
@@ -442,12 +495,42 @@ RetryStart:
End If
Else
Ani.AddRange({
AaOpacity(RectBack, -RectBack.Opacity, Time),
AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent),
AaScaleTransform(RectBack, -0.196, 1,,, True)
})
AaOpacity(RectBack, -RectBack.Opacity, Time),
AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent),
AaScaleTransform(RectBack, -0.196, 1,,, True)
})
End If
AniStart(Ani, "LocalModItem Color " & Uuid)
End Sub
'触发虚拟化内容
Private Sub InitLate(sender As Object, e As EventArgs)
If ButtonHandler IsNot Nothing Then
ButtonHandler(sender, e)
ButtonHandler = Nothing
End If
End Sub
'显示更新日志
Private Sub ShowUpdateLog(sender As Object, e As MouseButtonEventArgs) Handles BtnUpdate.PreviewMouseRightButtonUp
e.Handled = True
Dim CurseForgeUrl As String = Entry.ChangelogUrls.FirstOrDefault(Function(x) x.Contains("curseforge.com"))
Dim ModrinthUrl As String = Entry.ChangelogUrls.FirstOrDefault(Function(x) x.Contains("modrinth.com"))
If CurseForgeUrl Is Nothing OrElse ModrinthUrl Is Nothing Then
OpenWebsite(Entry.ChangelogUrls.First)
Else
Select Case MyMsgBox("要在哪个网站上查看更新日志?", "查看更新日志", "Modrinth", "CurseForge", "取消")
Case 1
OpenWebsite(ModrinthUrl)
Case 2
OpenWebsite(CurseForgeUrl)
End Select
End If
End Sub
'触发更新
Private Sub BtnUpdate_Click(sender As Object, e As EventArgs) Handles BtnUpdate.Click
FrmVersionMod.UpdateMods({Entry})
End Sub
End Class
+4 -4
View File
@@ -13,7 +13,7 @@
Case "打开网页"
Data(0) = Data(0).Replace("\", "/")
If Not Data(0).Contains("://") OrElse Data(0).ToLower.StartsWith("file") Then '为了支持更多协议(#2200)
If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议(#2200)
MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序,请将 EventType 改为 打开文件。", "事件执行失败")
Exit Sub
End If
@@ -78,7 +78,7 @@
Case "下载文件"
Data(0) = Data(0).Replace("\", "/")
If Not (Data(0).StartsWith("http://") OrElse Data(0).StartsWith("https://")) Then
If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败")
Exit Sub
End If
@@ -99,7 +99,7 @@
Public Function GetEventAbsoluteUrls(RelativeUrl As String, EventType As String) As String()
'网页确认
If RelativeUrl.ToLower.StartsWith("http") Then
If RelativeUrl.StartsWithF("http", True) Then
If RunInUi() Then
Throw New Exception("MyListItem 在界面初始化时就需要获取帮助标题等信息,这会导致程序在网络请求时卡死。" & vbCrLf &
"因此,请换用 MyListItem 以外的控件(例如 MyButton)作为联网帮助页面的入口!")
@@ -108,7 +108,7 @@
Dim RawFileName As String
Try
RawFileName = GetFileNameFromPath(RelativeUrl)
If Not RawFileName.ToLower.EndsWith(".json") Then Throw New Exception("未指向 .json 后缀的文件")
If Not RawFileName.EndsWithF(".json", True) Then Throw New Exception("未指向 .json 后缀的文件")
Catch ex As Exception
Throw New Exception("联网帮助页面须指向一个帮助 JSON 文件,并在同路径下包含相应 XAML 文件!" & vbCrLf &
"例如:" & vbCrLf &
+15 -9
View File
@@ -1,4 +1,6 @@
Public Module ModMusic
Imports System.Security.Cryptography
Public Module ModMusic
#Region "播放列表"
@@ -25,13 +27,13 @@
For Each File In EnumerateFiles(Path & "PCL\Musics\")
'文件夹可能会被加入 .ini 文件夹配置文件、一些乱七八糟的 .jpg 文件啥的
Dim Ext As String = File.Extension.ToLower
If {"ini", "jpg", "txt", "cfg", "lrc", "db", "png"}.Contains(Ext) Then Continue For
If {".ini", ".jpg", ".txt", ".cfg", ".lrc", ".db", ".png"}.Contains(Ext) Then Continue For
MusicAllList.Add(File.FullName)
Next
End If
'打乱顺序播放
MusicWaitingList = If(Setup.Get("UiMusicRandom"), Shuffle(New List(Of String)(MusicAllList)), New List(Of String)(MusicAllList))
If Not IgnoreFirst = "" AndAlso Not MusicWaitingList.Count = 0 AndAlso MusicWaitingList(0) = IgnoreFirst Then
If Not IgnoreFirst = "" AndAlso Not Not MusicWaitingList.Any() AndAlso MusicWaitingList(0) = IgnoreFirst Then
'若需要避免成为第一项的为第一项,则将它放在最后
MusicWaitingList.RemoveAt(0)
MusicWaitingList.Add(IgnoreFirst)
@@ -45,11 +47,11 @@
''' </summary>
Private Function DequeueNextMusicAddress() As String
'初始化,确保存在音乐
If MusicAllList Is Nothing OrElse MusicAllList.Count = 0 OrElse MusicWaitingList.Count = 0 Then MusicListInit(False)
If MusicAllList Is Nothing OrElse Not MusicAllList.Any() OrElse Not MusicWaitingList.Any() Then MusicListInit(False)
'出列下一个音乐,如果出列结束则生成新列表
DequeueNextMusicAddress = MusicWaitingList(0)
MusicWaitingList.RemoveAt(0)
If MusicWaitingList.Count = 0 Then MusicListInit(False, DequeueNextMusicAddress)
If Not MusicWaitingList.Any() Then MusicListInit(False, DequeueNextMusicAddress)
End Function
#End Region
@@ -63,7 +65,7 @@
RunInUi(Sub()
Try
If MusicAllList.Count = 0 Then
If Not MusicAllList.Any() Then
'无背景音乐
FrmMain.BtnExtraMusic.Show = False
Else
@@ -160,7 +162,7 @@
Try
MusicListInit(True)
If MusicAllList.Count = 0 Then
If Not MusicAllList.Any() Then
If MusicNAudio Is Nothing Then
If ShowHint Then Hint("未检测到可用的背景音乐!", HintType.Critical)
Else
@@ -264,12 +266,16 @@
Thread.Sleep(100)
End While
'当前音乐已播放结束,继续下一曲
If CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped AndAlso MusicAllList.Count > 0 Then MusicStartPlay(DequeueNextMusicAddress)
If CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped AndAlso MusicAllList.Any Then MusicStartPlay(DequeueNextMusicAddress)
Catch ex As Exception
Log("[Music] 播放音乐失败的文件完整路径:" & MusicCurrent)
If TypeOf ex Is NAudio.MmException AndAlso (ex.Message.Contains("NoDriver") OrElse ex.Message.Contains("BadDeviceId")) Then
Hint("由于音频设备变更,音乐播放功能在重启 PCL 后才能恢复!", HintType.Critical)
Thread.Sleep(1000000000)
End If
If ex.Message.Contains("Got a frame at sample rate") OrElse ex.Message.Contains("does not support changes to") Then
Hint("播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & "):PCL 不支持播放音频属性在中途发生变化的音乐", HintType.Critical)
ElseIf Not (MusicCurrent.ToLower.EndsWith(".wav") OrElse MusicCurrent.ToLower.EndsWith(".mp3") OrElse MusicCurrent.ToLower.EndsWith(".flac")) Then
ElseIf Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) Then
Hint("播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & "):PCL 可能不支持此音乐格式,请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Critical)
Else
Log(ex, "播放音乐失败(" & GetFileNameFromPath(MusicCurrent) & ")", LogLevel.Hint)
@@ -8,11 +8,11 @@ Imports System.Runtime.InteropServices
'查看程序集特性的值
<Assembly: AssemblyTitle("Plain Craft Launcher 2 启动器")>
<Assembly: AssemblyTitle("Plain Craft Launcher 启动器")>
<Assembly: AssemblyDescription("Minecraft 启动器 (制作:龙腾猫跃)")>
<Assembly: AssemblyCompany("")>
<Assembly: AssemblyProduct("Plain Craft Launcher 2")>
<Assembly: AssemblyCopyright("Copyright © 龙腾猫跃 2016-2024. All Rights Reserved.")>
<Assembly: AssemblyProduct("Plain Craft Launcher")>
<Assembly: AssemblyCopyright("Copyright © 龙腾猫跃 2016. All Rights Reserved.")>
<Assembly: AssemblyConfiguration("PCL2 Config Mark")>
<Assembly: ComVisible(False)>
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.6.13.0")>
<Assembly: AssemblyFileVersion("2.6.13.0")>
<Assembly: AssemblyVersion("2.7.2.0")>
<Assembly: AssemblyFileVersion("2.7.2.0")>
<Assembly: NeutralResourcesLanguage("")>
File diff suppressed because it is too large. Load diff
@@ -39,7 +39,7 @@
Version("id") = "20w14∞"
Version("type") = "special"
Version.Add("lore", GetMcFoolName(Version("id")))
Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b"
Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b", "24w14potato"
Type = "愚人节版"
Version("type") = "special"
Version.Add("lore", GetMcFoolName(Version("id")))
@@ -77,7 +77,7 @@
PanMain.Children.Add(CardInfo)
'添加其他版本
For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict
If Pair.Value.Count = 0 Then Continue For
If Not Pair.Value.Any() Then Continue For
'增加卡片
Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 2}
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
@@ -16,7 +16,6 @@
<StackPanel Orientation="Horizontal" Height="35">
<local:MyButton x:Name="BtnIntroWeb" MinWidth="140" Text="转到 CurseForge" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" ColorType="Highlight" />
<local:MyButton x:Name="BtnIntroWiki" MinWidth="140" Text="转到 MC 百科" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" />
<local:MyButton x:Name="BtnIntroMCBBS" MinWidth="140" Text="转到 MCBBS" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" />
<local:MyButton x:Name="BtnIntroCopy" MinWidth="140" Text="复制名称" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" />
</StackPanel>
</StackPanel>
@@ -88,7 +88,7 @@
PanMain.Children.Clear()
'转化为 UI
For Each Pair As KeyValuePair(Of String, List(Of CompFile)) In Dict
If Pair.Value.Count = 0 Then Continue For
If Not Pair.Value.Any() Then Continue For
'增加卡片
Dim NewCard As New MyCard With {.Title = Pair.Key, .Margin = New Thickness(0, 0, 0, 15), .SwapType = If(Project.Type = CompType.ModPack, 9, 8)} 'FUTURE: Res
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
@@ -145,7 +145,6 @@
'决定按钮显示
BtnIntroWeb.Text = If(Project.FromCurseForge, "转到 CurseForge", "转到 Modrinth")
BtnIntroWiki.Visibility = If(Project.WikiId = 0, Visibility.Collapsed, Visibility.Visible)
BtnIntroMCBBS.Visibility = If(Project.MCBBS = 0, Visibility.Collapsed, Visibility.Visible)
AniControlEnabled -= 1
End Sub
@@ -211,10 +210,10 @@
If Project.Type = CompType.Mod Then
'获取 Mod 所需的加载器种类
Dim AllowForge As Boolean? = Nothing, AllowFabric As Boolean? = Nothing
If File.ModLoaders.Count > 0 Then '从文件中获取
If File.ModLoaders.Any Then '从文件中获取
AllowForge = File.ModLoaders.Contains(CompModLoaderType.Forge)
AllowFabric = File.ModLoaders.Contains(CompModLoaderType.Fabric)
ElseIf Project.ModLoaders.Count > 0 Then '从工程中获取
ElseIf Project.ModLoaders.Any Then '从工程中获取
AllowForge = Project.ModLoaders.Contains(CompModLoaderType.Forge)
AllowFabric = Project.ModLoaders.Contains(CompModLoaderType.Fabric)
End If
@@ -253,7 +252,7 @@
For Each Version As McVersion In McVersionList.Values.SelectMany(Function(l) l)
If IsVersionSuitable(Version) Then SuitableVersions.Add(Version)
Next
If SuitableVersions.Count = 0 Then
If Not SuitableVersions.Any() Then
DefaultFolder = PathMcFolder
If NeedLoad Then
Hint("当前 MC 文件夹中没有找到适合这个 Mod 的版本!")
@@ -323,9 +322,6 @@
Private Sub BtnIntroWiki_Click(sender As Object, e As EventArgs) Handles BtnIntroWiki.Click
OpenWebsite("https://www.mcmod.cn/class/" & Project.WikiId & ".html")
End Sub
Private Sub BtnIntroMCBBS_Click(sender As Object, e As EventArgs) Handles BtnIntroMCBBS.Click
OpenWebsite("https://www.mcbbs.net/thread-" & Project.MCBBS & "-1-1.html")
End Sub
Private Sub BtnIntroCopy_Click(sender As Object, e As EventArgs) Handles BtnIntroCopy.Click
ClipboardSet(CompItem.LabTitle.Text)
End Sub
@@ -20,7 +20,6 @@
<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="安装结束后,请在 Mod 下载中搜索 OptiFabric Origins 并下载,否则 OptiFine 会无法使用!" Margin="0,1,0,7" x:Name="HintOptiFabricOld" IsWarn="False" />
<Grid Margin="0,0,0,11">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="1*" />
@@ -32,7 +32,7 @@
#Region "页面切换"
'页面切换动画
Private IsInSelectPage As Boolean = False
Public IsInSelectPage As Boolean = False
Private IsFirstLoaded As Boolean = False
Private Sub EnterSelectPage()
If IsInSelectPage Then Exit Sub
@@ -273,11 +273,13 @@
End If
End Sub
Private IsReloading As Boolean = False '#3742 中,LoadOptiFineGetError 会初始化 LoadOptiFine,触发事件 LoadOptiFine.StateChanged,导致再次调用 SelectReload
''' <summary>
''' 重载已选择的项目的显示。
''' </summary>
Private Sub SelectReload() Handles CardOptiFine.Swap, LoadOptiFine.StateChanged, CardForge.Swap, LoadForge.StateChanged, CardFabric.Swap, LoadFabric.StateChanged, CardFabricApi.Swap, LoadFabricApi.StateChanged, CardOptiFabric.Swap, LoadOptiFabric.StateChanged, CardLiteLoader.Swap, LoadLiteLoader.StateChanged
If SelectedMinecraftId Is Nothing Then Exit Sub
If SelectedMinecraftId Is Nothing OrElse IsReloading Then Exit Sub
IsReloading = True
'主预览
SelectNameUpdate()
ItemSelect.Title = TextSelectName.Text
@@ -385,17 +387,12 @@
'主警告
HintFabricAPI.Visibility = If(SelectedFabric IsNot Nothing AndAlso SelectedFabricApi Is Nothing, Visibility.Visible, Visibility.Collapsed)
If SelectedFabric IsNot Nothing AndAlso SelectedOptiFine IsNot Nothing AndAlso SelectedOptiFabric Is Nothing Then
If SelectedMinecraftId.StartsWith("1.14") OrElse SelectedMinecraftId.StartsWith("1.15") Then
HintOptiFabric.Visibility = Visibility.Collapsed
HintOptiFabricOld.Visibility = Visibility.Visible
Else
HintOptiFabric.Visibility = Visibility.Visible
HintOptiFabricOld.Visibility = Visibility.Collapsed
End If
HintOptiFabric.Visibility = Visibility.Visible
Else
HintOptiFabric.Visibility = Visibility.Collapsed
HintOptiFabricOld.Visibility = Visibility.Collapsed
End If
'结束
IsReloading = False
End Sub
''' <summary>
''' 清空已选择的项目。
@@ -523,7 +520,7 @@
Version("id") = "20w14∞"
Version("type") = "special"
Version.Add("lore", GetMcFoolName(Version("id")))
Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b"
Case "3d shareware v1.34", "1.rv-pre1", "15w14a", "2.0", "22w13oneblockatatime", "23w13a_or_b", "24w14potato"
Type = "愚人节版"
Version("type") = "special"
Version.Add("lore", GetMcFoolName(Version("id")))
@@ -562,7 +559,7 @@
PanMinecraft.Children.Insert(0, CardInfo)
'添加其他版本
For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict
If Pair.Value.Count = 0 Then Continue For
If Not Pair.Value.Any() Then Continue For
'增加卡片
Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 7}
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
@@ -656,7 +653,7 @@
If SelectedForge IsNot Nothing AndAlso Not IsOptiFineSuitForForge(Version, SelectedForge) Then Continue For
If Version.NameDisplay.StartsWith(SelectedMinecraftId & " ") Then Versions.Add(Version)
Next
If Versions.Count = 0 Then Exit Sub
If Not Versions.Any() Then Exit Sub
'排序
Versions = Sort(Versions, Function(Left As DlOptiFineListEntry, Right As DlOptiFineListEntry) As Boolean
If Not Left.IsPreview AndAlso Right.IsPreview Then Return True
@@ -724,7 +721,7 @@
For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value
If Version.Inherit = SelectedMinecraftId Then Versions.Add(Version)
Next
If Versions.Count = 0 Then Exit Sub
If Not Versions.Any() Then Exit Sub
'可视化
PanLiteLoader.Children.Clear()
For Each Version In Versions
@@ -804,7 +801,7 @@
'获取要显示的版本
Dim Versions As New List(Of DlForgeVersionEntry)
Versions.AddRange(Loader.Output) '复制数组,以免 Output 在实例化后变空
If Loader.Output.Count = 0 Then Exit Sub
If Not Loader.Output.Any() Then Exit Sub
PanForge.Children.Clear()
Versions = Sort(Versions, Function(a, b) New Version(a.Version) > New Version(b.Version)).
Where(Function(v)
@@ -870,7 +867,7 @@
If DlFabricListLoader.State <> LoadState.Finished Then Exit Sub
'获取版本列表
Dim Versions As JArray = DlFabricListLoader.Output.Value("loader")
If Versions.Count = 0 Then Exit Sub
If Not Versions.Any() Then Exit Sub
'可视化
PanFabric.Children.Clear()
PanFabric.Tag = Versions
@@ -983,7 +980,7 @@
Versions.Add(Version)
End If
Next
If Versions.Count = 0 Then Exit Sub
If Not Versions.Any() Then Exit Sub
Versions = Sort(Versions, Function(a, b) a.ReleaseDate > b.ReleaseDate)
'可视化
PanFabricApi.Children.Clear()
@@ -1037,7 +1034,6 @@
''' 获取 OptiFabric 的加载异常信息。若正常则返回 Nothing。
''' </summary>
Private Function LoadOptiFabricGetError() As String
If SelectedMinecraftId.StartsWith("1.14") OrElse SelectedMinecraftId.StartsWith("1.15") Then Return "不兼容老版本 Fabric,请手动下载 OptiFabric Origins"
If LoadOptiFabric Is Nothing OrElse LoadOptiFabric.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "正在获取版本列表……"
If LoadOptiFabric.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败:" & CType(LoadOptiFabric.State, Object).Error.Message
If DlOptiFabricLoader.Output Is Nothing Then
@@ -1073,7 +1069,7 @@
For Each Version In DlOptiFabricLoader.Output
If IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Versions.Add(Version)
Next
If Versions.Count = 0 Then Exit Sub
If Not Versions.Any() Then Exit Sub
'排序
Versions = Sort(Versions, Function(a, b) a.ReleaseDate > b.ReleaseDate)
'可视化
@@ -28,7 +28,7 @@
PanMain.Children.Clear()
'转化为 UI
For Each Pair As KeyValuePair(Of String, List(Of DlLiteLoaderListEntry)) In Dict
If Pair.Value.Count = 0 Then Continue For
If Not Pair.Value.Any() Then Continue For
'增加卡片
Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 10}
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
@@ -33,22 +33,19 @@
<TextBlock VerticalAlignment="Center" Grid.Row="2" HorizontalAlignment="Left" Text="版本" Margin="0,0,18,0" />
<local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="1" Grid.ColumnSpan="2" IsEditable="True" MaxDropDownHeight="320">
<local:MyComboBoxItem Content="全部 (也可自行输入)" IsSelected="True" />
<local:MyComboBoxItem Content="1.20.6" />
<local:MyComboBoxItem Content="1.20.4" />
<local:MyComboBoxItem Content="1.20.3" />
<local:MyComboBoxItem Content="1.20.2" />
<local:MyComboBoxItem Content="1.20.1" />
<local:MyComboBoxItem Content="1.20" />
<local:MyComboBoxItem Content="1.19.4" />
<local:MyComboBoxItem Content="1.19.2" />
<local:MyComboBoxItem Content="1.18.2" />
<local:MyComboBoxItem Content="1.17.1" />
<local:MyComboBoxItem Content="1.16.5" />
<local:MyComboBoxItem Content="1.15.2" />
<local:MyComboBoxItem Content="1.14.4" />
<local:MyComboBoxItem Content="1.13.2" />
<local:MyComboBoxItem Content="1.12.2" />
<local:MyComboBoxItem Content="1.11.2" />
<local:MyComboBoxItem Content="1.10.2" />
<local:MyComboBoxItem Content="1.9.4" />
<local:MyComboBoxItem Content="1.8.9" />
<local:MyComboBoxItem Content="1.7.10" />
</local:MyComboBox>
@@ -32,7 +32,7 @@
PanMain.Children.Clear()
'转化为 UI
For Each Pair As KeyValuePair(Of String, List(Of DlOptiFineListEntry)) In Dict
If Pair.Value.Count = 0 Then Continue For
If Not Pair.Value.Any() Then Continue For
'增加卡片
Dim NewCard As New MyCard With {.Title = Pair.Key & " (" & Pair.Value.Count & ")", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 3}
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
@@ -32,22 +32,19 @@
<TextBlock VerticalAlignment="Center" Grid.Row="2" HorizontalAlignment="Left" Text="版本" Margin="0,0,18,0" />
<local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="1" IsEditable="True" MaxDropDownHeight="320">
<local:MyComboBoxItem Content="全部 (也可自行输入)" IsSelected="True" />
<local:MyComboBoxItem Content="1.20.6" />
<local:MyComboBoxItem Content="1.20.4" />
<local:MyComboBoxItem Content="1.20.3" />
<local:MyComboBoxItem Content="1.20.2" />
<local:MyComboBoxItem Content="1.20.1" />
<local:MyComboBoxItem Content="1.20" />
<local:MyComboBoxItem Content="1.19.4" />
<local:MyComboBoxItem Content="1.19.2" />
<local:MyComboBoxItem Content="1.18.2" />
<local:MyComboBoxItem Content="1.17.1" />
<local:MyComboBoxItem Content="1.16.5" />
<local:MyComboBoxItem Content="1.15.2" />
<local:MyComboBoxItem Content="1.14.4" />
<local:MyComboBoxItem Content="1.13.2" />
<local:MyComboBoxItem Content="1.12.2" />
<local:MyComboBoxItem Content="1.11.2" />
<local:MyComboBoxItem Content="1.10.2" />
<local:MyComboBoxItem Content="1.9.4" />
<local:MyComboBoxItem Content="1.8.9" />
<local:MyComboBoxItem Content="1.7.10" />
</local:MyComboBox>
@@ -33,7 +33,7 @@
<Path Name="PathTypeOne" HorizontalAlignment="Left" RenderTransformOrigin="0.5,0.5" Margin="12,0,0,0" Stretch="Uniform" Fill="{DynamicResource ColorBrush3}" MaxHeight="16" MaxWidth="16" VerticalAlignment="Center"
Data="">
<Path.RenderTransform>
<ScaleTransform ScaleX="1.2" ScaleY="1.2" />
<ScaleTransform ScaleX="1.05" ScaleY="1.05" />
</Path.RenderTransform>
</Path>
<TextBlock Name="LabTypeOne" Text="" FontSize="14" VerticalAlignment="Center" Grid.Column="1" Foreground="{DynamicResource ColorBrush3}" Margin="15,0,12,0" Grid.ColumnSpan="2" SnapsToDevicePixels="False" UseLayoutRounding="False" />
@@ -19,51 +19,53 @@
RefreshButtonsUI()
'加载版本
RunInNewThread(Sub()
'确认 Minecraft 文件夹存在
PathMcFolder = Setup.Get("LaunchFolderSelect").ToString.Replace("$", Path)
If PathMcFolder = "" OrElse Not Directory.Exists(PathMcFolder) Then
'无效的文件夹
If PathMcFolder = "" Then
Log("[Launch] 没有已储存的 Minecraft 文件夹")
Else
Log("[Launch] Minecraft 文件夹无效,该文件夹已不存在:" & PathMcFolder, LogLevel.Debug)
End If
McFolderListLoader.WaitForExit(IsForceRestart:=True)
Setup.Set("LaunchFolderSelect", McFolderList(0).Path.Replace(Path, "$"))
End If
Log("[Launch] Minecraft 文件夹:" & PathMcFolder)
If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(500, 3000))
'确认 Minecraft 版本存在
Dim Selection As String = Setup.Get("LaunchVersionSelect")
Dim Version As McVersion
If Selection = "" Then
Version = Nothing
Else
Version = New McVersion(Selection)
End If
If IsNothing(Version) OrElse Not (Version.Path.StartsWith(PathMcFolder) AndAlso Version.Check) Then
'无效的版本
Log("[Launch] Minecraft 版本无效" & If(IsNothing(Version), ",没有有效版本", ":" & Version.Path), If(IsNothing(Version), LogLevel.Normal, LogLevel.Debug))
If Not McVersionListLoader.State = LoadState.Finished Then LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True)
If McVersionList.Count = 0 OrElse McVersionList.First.Value(0).Logo.Contains("RedstoneBlock") Then
Version = Nothing
Setup.Set("LaunchVersionSelect", "")
Log("[Launch] 无可用 Minecraft 版本")
Else
Version = McVersionList.First.Value(0)
Setup.Set("LaunchVersionSelect", Version.Name)
Log("[Launch] 自动选择 Minecraft 版本:" & Version.Path)
End If
End If
RunInUi(Sub()
McVersionCurrent = Version '绕这一圈是为了避免 McVersionCheck 触发第二次版本改变
IsLoadFinished = True
RefreshButtonsUI()
RefreshPage(False, False) '有可能选择的版本变化了,需要重新刷新
If McLoginAble() = "" Then McLoginLoader.Start() '自动登录
End Sub)
End Sub, "Version Check", ThreadPriority.AboveNormal)
RunInNewThread(
Sub()
'确认 Minecraft 文件夹存在
PathMcFolder = Setup.Get("LaunchFolderSelect").ToString.Replace("$", Path)
If PathMcFolder = "" OrElse Not Directory.Exists(PathMcFolder) Then
'无效的文件夹
If PathMcFolder = "" Then
Log("[Launch] 没有已储存的 Minecraft 文件夹")
Else
Log("[Launch] Minecraft 文件夹无效,该文件夹已不存在:" & PathMcFolder, LogLevel.Debug)
End If
McFolderListLoader.WaitForExit(IsForceRestart:=True)
Setup.Set("LaunchFolderSelect", McFolderList(0).Path.Replace(Path, "$"))
End If
Log("[Launch] Minecraft 文件夹:" & PathMcFolder)
If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(500, 3000))
'确认 Minecraft 版本存在
Dim Selection As String = Setup.Get("LaunchVersionSelect")
Dim Version As McVersion
If Selection = "" Then
Version = Nothing
Else
Version = New McVersion(Selection)
End If
If IsNothing(Version) OrElse Not (Version.Path.StartsWith(PathMcFolder) AndAlso Version.Check) Then
'无效的版本
Log("[Launch] Minecraft 版本无效" & If(IsNothing(Version), ",没有有效版本", ":" & Version.Path), If(IsNothing(Version), LogLevel.Normal, LogLevel.Debug))
If Not McVersionListLoader.State = LoadState.Finished Then LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True)
If Not McVersionList.Any() OrElse McVersionList.First.Value(0).Logo.Contains("RedstoneBlock") Then
Version = Nothing
Setup.Set("LaunchVersionSelect", "")
Log("[Launch] 无可用 Minecraft 版本")
Else
Version = McVersionList.First.Value(0)
Setup.Set("LaunchVersionSelect", Version.Name)
Log("[Launch] 自动选择 Minecraft 版本:" & Version.Path)
End If
End If
RunInUi(
Sub()
McVersionCurrent = Version '绕这一圈是为了避免 McVersionCheck 触发第二次版本改变
IsLoadFinished = True
RefreshButtonsUI()
RefreshPage(False, False) '有可能选择的版本变化了,需要重新刷新
If McLoginAble() = "" Then McLoginLoader.Start() '自动登录
End Sub)
End Sub, "Version Check", ThreadPriority.AboveNormal)
'改变页面
Dim LoginType As McLoginType = Setup.Get("LoginType")
@@ -286,7 +288,7 @@ UnknownType:
Setup.Set("LoginType", McLoginType.Ms)
PanType.Visibility = Visibility.Collapsed
PanTypeOne.Visibility = Visibility.Visible
PathTypeOne.Data = (New GeometryConverter).ConvertFromString(Logo.IconButtonMs)
PathTypeOne.Data = (New GeometryConverter).ConvertFromString(Logo.IconButtonShield)
LabTypeOne.Text = "正版登录"
RadioLoginType5.Visibility = Visibility.Visible
RadioLoginType0.Visibility = Visibility.Collapsed
@@ -295,7 +297,7 @@ UnknownType:
Setup.Set("LoginType", McLoginType.Legacy)
PanType.Visibility = Visibility.Collapsed
PanTypeOne.Visibility = Visibility.Visible
PathTypeOne.Data = (New GeometryConverter).ConvertFromString(Logo.IconButtonUser)
PathTypeOne.Data = (New GeometryConverter).ConvertFromString(Logo.IconButtonOffline)
LabTypeOne.Text = "离线登录"
Case 3 '统一通行证
If Setup.Get("CacheNideAccess") = "" Then
@@ -67,7 +67,7 @@ Download:
End If
Case 3
Select Case Setup.Get("UiCustomPreset")
Case 0 '你知道吗
Case 0
Log("[Page] 主页预设:你知道吗")
Content = "
<local:MyCard Title=""你知道吗?"" Margin=""0,0,0,15"">
@@ -76,7 +76,7 @@ Download:
EventType=""刷新主页"" EventData=""/""
Logo=""M875.52 148.48C783.36 56.32 655.36 0 512 0 291.84 0 107.52 138.24 30.72 332.8l122.88 46.08C204.8 230.4 348.16 128 512 128c107.52 0 199.68 40.96 271.36 112.64L640 384h384V0L875.52 148.48zM512 896c-107.52 0-199.68-40.96-271.36-112.64L384 640H0v384l148.48-148.48C240.64 967.68 368.64 1024 512 1024c220.16 0 404.48-138.24 481.28-332.8L870.4 645.12C819.2 793.6 675.84 896 512 896z"" />
</local:MyCard>"
Case 1 '回声洞
Case 1
Log("[Page] 主页预设:回声洞")
Content = "
<local:MyCard Title=""回声洞"" Margin=""0,0,0,15"">
@@ -85,17 +85,17 @@ Download:
EventType=""刷新主页"" EventData=""/""
Logo=""M875.52 148.48C783.36 56.32 655.36 0 512 0 291.84 0 107.52 138.24 30.72 332.8l122.88 46.08C204.8 230.4 348.16 128 512 128c107.52 0 199.68 40.96 271.36 112.64L640 384h384V0L875.52 148.48zM512 896c-107.52 0-199.68-40.96-271.36-112.64L384 640H0v384l148.48-148.48C240.64 967.68 368.64 1024 512 1024c220.16 0 404.48-138.24 481.28-332.8L870.4 645.12C819.2 793.6 675.84 896 512 896z"" />
</local:MyCard>"
Case 2 '新闻
Case 2
Log("[Page] 主页预设:Minecraft 新闻")
Url = "http://pcl.mcnews.thestack.top"
GoTo Download
Case 3 '简单主页
Case 3
Log("[Page] 主页预设:简单主页")
Url = "https://gitee.com/mfn233/PCL-Mainpage/raw/main/Custom.xaml"
GoTo Download
Case 4 '历史上的今天
Log("[Page] 主页预设:历史上的今天")
Url = "https://pclnews.52chye.cn/custom.xaml"
Case 4
Log("[Page] 主页预设:每日整合包推荐")
Url = "https://pclsub.sodamc.com/"
GoTo Download
End Select
End Select
@@ -85,50 +85,51 @@
Hint("正在更改皮肤……")
IsChanging = True
'开始实际获取
RunInNewThread(Async Sub()
Try
RunInNewThread(
Async Sub()
Try
Retry:
If McLoginMsLoader.State = LoadState.Loading Then McLoginMsLoader.WaitForExit() '等待登录结束
Dim AccessToken As String = Setup.Get("CacheMsAccess")
Dim Uuid As String = Setup.Get("CacheMsUuid")
If McLoginMsLoader.State = LoadState.Loading Then McLoginMsLoader.WaitForExit() '等待登录结束
Dim AccessToken As String = Setup.Get("CacheMsAccess")
Dim Uuid As String = Setup.Get("CacheMsUuid")
Dim Client As New Net.Http.HttpClient With {.Timeout = New TimeSpan(0, 0, 30)}
Client.DefaultRequestHeaders.Authorization = New Net.Http.Headers.AuthenticationHeaderValue("Bearer", AccessToken)
Client.DefaultRequestHeaders.Accept.Add(New Net.Http.Headers.MediaTypeWithQualityHeaderValue("*/*"))
Client.DefaultRequestHeaders.UserAgent.Add(New Net.Http.Headers.ProductInfoHeaderValue("MojangSharp", "0.1"))
Dim Contents As New Net.Http.MultipartFormDataContent From {
{New Net.Http.StringContent(If(SkinInfo.IsSlim, "slim", "classic")), "variant"},
{New Net.Http.ByteArrayContent(File.ReadAllBytes(SkinInfo.LocalFile)), "file", GetFileNameFromPath(SkinInfo.LocalFile)}
}
Dim Result As String = Await (Await Client.PostAsync(New Uri("https://api.minecraftservices.com/minecraft/profile/skins"), Contents)).Content.ReadAsStringAsync
If Result.Contains("request requires user authentication") Then
Hint("正在登录,将在登录完成后继续更改皮肤……")
McLoginMsLoader.Start(GetLoginData(), IsForceRestart:=True)
GoTo Retry
ElseIf Result.Contains("""error""") Then
Hint("更改皮肤失败:" & GetJson(Result)("error"), HintType.Critical)
Exit Sub
End If
'获取新皮肤地址
Log("[Skin] 皮肤修改返回值:" & vbCrLf & Result)
Dim ResultJson As JObject = GetJson(Result)
For Each Skin As JObject In ResultJson("skins")
If Skin("state").ToString = "ACTIVE" Then
MySkin.ReloadCache(Skin("url"))
Exit Sub
End If
Next
Throw New Exception("未知错误(" & Result & ")")
Catch ex As Exception
If ex.GetType.Equals(GetType(Tasks.TaskCanceledException)) Then
Hint("更改皮肤失败:与 Mojang 皮肤服务器的连接超时,请检查你的网络是否通畅!", HintType.Critical)
Else
Log(ex, "更改皮肤失败", LogLevel.Hint)
End If
Finally
IsChanging = False
End Try
End Sub, "Ms Skin Upload")
Dim Client As New Net.Http.HttpClient With {.Timeout = New TimeSpan(0, 0, 30)}
Client.DefaultRequestHeaders.Authorization = New Net.Http.Headers.AuthenticationHeaderValue("Bearer", AccessToken)
Client.DefaultRequestHeaders.Accept.Add(New Net.Http.Headers.MediaTypeWithQualityHeaderValue("*/*"))
Client.DefaultRequestHeaders.UserAgent.Add(New Net.Http.Headers.ProductInfoHeaderValue("MojangSharp", "0.1"))
Dim Contents As New Net.Http.MultipartFormDataContent From {
{New Net.Http.StringContent(If(SkinInfo.IsSlim, "slim", "classic")), "variant"},
{New Net.Http.ByteArrayContent(File.ReadAllBytes(SkinInfo.LocalFile)), "file", GetFileNameFromPath(SkinInfo.LocalFile)}
}
Dim Result As String = Await (Await Client.PostAsync(New Uri("https://api.minecraftservices.com/minecraft/profile/skins"), Contents)).Content.ReadAsStringAsync
If Result.Contains("request requires user authentication") Then
Hint("正在登录,将在登录完成后继续更改皮肤……")
McLoginMsLoader.Start(GetLoginData(), IsForceRestart:=True)
GoTo Retry
ElseIf Result.Contains("""error""") Then
Hint("更改皮肤失败:" & GetJson(Result)("error"), HintType.Critical)
Exit Sub
End If
'获取新皮肤地址
Log("[Skin] 皮肤修改返回值:" & vbCrLf & Result)
Dim ResultJson As JObject = GetJson(Result)
For Each Skin As JObject In ResultJson("skins")
If Skin("state").ToString = "ACTIVE" Then
MySkin.ReloadCache(Skin("url"))
Exit Sub
End If
Next
Throw New Exception("未知错误(" & Result & ")")
Catch ex As Exception
If ex.GetType.Equals(GetType(Tasks.TaskCanceledException)) Then
Hint("更改皮肤失败:与 Mojang 皮肤服务器的连接超时,请检查你的网络是否通畅!", HintType.Critical)
Else
Log(ex, "更改皮肤失败", LogLevel.Hint)
End If
Finally
IsChanging = False
End Try
End Sub, "Ms Skin Upload")
End Sub
'保存皮肤
@@ -58,307 +58,21 @@
'检查网络状态
Private Shared Sub InitPingCheck(Task As LoaderTask(Of Integer, Integer))
PingTime = 0
Try
Log("[HiPer] 网络检测:连通检测开始")
Dim StartTime = Date.Now.Ticks
Dim Result As String = NetGetCodeByClient("https://www.baidu.com/duty/", Encoding.UTF8, 20000, "")
Dim DuringTime As Integer = (Date.Now.Ticks - StartTime) / 10000
If Result.Contains("百度") Then
Log("[HiPer] 网络检测:连通检测成功(" & DuringTime & "ms)")
PingTime = DuringTime
Else
Log("[HiPer] 网络检测:连通检测失败(获取的内容有误)")
PingTime = -1
End If
Catch ex As ThreadInterruptedException
Catch ex As Exception
Log(ex, "连通检测失败")
PingTime = -1
End Try
End Sub
Private Shared Sub InitIpCheck()
IpCheckStatus = LoadState.Loading
Try
Log("[HiPer] 网络检测:IP 地址检测开始")
Dim IpCheckResult As String = NetRequestOnce("https://ipinfo.io/json", "GET", "", "application/json", 10000)
Dim Country As String = GetJson(IpCheckResult)("country")
IpIsInChina = Country = "CN"
IpCheckStatus = LoadState.Finished
Log("[HiPer] 网络检测:IP 地址检测结果:" & Country)
Catch ex As ThreadInterruptedException
IpCheckStatus = LoadState.Aborted
Catch ex As Exception
Log(ex, "IP 地址检测失败")
IpCheckStatus = LoadState.Failed
IpIsInChina = True
End Try
End Sub
Private Shared PingTime As Integer, IpCheckStatus As LoadState = LoadState.Loading, IpIsInChina As Boolean
Private Shared Sub InitCheck(Task As LoaderTask(Of Integer, Integer))
'检查协议
If Not Setup.Get("LinkEula") Then
Reopen:
Select Case MyMsgBox("PCL 的联机服务由速聚授权提供。" & vbCrLf & "在使用前,你需要同意速聚的用户服务协议和隐私政策。", "协议授权", "同意", "拒绝", "查看用户服务协议和隐私政策")
Case 1
Setup.Set("LinkEula", True)
Case 2
Throw New Exception("$你拒绝了用户服务协议……")
Case 3
OpenWebsite("https://mp.weixin.qq.com/mp/appmsgalbum?__biz=MzkxMTMyODk3Mg==&action=getalbum&album_id=2585385685407514625&scene=173&from_msgid=2247483720&from_itemidx=1&count=3&nolastread=1#wechat_redirect")
GoTo Reopen
End Select
End If
'等待网络环境检查加载器结束
SetLoadDesc("正在检查网络环境……", "检查网络环境")
Do While Task.State = LoadState.Loading AndAlso Not (PingTime <> 0 AndAlso IpCheckStatus <> LoadState.Loading)
Thread.Sleep(50)
Loop
'获取网络环境检查结果
If IpCheckStatus = LoadState.Finished AndAlso Not IpIsInChina Then
If MyMsgBox("检测到你的 IP 不在中国,这会导致联机变得非常不稳定。" & vbCrLf &
"如果你正开着加速器或者 VPN,请先关闭它们,然后再继续……", "警告", "继续", "取消", IsWarn:=True, ForceWait:=True) = 2 Then
Throw New Exception("$请在关闭加速器或者 VPN 后点击重试。")
End If
Task.Progress = 0.5
InitIpCheck() '重新进行检查
End If
'没有联网
If IpCheckStatus = LoadState.Failed AndAlso PingTime = -1 Then
Throw New Exception("$PCL 没法连上网……" & vbCrLf & "如果你改变了网络环境,请重启 PCL。")
End If
End Sub
'获取所需文件
Private Shared Sub InitGetFile(Task As LoaderTask(Of Integer, List(Of NetFile)))
'初始化
SetLoadDesc("正在初始化……", "初始化")
Directory.CreateDirectory(PathHiper)
WriteFile(PathHiper & "HiPer 联机模块.vbs", "createobject(""wscript.shell"").run """"""" & PathHiper & "HiPer 联机模块.exe"""" v"", 0", Encoding:=Encoding.GetEncoding("GB18030")) '准备启动脚本
'获取索引码文件
SetLoadDesc("正在获取索引码文件……", "获取索引码文件")
Dim Cert As String = RunInUiWait(Function() FrmLinkHiper.TextCert.Text)
Log("[Hiper] 联机索引码:" & Cert)
If Cert = Setup.Get("LinkHiperCertLast") AndAlso File.Exists(PathHiper & "cert.yml") Then
Log("[Hiper] 索引码与上次输入的一致,跳过获取步骤")
Else
Dim CertRaw As String
Try
CertRaw = NetRequestOnce("https://cert.mcer.cn/" & Cert & ".yml", "GET", "", "")
Catch ex As Exception
If GetExceptionSummary(ex).Contains("(404)") Then
Throw New CertOutdatedException '索引码无效或已过期
ElseIf GetExceptionSummary(ex).Contains("too many requests") Then
Throw New Exception("你的尝试太频繁了,请暂时啥都别点,等两分钟后再试……")
Else
Throw
End If
End Try
If Not CertRaw.Contains("WARNING <<< AUTO SYNC AREA") Then Throw New Exception("获取到的索引码文件内容有误!")
WriteFile(PathHiper & "cert.yml", CertRaw)
Setup.Set("LinkHiperCertLast", Cert)
Setup.Set("LinkHiperCertTime", "")
End If
Task.Progress = 0.25
'获取 CPU 架构
SetLoadDesc("正在获取 CPU 架构……", "获取 CPU 架构")
Dim Architecture As String
Select Case GetType(String).Assembly.GetName().ProcessorArchitecture
Case Reflection.ProcessorArchitecture.X86
Architecture = "386"
Case Reflection.ProcessorArchitecture.Amd64
Architecture = "amd64"
Case Reflection.ProcessorArchitecture.Arm
Architecture = "arm64"
Case Else
Architecture = "arm64"
Log("[Hiper] 当前 CPU 架构为 " & GetStringFromEnum(GetType(String).Assembly.GetName().ProcessorArchitecture) & ",没有最适合的项,这可能会导致联机模块无法启动!", LogLevel.Debug)
End Select
Log("[Hiper] CPU 架构:" & Architecture)
'检查更新:hiper.exe
SetLoadDesc("正在检查联机模块本体更新……", "检查联机模块本体更新")
Dim RequiredFiles As New List(Of NetFile)
Dim Checksums As String = Nothing, ChecksumHiper As String = Nothing
If File.Exists(PathHiper & "HiPer 联机模块.exe") Then
Try
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
"https://cert.mcer.cn/mirror/packages.sha1"
})
Catch ex As Exception
Log(ex, "获取联机模块更新信息失败,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishHiperFileCheck
End Try
ChecksumHiper = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/hiper.exe)")
If ChecksumHiper Is Nothing Then
Log("[Hiper] 未找到联机模块更新信息,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishHiperFileCheck
End If
Log("[Hiper] hiper.exe 的所需 SHA1:" & ChecksumHiper)
If ChecksumHiper = GetFileSHA1(PathHiper & "HiPer 联机模块.exe") Then
Log("[Hiper] hiper.exe 文件校验通过,无需重新下载")
GoTo FinishHiperFileCheck
End If
End If
Log("[Hiper] 需要重新下载 hiper.exe")
RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/hiper.exe",
"http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/hiper.exe",
"https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/hiper.exe?inline=false",
"https://cert.mcer.cn/mirror/windows-" & Architecture & "/hiper.exe"},
PathHiper & "HiPer 联机模块.exe",
New FileChecker(Hash:=ChecksumHiper, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishHiperFileCheck:
Task.Progress = 0.5
'检查更新:wintun.dll
Dim ChecksumWintun As String = Nothing
If File.Exists(PathHiper & "wintun.dll") Then
Try
If Checksums Is Nothing Then
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
"https://cert.mcer.cn/mirror/packages.sha1"
})
End If
Catch ex As Exception
Log(ex, "获取联机模块更新信息失败,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishWintunFileCheck
End Try
ChecksumWintun = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/wintun.dll)")
If ChecksumWintun Is Nothing Then
Log("[Hiper] 未找到联机模块更新信息,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishWintunFileCheck
End If
Log("[Hiper] wintun.dll 的所需 SHA1:" & ChecksumWintun)
If ChecksumWintun = GetFileSHA1(PathHiper & "wintun.dll") Then
Log("[Hiper] wintun.dll 文件校验通过,无需重新下载")
GoTo FinishWintunFileCheck
End If
End If
Log("[Hiper] 需要重新下载 wintun.dll")
RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/wintun.dll",
"http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/wintun.dll",
"https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/wintun.dll?inline=false",
"https://cert.mcer.cn/mirror/windows-" & Architecture & "/wintun.dll"},
PathHiper & "wintun.dll",
New FileChecker(Hash:=ChecksumWintun, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishWintunFileCheck:
Task.Progress = 0.75
'检查更新:MCB
If Not IsServerSide Then
SetLoadDesc("正在检查联机模块组件更新……", "检查联机模块组件更新")
Dim ChecksumMcb As String = Nothing
If File.Exists(PathHiper & "MCB 联机模块.exe") Then
Try
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/packages.sha1",
"https://cert.mcer.cn/mirror/utils/minecraft-broadcast/packages.sha1"
})
Catch ex As Exception
Log(ex, "获取联机模块组件更新信息失败,将会强制启动联机模块组件", LogLevel.Hint)
GoTo FinishMcbFileCheck
End Try
ChecksumMcb = RegexSeek(Checksums, "[0-9a-f]{40}(?= mcb-windows-" & Architecture & ".exe)")
If ChecksumMcb Is Nothing Then
Log("[Hiper] 未找到联机模块组件更新信息,将会强制启动联机模块组件", LogLevel.Hint)
GoTo FinishMcbFileCheck
End If
Log("[Hiper] mcb.exe 的所需 SHA1:" & ChecksumMcb)
If ChecksumMcb = GetFileSHA1(PathHiper & "MCB 联机模块.exe") Then
Log("[Hiper] mcb.exe 文件校验通过,无需重新下载")
GoTo FinishMcbFileCheck
End If
End If
Log("[Hiper] 需要重新下载 mcb.exe")
RequiredFiles.Add(New NetFile({
"http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
"http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
"https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe?inline=false",
"https://cert.mcer.cn/mirror/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe"},
PathHiper & "MCB 联机模块.exe",
New FileChecker(Hash:=ChecksumMcb, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishMcbFileCheck:
End If
'添加 point.yml
RequiredFiles.Add(New NetFile({"https://cert.mcer.cn/point.yml"}, PathHiper & "point.yml", New FileChecker(MinSize:=200)))
'开始下载
SetLoadDesc("正在下载联机模块……", "下载联机模块")
Task.Output = RequiredFiles
End Sub
Public Class CertOutdatedException
Inherits Exception
End Class
'启动联机模块
Private Shared Sub InitLaunch(Task As LoaderTask(Of Integer, Integer))
'关闭运行中的 HiPer,然后再刷新凭证文件
SetLoadDesc("正在关闭运行中的联机模块……", "关闭运行中的联机模块")
HiperStop(True)
'准备凭证文件
SetLoadDesc("正在准备索引码文件……", "准备索引码文件")
Dim CertFile As String = ReadFile(PathHiper & "cert.yml")
'添加防火墙配置
If IsServerSide Then
CertFile += ("\n\ninbound:\n port: " & HostPort & "\n proto: tcp\n host: any").Replace("\n", vbCrLf)
Else
CertFile += ("\n\noutbound:\n port: " & HostPort & "\n proto: tcp\n host: " & HostIp).Replace("\n", vbCrLf)
End If
CertFile += "\nlogging:\n format: json".Replace("\n", vbCrLf)
'更新 point.yml 段
Const SyncAreaRegex As String = "(?<=#[ ]*WARNING >>> AUTO SYNC AREA)[\s\S]+?(?=#[ ]*WARNING <<< AUTO SYNC AREA)"
CertFile = CertFile.Replace(RegexSeek(CertFile, SyncAreaRegex), RegexSeek(ReadFile(PathHiper & "point.yml"), SyncAreaRegex))
WriteFile(PathHiper & "config.yml", CertFile)
AllNodes = RegexSearch(CertFile.Replace(vbLf, "cr"), "(?<="")[0-9]+.[0-9]+.[0-9]+.[0-9]+(?=""( )?:( )?cr - "")").Distinct.
Where(Function(l) Not (l = "6.6.1.1" OrElse l = "6.6.2.2" OrElse l = "6.6.3.3")).ToList
If AllNodes.Count < 2 Then Throw New Exception("$索引码文件格式有误,未找到节点 IP!")
Task.Progress = 0.05
'尝试启动
HiperStart(Task) '启动失败会直接抛出异常
Task.Progress = 0.2
'检查连接情况
SetLoadDesc("正在连接到联机节点 (1/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国,可能要花费很长时间。"), "检查联机节点")
If Not IsServerSide AndAlso HostIp = HiperIp Then Throw New Exception("$还搁这自己连自己?!不是吧?!")
Dim PingNodeResults As New List(Of Integer)
Dim UnpingedNodes As New List(Of String)(AllNodes)
Do Until PingNodeResults.Count >= 2 OrElse Task.IsAborted
Dim SelectedNode = RandomOne(UnpingedNodes)
Dim PingNode = Ping(SelectedNode, 4000)
If PingNode = -1 Then
Task.Progress += (If(PingNodeResults.Count = 0, 0.58, 0.88) - Task.Progress) * 0.3
Else
SetLoadDesc("正在连接到联机节点 (2/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国,可能要花费很长时间。"), "检查联机节点")
Task.Progress = 0.6
PingNodeResults.Add(PingNode)
UnpingedNodes.Remove(SelectedNode)
End If
Loop
PingNodes = PingNodeResults.Min
Task.Progress = 0.9
'与房主 Ping 一下看看
If Not IsServerSide Then
SetLoadDesc("正在连接到房主……", "检查房主")
HostPing = -1 '实际上不使用本次 Ping 的结果,因为它真的偏大……
Do
Dim PingHost = Ping(HostIp, 4000, False)
If PingHost = -1 Then
Thread.Sleep(500)
Else
Exit Do
End If
Loop Until Task.IsAborted
'在等待 2 秒后再次触发 Ping,以刷新显示的 Ping
RunInNewThread(Sub()
Thread.Sleep(2000)
TaskPingHost.Start(True, IsForceRestart:=True)
End Sub, "HiPer Delayed Ping")
End If
'刷新完成页面
SetLoadDesc("正在加载完成页面……", "加载完成页面")
RunInUiWait(AddressOf FrmLinkHiper.WatcherTimer1)
End Sub
Private Shared PingNodes As Integer, AllNodes As List(Of String)
@@ -389,40 +103,6 @@ FinishMcbFileCheck:
''' </summary>
Public Shared Function HiperStop(SleepWhenKilled As Boolean) As Boolean
Return False
HiperStop = False
'修改凭证
Dim ConfigContent As String = ReadFile(PathHiper & "config.yml")
If Not ConfigContent.Contains("enable: false") Then
WriteFile(PathHiper & "config.yml", ConfigContent & vbCrLf & "enable: false")
End If
'关闭所有进程
For Each ProcessObject In Process.GetProcesses
Dim IsHiper As Boolean = ProcessObject.ProcessName = "HiPer 联机模块"
Dim IsMcb As Boolean = ProcessObject.ProcessName = "MCB 联机模块"
If Not IsHiper AndAlso Not IsMcb Then Continue For
HiperStop = True
Try
If IsMcb Then
ProcessObject.Kill()
Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & ":" & ProcessObject.ProcessName)
If HiperStop AndAlso SleepWhenKilled Then Thread.Sleep(1000) '等待 1 秒确认进程已退出
Else 'IsHiper
If SleepWhenKilled Then
Thread.Sleep(4000) '等待 4 秒确认进程已退出
If Not ProcessObject.HasExited Then
ProcessObject.Kill()
Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & ":" & ProcessObject.ProcessName)
End If
End If
End If
Catch ex As Exception
Log(ex, "结束进程失败(" & ProcessObject.Id & "," & ProcessObject.ProcessName & ")")
End Try
Next
'初始化
HiperState = LoadState.Waiting
HiperProcessId = -1 : McbProcessId = -1
HiperCertTime = Nothing
End Function
''' <summary>
''' 启动程序,并等待初始化完成后退出运行,同时更新 HiperIp。
@@ -430,125 +110,10 @@ FinishMcbFileCheck:
''' 若程序正在运行,则会先停止其运行。
''' </summary>
Public Shared Sub HiperStart(Task As LoaderTask(Of Integer, Integer))
Try
SetLoadDesc("正在启动联机模块……", "启动联机模块")
PossibleFailReason = Nothing
'启动 Hiper
Log("[Hiper] 启动 Hiper 进程")
DeleteDirectory(PathHiper & "logs") '清理日志
Dim HiperInfo = New ProcessStartInfo With {
.FileName = "wscript",
.Arguments = """" & PathHiper & "HiPer 联机模块.vbs""",
.Verb = "runas" '需要管理员权限
}
Dim HiperVbsProcess As New Process() With {.StartInfo = HiperInfo}
HiperVbsProcess.Start()
'查找真正的 Hiper 进程
SetLoadDesc("联机模块正在启动……", "联机模块加载")
Do
Dim GotProcesses = Process.GetProcesses.
Where(Function(l) l.ProcessName = "HiPer 联机模块" AndAlso Math.Abs((l.StartTime - Date.Now).TotalMinutes) < 1)
If GotProcesses.Count > 0 Then
HiperProcessId = GotProcesses.First.Id
Log("[Hiper] 已发现 Hiper 进程,PID:" & HiperProcessId)
Exit Do
End If
Thread.Sleep(50)
Loop While Task.State = LoadState.Loading AndAlso Not Task.IsAborted
If HiperProcessId = -1 Then Throw New Exception("联机模块未能成功启动!")
HiperState = LoadState.Loading
Task.Progress = 0.15
'抓取日志
Dim LogLine As Integer = 0
Do
Thread.Sleep(100)
If Not File.Exists(PathHiper & "logs\hiper.log") Then Continue Do
Dim LogLines As String() = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
For i = LogLine To LogLines.Count - 1
HiperLogLine(LogLines(i), Task)
Next
LogLine = LogLines.Count
Loop While HiperState = LoadState.Loading AndAlso Not Task.IsAborted AndAlso Process.GetProcesses.Any(Function(l) l.Id = HiperProcessId)
'输出
If HiperState = LoadState.Finished Then
Log("[Hiper] Hiper 启动完成")
ElseIf PossibleFailReason IsNot Nothing AndAlso PossibleFailReason.Contains("索引码已过期") Then
Throw New CertOutdatedException()
Else
Throw New Exception(If(PossibleFailReason, "联机模块因未知原因启动失败!"))
End If
'启动 MCB
Task.Progress = 0.25
If Not IsServerSide Then
Try
Log("[Hiper] 启动 MCB 进程")
Dim McbInfo = New ProcessStartInfo With {
.FileName = PathHiper & "MCB 联机模块.exe", .WorkingDirectory = PathHiper,
.UseShellExecute = False, .CreateNoWindow = True,
.RedirectStandardError = True, .RedirectStandardOutput = True,
.Arguments = "-addr " & HostIp & ":" & HostPort & " -motd ""PCL 联机房间"""
}
Dim McbProcess As New Process() With {.StartInfo = McbInfo}
McbProcess.Start()
McbProcessId = McbProcess.Id
Catch ex As Exception
Throw New Exception("联机模块组件启动失败", ex)
End Try
End If
Catch ex As Exception
Try
HiperStop(True) '由于启动失败停止进程
Catch
End Try
HiperState = LoadState.Failed
Throw
End Try
End Sub
'Hiper 日志
Private Shared Sub HiperLogLine(Content As String, Task As LoaderTask(Of Integer, Integer))
'检查报错
Dim ContentTest As String = Content.ToLower
Dim ErrorMessage As String = Nothing
Dim ContentJson As JObject = Nothing
If Content.StartsWith("{""") AndAlso Content.EndsWith("}") Then
ContentJson = GetJson(Content)
ContentTest = If(ContentJson("error"), ContentJson("msg")).ToString.ToLower
ErrorMessage = ContentJson("error")
End If
If ContentTest.Contains("hiper certificate for this host is expired") Then
PossibleFailReason = "$你的索引码已过期,请更换新的索引码!"
ElseIf ContentTest.Contains("error creating interface: access is denied") Then
PossibleFailReason = "$没有获得管理员权限,无法创建网络通道!"
ElseIf ContentTest.Contains("cannot create a file when that file already exists") Then
PossibleFailReason = "$请不要重复开启多个联机模块!"
ElseIf Content.Contains("failed to load config") Then
PossibleFailReason = "$索引码文件内容存在错误!"
ElseIf Content.Contains("system cannot find the file specified") Then
PossibleFailReason = "$创建网络通道失败!" & vbCrLf & "如果你曾启动过 VPN 软件,请先打开那个软件,然后关掉它,最后再重试。虽然不知道为啥,但这样大概管用……"
End If
If PossibleFailReason Is Nothing AndAlso ErrorMessage IsNot Nothing Then PossibleFailReason = ErrorMessage
'检查结束
If ContentJson IsNot Nothing Then
Dim Message As String = ContentJson("msg")
If Message = "HiPer interface is active" Then
HiperIp = ContentJson("network").ToString.Split("/").First
If IsServerSide Then HostIp = HiperIp
Log("[Hiper] Hiper 启动完成,IP:" & HiperIp)
HiperState = LoadState.Finished
ElseIf Message = "Validity of client certificate" Then
Dim VaildTime As String = ContentJson("valid")
Date.TryParseExact(VaildTime, "yyyy-MM-dd HH:mm:ss", Globalization.CultureInfo.InvariantCulture, Globalization.DateTimeStyles.None, HiperCertTime)
Log("[Hiper] 索引码到期时间:" & HiperCertTime.ToString)
Setup.Set("LinkHiperCertTime", HiperCertTime.ToString)
End If
End If
'写入日志
If ModeDebug OrElse Content.Contains("""error""") Then Log("[Hiper] " & Content)
End Sub
Private Shared PossibleFailReason As String = Nothing
@@ -643,42 +208,6 @@ FinishMcbFileCheck:
'每 15 秒执行的 Timer
Private Shared HostPing As Integer = -1
Private Sub WatcherTimer15()
If Not (HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading) Then Exit Sub
'检查 HiPer 崩溃
Try
Process.GetProcessById(HiperProcessId)
Catch
Dim LogLines = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
HiperExit(False)
MyMsgBox("由于联机模块异常退出,已退出联机房间。" & vbCrLf & vbCrLf &
"联机模块最后的日志:" & vbCrLf & Join(LogLines.Skip(LogLines.Count - 3).ToList, vbCrLf), "联机断开")
End Try
'下面的部分需要完全完成加载
If HiperState <> LoadState.Finished Then Exit Sub
'检查 MCB 崩溃
Try
If Not IsServerSide Then Process.GetProcessById(McbProcessId)
Catch
HiperExit(False)
MyMsgBox("由于 MCB 联机模块异常退出,已退出联机房间。", "联机断开")
End Try
'重新检查 Ping
If Not IsServerSide Then
Dim PingHostFailedCount As Integer = 0
Do
TaskPingHost.WaitForExit(True, IsForceRestart:=True)
If TaskPingHost.Output = -1 Then
PingHostFailedCount += 1
Log("[HiPer] Ping 房主失败(第 " & PingHostFailedCount & " 次)")
If PingHostFailedCount >= 3 Then
HiperExit(False) : MyMsgBox("与房主断开连接,已退出联机房间。", "联机断开") : Exit Sub
End If
Else
If PingHostFailedCount > 0 Then Log("[HiPer] Ping 房主已恢复成功(" & HostPing & "ms)")
Exit Do
End If
Loop While True
End If
End Sub
#End Region
@@ -711,14 +240,6 @@ FinishMcbFileCheck:
'创建房间
Private Sub BtnSelectCreate_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectCreate.MouseLeftButtonUp
''获取端口号
'Dim PortInput As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {
' New ValidateInteger(2, 65535),
' New ValidateExceptSame({"55555", "55557"}, "端口不能为 %!")
' }, "在 MC 的暂停画面选择【对局域网开放】", "输入端口号", "确定", "取消")
'If PortInput Is Nothing Then Exit Sub
''开始
'RoomCreate(Val(PortInput))
End Sub
Private Sub RoomCreate(Port As Integer)
'记录信息
@@ -730,34 +251,6 @@ FinishMcbFileCheck:
'加入房间
Private Sub BtnSelectJoin_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectJoin.MouseLeftButtonUp
' '获取信息
' Dim Code As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateLength(8, 99)}, "",
' "输入联机码", "确定", "取消")
' If Code Is Nothing Then Exit Sub
' '记录信息
' If Not Code.EndsWith(RequestVersion) OrElse Not Code.StartsWith("P") Then GoTo WrongCode
' Dim Ip As String, Port As Integer
' Try
' Dim IpAndPort As Long = RadixConvert(Code.Substring(1, Code.Length - 2).ToUpper, 36, 10)
' 'IpAndPort = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
' Ip = Math.Floor(IpAndPort / (65536L * 256 * 256 * 256))
' IpAndPort = IpAndPort Mod (65536L * 256 * 256 * 256)
' Ip = Math.Floor(IpAndPort / (65536L * 256 * 256)) & "." & Ip
' IpAndPort = IpAndPort Mod (65536L * 256 * 256)
' Ip = Math.Floor(IpAndPort / (65536L * 256)) & "." & Ip
' IpAndPort = IpAndPort Mod (65536L * 256)
' Ip = Math.Floor(IpAndPort / (65536L)) & "." & Ip
' Port = IpAndPort Mod 65536
' Catch
' GoTo WrongCode
' End Try
' '启动
' RoomJoin(Ip, Port)
' Exit Sub
'WrongCode:
' If Not Code.StartsWith("P") AndAlso Code.Length >= 49 Then Hint("你输入的可能是 IOI 的联机码,请在左侧的联机方式中选择 IOI!", HintType.Critical) : Exit Sub
' If Code.StartsWith("P") AndAlso Not Code.EndsWith(RequestVersion) Then Hint("你的 PCL 版本与房主的 PCL 版本不一致!", HintType.Critical) : Exit Sub
' Hint("你输入的联机码无效!", HintType.Critical)
End Sub
Private Sub RoomJoin(Ip As String, Port As Integer)
'记录信息
@@ -773,54 +266,6 @@ FinishMcbFileCheck:
'承接状态切换的 UI 改变
Private Sub OnLoadStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
Select Case NewState
Case LoadState.Loading
UpdateProgress(0)
If IsServerSide Then
LabLoadTitle.Text = "正在创建联机房间"
Log("[Hiper] 正在创建联机房间,端口 " & HostPort)
Else
LabLoadTitle.Text = "正在加入联机房间"
Log("[Hiper] 正在加入联机房间,目标 IP " & HostIp & ":" & HostPort)
End If
LabLoadDesc.Text = "正在初始化……"
LoadStep = "准备初始化"
Case LoadState.Failed
UpdateProgress(1)
If IsServerSide Then
LabLoadTitle.Text = "创建联机房间失败"
Else
LabLoadTitle.Text = "加入联机房间失败"
End If
Dim RealException As Exception = If(Loader.Error.InnerException, Loader.Error)
If TypeOf RealException Is CertOutdatedException Then
LabCertTitle.Text = "索引码无效"
LabCertDesc.Text = "你的 HiPer 索引码无效或者已经过期!" & vbCrLf & "请重新输入索引码。"
HiperExit(True)
ElseIf RealException.Message.StartsWith("$") Then
LabLoadDesc.Text = RealException.Message.TrimStart("$") & vbCrLf &
"点击镐子重试,或者点击灰色的 × 取消。"
Else
LabLoadDesc.Text = LoadStep & "失败:" & GetExceptionSummary(RealException) & vbCrLf &
"点击镐子重试,或者点击灰色的 × 取消。"
End If
Log(Loader.Error, "HiPer 联机尝试失败")
Case LoadState.Finished
UpdateProgress(1)
CurrentSubpage = Subpages.PanFinish
BtnFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
LineFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
BtnFinishCopy.Visibility = If(IsServerSide, Visibility.Visible, Visibility.Collapsed)
If IsServerSide Then
LabFinishTitle.Text = "已创建联机房间"
LabFinishDesc.Text = "已在端口 " & HostPort & " 创建了联机房间。" & vbCrLf & "点击下方的复制联机码按钮,然后把联机码发给朋友吧!"
Else
LabFinishTitle.Text = "已加入联机房间"
LabFinishDesc.Text = "启动游戏,进入多人游戏页面后稍等片刻,房间就会出现在服务器列表的最下方。" & vbCrLf & "如果提示无效会话,不要退出联机房间,重新启动游戏即可!"
End If
LabFinishIp.Text = HostIp & ":" & HostPort
Log("[Hiper] 已完成连接")
End Select
End Sub
Private Shared LoadStep As String = "准备初始化"
Private Shared Sub SetLoadDesc(Intro As String, [Step] As String)
@@ -888,10 +333,6 @@ FinishMcbFileCheck:
'复制联机码
Private Sub BtnFinishCopy_Click(sender As Object, e As EventArgs) Handles BtnFinishCopy.Click
Dim IpParts = HostIp.Split(".").Select(Function(l) Val(l)).ToList
Dim IpAndPort As Long = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
ClipboardSet("P" & RadixConvert(IpAndPort, 10, 36) & RequestVersion, False)
Hint("已复制联机码!", HintType.Finish)
End Sub
'Ping 房主
@@ -1,204 +1,10 @@
Imports System.Net
Imports System.Net.Sockets
Imports System.Net.Sockets
Public Class PageLinkIoi
Public Const RequestVersion As Integer = 4
Public Const IoiVersion As Integer = 10 '由于已关闭更新渠道,在提升 IoiVersion 时必须提升 RequestVersion
Public Shared PathIoi As String = PathAppdata & "联机模块\IOI 联机模块.exe"
#Region "初始化"
'页面初始化
Private IsLoad As Boolean = False
Private Sub MeLoaded() Handles Me.Loaded
FormMain.EndProgramForce(Result.Aborted)
'重复加载部分
PanBack.ScrollToHome()
RefreshUi()
'非重复加载部分
If IsLoad Then Exit Sub
IsLoad = True
'更新线程
RunInNewThread(Sub()
Do While True
Thread.Sleep(200)
If FrmMain.PageCurrent.Page = FormMain.PageType.Link AndAlso FrmMain.PageCurrentSub = FormMain.PageSubType.LinkIoi Then RunInUiWait(Sub() FrmLinkIoi.RefreshUi())
RefreshWorker()
Loop
End Sub, "Link Timer")
End Sub
'加载器初始化与左边栏处理
Private Sub LoaderInit() Handles Me.Initialized
PageLoaderInit(Load, PanLoad, PanBack, PanAlways, InitLoader, Sub()
End Sub)
End Sub
'初始化加载器与步骤
Public Shared WithEvents InitLoader As New LoaderCombo(Of Integer)("联机模块初始化", {
New LoaderTask(Of Integer, Integer)("端口检查", AddressOf InitPortCheck) With {.ProgressWeight = 1},
New LoaderTask(Of Integer, Integer)("启动请求核心", AddressOf StartSocketListener) With {.ProgressWeight = 1},
New LoaderTask(Of Integer, List(Of NetFile))("初次启动尝试", AddressOf InitFirst) With {.ProgressWeight = 4},
New LoaderDownload("下载更新文件", New List(Of NetFile)) With {.ProgressWeight = 6},
New LoaderTask(Of List(Of NetFile), Boolean)("二次启动尝试", AddressOf InitSecond) With {.ProgressWeight = 3},
New LoaderTask(Of Boolean, Boolean)("创建请求核心房间", AddressOf InitRequest) With {.ProgressWeight = 2}
})
'判断端口是否被占用
Private Shared Sub InitPortCheck()
'检查协议
If Not Setup.Get("LinkEula") Then
Reopen:
Select Case MyMsgBox("PCL 的联机服务由速聚授权提供。" & vbCrLf & "在使用前,你需要同意速聚的用户服务协议和隐私政策。", "协议授权", "同意", "拒绝", "查看用户服务协议和隐私政策")
Case 1
Setup.Set("LinkEula", True)
Case 2
Throw New Exception("你拒绝了用户服务协议……")
Case 3
OpenWebsite("https://mp.weixin.qq.com/mp/appmsgalbum?__biz=MzkxMTMyODk3Mg==&action=getalbum&album_id=2585385685407514625&scene=173&from_msgid=2247483720&from_itemidx=1&count=3&nolastread=1#wechat_redirect")
GoTo Reopen
End Select
End If
'先掐死
IoiStop(True)
'检查端口
Dim HasConflict As Boolean = False
For Each Port In Net.NetworkInformation.IPGlobalProperties.GetIPGlobalProperties().GetActiveTcpListeners()
If Port.Port <> 55555 AndAlso Port.Port <> 55557 Then Continue For
Log("[IOI] 发现端口 " & Port.Port & " 被占用")
HasConflict = True
Next
If Not HasConflict Then Exit Sub
'对应的报错
For Each Line As String In ShellAndGetOutput("netstat", "-ano", 30000).Split({vbCrLf}, StringSplitOptions.RemoveEmptyEntries)
If Not (Line.Contains("127.0.0.1:55555") OrElse Line.Contains("127.0.0.1:55557")) Then Continue For
Dim ProcessName As String
Try
ProcessName = Process.GetProcessById(Line.Split(" ").Last).ProcessName
Catch ex As Exception
Log(ex, "获取占用端口的进程信息失败,假定进程已结束")
Continue For
End Try
If ProcessName = "联机模块" Then
Throw New Exception("由于一个已知问题,请在重启电脑后再尝试使用联机功能")
ElseIf ProcessName = "Idle" Then
'不知道为啥反正又没占用了
Log("[IOI] 未发现占用此端口的程序,继续执行")
Else
Throw New Exception("端口被程序 " & ProcessName & " 占用,无法启动联机模块,请在任务管理器关闭此程序后再试")
End If
Next
End Sub
'下载更新前尝试启动
Private Shared Sub InitFirst(Task As LoaderTask(Of Integer, List(Of NetFile)))
'初次启动尝试
If IoiVersion <> Setup.Get("LinkIoiVersion") Then
Log("[IOI] 设置版本强制要求联机模块更新")
Setup.Set("LinkIoiVersion", IoiVersion)
ElseIf File.Exists(PathIoi) Then
Task.Progress = 0.2
CheckFirewall()
If IoiStart() Then
'已完成启动与初始化
Task.Output = New List(Of NetFile)
Exit Sub
Else
'需要更新
IoiStop(True)
File.Delete(PathIoi)
GoTo StartDownload
End If
'如果抛出异常则直接使加载器失败
End If
'开始下载
StartDownload:
Task.Progress = 0.8
Log("[IOI] 需要下载联机模块")
If File.Exists(PathTemp & "联机模块.zip") Then File.Delete(PathTemp & "联机模块.zip")
Task.Output = New List(Of NetFile) From {New NetFile(
{"https://gitcode.net/to/cato_bin/-/raw/master/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
"http://mirror.hiper.cn.s2.the.bb/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
"http://mirror.hiper.cn.s3.the.bb:175/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
"https://pcl2-server-1253424809.file.myqcloud.com/link/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip{CDN}"},
PathTemp & "联机模块.zip")}
End Sub
'下载更新后尝试启动
Private Shared Sub InitSecond(Task As LoaderTask(Of List(Of NetFile), Boolean))
'若首次尝试已经成功,则直接跳过
If IoiState = LoadState.Finished Then Exit Sub
'解压更新包
Log("[IOI] 解压联机模块以完成下载")
If File.Exists(PathTemp & "ioi.exe") Then File.Delete(PathTemp & "ioi.exe")
If File.Exists(PathIoi) Then File.Delete(PathIoi)
ExtractFile(PathTemp & "联机模块.zip", PathTemp)
File.Delete(PathTemp & "联机模块.zip")
CopyFile(PathTemp & "ioi.exe", PathIoi)
File.Delete(PathTemp & "ioi.exe")
Task.Progress = 0.4
'再次尝试启动
CheckFirewall()
If IoiStart() Then Exit Sub
IoiStop(True)
Throw New Exception("联机模块初始化失败")
End Sub
'在 IOI 启动后建立 55557 房间
Private Shared Sub InitRequest()
Try
Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=55557" & "&password=" & IoiPassword, "PUT", "", "", 100000))
If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
Catch ex As InvalidOperationException
'API 返回的错误
Log("创建请求核心房间失败:" & ex.Message, LogLevel.Msgbox)
Catch ex As Exception
'常规错误
Log(ex, "创建请求核心房间失败", LogLevel.Msgbox)
End Try
End Sub
'检查防火墙权限,并添加对应的权限
Private Shared Sub CheckFirewall()
Try
Log("[IOI] Windows 防火墙:检测开始")
If Not PageLinkLeft.FirewallIsBlock(PathIoi) Then Exit Try
If PageLinkLeft.FirewallPolicy.CurrentProfile.ExceptionsNotAllowed Then
'禁止白名单
MyMsgBox("由于 Windows 防火墙阻止了所有传入连接,PCL 无法获取防火墙通行权限。" & vbCrLf &
"联机会有很大概率失败,就算连上了,延迟也会变高……" & vbCrLf & vbCrLf &
"请先关闭 Windows 防火墙中的 " & vbLQ & "阻止所有传入连接" & vbRQ & " 选项,然后重启 PCL。", "遭到防火墙拦截")
ElseIf IsAdmin() Then
'有管理员权限
Log("[IOI] Windows 防火墙:尝试添加防火墙通行权限")
Try
PageLinkLeft.FirewallAddAuthorized("Plain Craft Launcher 启动器(IOI 联机模块)", PathIoi)
Catch ex As Exception
Log(ex, "无法将联机模块添加至防火墙白名单,可能导致联机失败", LogLevel.Msgbox)
End Try
Else
'无管理员权限
If MyMsgBox("由于你开启了 Windows 防火墙,PCL 需要获取防火墙通行权限。" & vbCrLf & vbCrLf &
"若继续,PCL 将尝试以管理员权限重新启动。" & vbCrLf &
"若拒绝,联机模块可能会被防火墙拦截,联机会有很大概率失败。", "需要管理员权限", "继续", "拒绝") = 1 Then
Log("[IOI] Windows 防火墙:尝试提升权限")
If RunAsAdmin("--link ioi") Then
FrmMain.EndProgram(False) '已重新运行
Else
Hint("获取管理员权限失败,请尝试右键 PCL,选择 " & vbLQ & "以管理员身份运行" & vbRQ & ",然后再进入联机页面!", HintType.Critical)
End If
Else
Hint("在没有防火墙权限的情况下尝试联机,很可能会导致联机失败!", HintType.Critical)
End If
End If
Log("[IOI] Windows 防火墙:无防火墙通行权限")
Catch ex As Exception
Log(ex, "无法检测防火墙状态,可能导致联机失败", LogLevel.Msgbox)
End Try
End Sub
#End Region
#Region "进程管理"
Private Shared IoiId As String, IoiPassword As String
@@ -209,38 +15,7 @@ StartDownload:
''' 若 Ioi 正在运行,则结束 Ioi 进程,同时初始化状态数据。返回是否关闭了对应进程。
''' </summary>
Public Shared Function IoiStop(SleepWhenKilled As Boolean) As Boolean
IoiStop = False
'发送断开信息
Try
If IoiProcess IsNot Nothing AndAlso Not IoiProcess.HasExited Then
For i = 0 To UserList.Count - 1
If i > UserList.Count - 1 Then Exit For
Dim User = UserList.Values(i)
SendDisconnectRequest(User)
Next
End If
Catch ex As Exception
Log(ex, "结束 IOI 进程时发送 Disconnect 信息失败")
End Try
'关闭所有 Ioi 进程
For Each ProcessObject In Process.GetProcesses
If ProcessObject.ProcessName <> "IOI 联机模块" Then Continue For
IoiStop = True
Try
ProcessObject.Kill()
Log("[IOI] 已关闭联机模块:" & ProcessObject.Id)
If SleepWhenKilled Then Thread.Sleep(3000) '等待 3 秒确认进程已退出
Catch ex As Exception
Log(ex, "关闭联机模块失败(" & ProcessObject.Id & ")")
End Try
Next
'初始化
IoiProcess = Nothing
IoiId = Nothing
IoiPassword = Nothing
IoiState = LoadState.Waiting
UserList = New Dictionary(Of String, LinkUserIoi)
RoomListForMe = New List(Of RoomEntry)
Return False
End Function
''' <summary>
''' 启动 Ioi,并等待初始化完成后退出运行,同时更新 IoiId 与 IoiPassword。
@@ -248,130 +23,11 @@ StartDownload:
''' 若 Ioi 正在运行,则会先停止其运行。
''' </summary>
Public Shared Function IoiStart() As Boolean
IoiStop(True)
Log("[IOI] 启动联机模块进程")
Dim Info = New ProcessStartInfo With {
.FileName = PathIoi,
.UseShellExecute = False,
.CreateNoWindow = True,
.RedirectStandardError = True,
.RedirectStandardOutput = True,
.WorkingDirectory = PathTemp
}
IoiProcess = New Process() With {.StartInfo = Info}
Using outputWaitHandle As New AutoResetEvent(False)
Using errorWaitHandle As New AutoResetEvent(False)
AddHandler IoiProcess.OutputDataReceived, Function(sender, e)
Try
If e.Data Is Nothing Then
outputWaitHandle.[Set]()
Else
IoiLogLine(e.Data)
End If
Catch ex As ObjectDisposedException
Catch ex As Exception
Log(ex, "读取联机模块信息失败")
IoiState = LoadState.Failed
End Try
Return Nothing
End Function
AddHandler IoiProcess.ErrorDataReceived, Function(sender, e)
Try
If e.Data Is Nothing Then
errorWaitHandle.[Set]()
Else
IoiLogLine(e.Data)
End If
Catch ex As ObjectDisposedException
Catch ex As Exception
Log(ex, "读取联机模块错误信息失败")
IoiState = LoadState.Failed
End Try
Return Nothing
End Function
IoiProcess.Start()
IoiState = LoadState.Loading
IoiProcess.BeginOutputReadLine()
IoiProcess.BeginErrorReadLine()
'等待
Do Until IoiProcess.HasExited OrElse IoiState <> LoadState.Loading
Thread.Sleep(10)
Loop
'输出
If IoiState = LoadState.Finished Then
Log("[IOI] 联机模块启动成功")
Return True
Else
Throw New Exception("联机模块启动失败")
End If
'Select Case IoiState
' Case LoadState.Finished
' Log("[IOI] 联机模块启动成功")
' Return True
' Case LoadState.Aborted
' Log("[IOI] 联机模块要求更新")
' Return False
' Case LoadState.Failed
' Log("[IOI] 联机模块启动出现异常")
' Return False
' Case Else 'LoadState.Loading
' Throw New Exception("联机模块启动失败,请检查你的网络连接")
'End Select
End Using
End Using
Return False
End Function
'Ioi 日志
Private Shared Sub IoiLogLine(Content As String)
'初始化
If Content.Contains(" > http://127.0.0.1:55555/") Then Exit Sub
If Content.Contains("All done") Then
If IoiId IsNot Nothing AndAlso IoiPassword IsNot Nothing Then
IoiState = LoadState.Finished
Else
Log("[IOI] 联机模块汇报初始化完成,但未提供账户信息")
IoiState = LoadState.Failed
End If
Exit Sub
End If
If Content.Contains("Password :: ") Then
IoiPassword = Content.Split({"Password :: "}, StringSplitOptions.None)(1)
Exit Sub '为保证安全不记录密码到 Log
End If
'初始化
If Content.Contains("ID :: ") Then IoiId = Content.Split({"ID :: "}, StringSplitOptions.None)(1)
If Content.Contains("Initialization failed") OrElse Content.Contains("The version is ") Then IoiState = LoadState.Aborted
'系统回应
If Content.Contains("'portssub' from ") Then LastPortsId = Content.Split(" ").Last
If Content.Contains("Listening tcp ") Then
If UserList.ContainsKey(LastPortsId) Then
UserList(LastPortsId).Ports(Content.Split(" ").Last) = RegexSeek(Content, "(?<=Listening tcp )[^:]+")
Else
Log("[IOI] 未在列表中的用户出现意料外的连接信息")
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & LastPortsId & "&password=" & IoiPassword, "DELETE", "", "", 500)
End If
End If
'断开连接
If Content.Contains("Closed tcp connection from ") AndAlso Content.Contains(":55557") Then
For i = 0 To UserList.Count - 1
Dim User = UserList.Values(i)
If Not Content.Contains(User.Ports(55557)) OrElse User.IsDisposed Then Continue For
Log("[IOI] 检测到 55557 端口断开(" & User.DisplayName & ")")
UserRemove(User, True)
Exit For
Next
End If
'写入日志
If Not Content.Contains("read /dev/stdin: The handle is invalid.") AndAlso LogLinesCount < If(ModeDebug, 10000, 1000) Then
LogLinesCount += 1
Log("[IOI] " & Content)
End If
End Sub
Private Shared LogLinesCount As Integer = 0
Private Shared LastPortsId As String = "" '上一个收到 portssub 的 ID,用于记录端口
@@ -384,94 +40,10 @@ StartDownload:
Private Shared UserListIdentifyCache As String = ""
Private Shared RoomListIdentifyCache As String = ""
Public Sub RefreshUi()
Try
'确认用户列表缓存
Dim UserListIdentify As String = Join(UserList, vbCrLf)
If UserListIdentify <> UserListIdentifyCache Then
UserListIdentifyCache = UserListIdentify
'刷新列表项
PanUserList.Children.Clear()
For i = 0 To UserList.Count - 1
If i > UserList.Count - 1 Then Exit For
PanUserList.Children.Add(UserList.Values(i).ToListItem)
Next
'刷新列表标题
CardUser.Title = "已连接的玩家 (" & PanUserList.Children.Count & ")"
End If
'刷新用户列表项
For Each UserItem As MyListItem In PanUserList.Children
CType(UserItem.Tag, LinkUserIoi).RefreshUi(UserItem)
Next
'确认房间列表缓存
Dim RoomListIdentify As String = Join(GetRoomList(), vbCrLf)
If RoomListIdentify <> RoomListIdentifyCache Then
RoomListIdentifyCache = RoomListIdentify
'刷新列表项
PanRoom.Children.Clear()
For Each Room In GetRoomList()
PanRoom.Children.Add(Room.ToListItem)
Next
End If
'刷新房间列表项
For Each RoomItem As MyListItem In PanRoom.Children
CType(RoomItem.Tag, RoomEntry).RefreshUi(RoomItem)
Next
'刷新操作提示
If UserList.Count = 0 Then
If RoomListForMe.Count = 0 Then
LabHint.Text = "若想创建房间,请点击创建房间按钮,并按说明进行操作。" & vbCrLf & "若想加入他人的房间,请点击建立连接,然后输入对方的联机码。"
Else
LabHint.Text = "若想让其他人加入你的房间,请点击复制联机码,然后让你的朋友输入你的联机码以建立连接。"
End If
Else
If GetRoomList.Count = 0 Then
LabHint.Text = "若想创建房间,请点击创建房间按钮,然后输入对局域网开放后 MC 显示的端口号,或本地服务端的端口号。"
ElseIf RoomListForMe.Count = 0 Then
'已有连接,本人没有房间,对方有房间
LabHint.Text = "若想加入某个房间,直接点击该房间即可获取说明。"
Else
'已有连接,且本人有房间
LabHint.Text = "指向你所创建的房间,能在右侧找到修改房间名称、关闭房间等选项。" &
If(RoomListForMe.Count <> GetRoomList.Count, vbCrLf & "若想加入其他人的房间,直接点击该房间即可获取说明。", "")
End If
End If
Catch ex As Exception
Log(ex, "联机模块 UI 时钟运行失败", LogLevel.Feedback)
End Try
End Sub
'工作线程刷新
Public Sub RefreshWorker()
Try
'检测退出
If InitLoader.State = LoadState.Finished AndAlso IoiProcess.HasExited Then
Log("[IOI] 联机模块出现异常!", LogLevel.Hint)
ModuleStopManually()
End If
'检测用户
For i = 0 To UserList.Values.Count - 1
If i > UserList.Values.Count - 1 Then Exit For
Dim User = UserList.Values(i)
If User.Progress < 1 Then Continue For '跳过连接中的用户
'发送心跳包
If Date.Now - User.LastSend > New TimeSpan(0, 0, RandomInteger(50, 30)) Then
RunInNewThread(Sub()
Try
SendUpdateRequest(User, 1)
Catch ex As Exception
Log(ex, "心跳包发送失败(" & User.DisplayName & ")", LogLevel.Normal)
End Try
End Sub, "Link Heartbeat " & User.Id)
End If
'检测被动离线
If Date.Now - User.LastReceive > New TimeSpan(0, 2, 0) Then
SendDisconnectRequest(User)
Hint("与 " & User.DisplayName & " 的连接已中断!", HintType.Critical)
End If
Next
Catch ex As Exception
Log(ex, "联机模块工作时钟运行失败", LogLevel.Feedback)
End Try
End Sub
#End Region
@@ -482,65 +54,6 @@ StartDownload:
''' 发送 Portsub 请求并等待获取控制台端口。进度将从 0 变化至 80%。
''' </summary>
Private Shared Sub SendPortsubRequest(User As LinkUserIoi)
Log("[IOI] 尝试建立连接:" & User.Id)
'向对方发送 portsub 请求
Dim Retry As Integer = 0
RetryLink:
Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "PUT", "", "", 100000))
'失败与重试
If Result("msg") IsNot Nothing Then
Dim ErrorMessage As String = Result("msg").ToString
Select Case ErrorMessage
Case "failed to find any peer in table"
Retry += 1
ErrorMessage = "我方网络环境不佳,连接失败。" '初始化对等机列表超时
Log("[IOI] 尝试建立连接结果:未找到对等机,第 " & Retry & " 级重试")
Case "routing: not found"
Retry += 4
ErrorMessage = "我方或对方网络环境不佳,或对方已关闭联机模块,未找到路由。" '未知情况
Log("[IOI] 尝试建立连接结果:无法连接到路由,第 " & Retry & " 级重试")
Case "you are already connected to specified host"
If User.IsDisposed Then Throw New ThreadInterruptedException("用户对象已被释放")
Log("[IOI] 尝试建立连接结果:已与对方连接")
GoTo Done
'Retry += 1
'NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 100000)
'ErrorMessage = "已与对方连接。" '双向连接偶尔导致
'Log("[IOI] 已与对方连接,尝试中断现有连接,第 " & Retry & " 级重试")
Case "dial backoff"
Retry += 20
ErrorMessage = "对方网络环境不佳,或对方已关闭联机模块。请尝试让对方主动连接你,而不是你去连接对方。" 'NAT2 连 NAT4 导致
Log("[IOI] 尝试建立连接结果:NAT 异常,第 " & Retry & " 级重试")
Case Else
If ErrorMessage.Contains("all dials failed") Then
Retry += 8
ErrorMessage = "我方或对方网络环境不佳,或对方已关闭联机模块,连接失败。" '网络不佳,或对方已关闭模块
Log("[IOI] 尝试建立连接结果:连接失败,第 " & Retry & " 级重试")
Else
Retry += 8
Log("[IOI] 尝试建立连接结果:未知错误(" & ErrorMessage & "),第 " & Retry & " 级重试")
End If
End Select
If User.IsDisposed Then Throw New ThreadInterruptedException("用户对象已被释放")
If Retry <= 64 Then
User.Progress = Retry * 0.01 + 0.05
Thread.Sleep(3000)
GoTo RetryLink
Else
Throw New InvalidOperationException(ErrorMessage)
End If
End If
Log("[IOI] 尝试建立连接结果:成功")
'等待获取对方端口
Done:
Dim WaitCount As Integer = 0
Do Until User.Ports.ContainsKey(55555) AndAlso User.Ports.ContainsKey(55557)
WaitCount += 1
User.Progress = 0.7 + WaitCount / 200 * 0.1 '70% ~ 80%
If WaitCount = 100 Then Throw New Exception("连接超时,请尝试重新连接(未收到端口回报)!")
Thread.Sleep(150)
Loop
User.Progress = 0.8
End Sub
''' <summary>
@@ -584,20 +97,6 @@ Done:
''' 尝试发送断开请求,并将其从用户列表中移除。
''' </summary>
Private Shared Sub SendDisconnectRequest(User As LinkUserIoi, Optional Message As String = Nothing, Optional IsError As Boolean = False)
Dim RawJson As New JObject()
RawJson("id") = IoiId
RawJson("type") = "disconnect"
If Message IsNot Nothing Then
RawJson("message") = Message
RawJson("isError") = IsError
End If
Try
User.Send(RawJson)
Thread.Sleep(50)
Catch
End Try
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
User.Dispose()
End Sub
#End Region
@@ -606,29 +105,9 @@ Done:
'刷新连接
Private Shared Sub BtnListRefresh_Click(sender As MyIconButton, e As EventArgs)
Dim User As LinkUserIoi = sender.Tag
User.PingRecord.Clear()
FrmLinkIoi.RefreshUi()
RunInThread(Sub()
Try
SendUpdateRequest(User, 1)
Catch ex As Exception
If InitLoader.State = LoadState.Finished Then Log(ex, "刷新与 " & User.DisplayName & " 的连接失败", LogLevel.Hint)
End Try
End Sub)
End Sub
'断开连接
Private Shared Sub BtnListDisconnect_Click(sender As MyIconButton, e As EventArgs)
Dim User As LinkUserIoi = sender.Tag
sender.IsEnabled = False
RunInThread(Sub()
If User.Progress < 1 AndAlso User.RelativeThread IsNot Nothing AndAlso User.RelativeThread.IsAlive Then
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
User.Dispose()
Else
SendDisconnectRequest(User, GetPlayerName() & " 主动断开了连接!")
End If
End Sub)
End Sub
'复制联机码
Public Shared Sub BtnLeftCopy_Click() Handles BtnLeftCopy.Click
@@ -680,46 +159,10 @@ Done:
#Region "请求核心"
Private Shared Listener As Socket = Nothing
''' <summary>
''' 启动 Socket 监听核心。
''' </summary>
Public Shared Sub StartSocketListener()
If Listener IsNot Nothing Then Exit Sub '已经启动过了
Listener = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) With {.ReceiveTimeout = 1000000000, .SendTimeout = 1000000000}
Listener.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReuseAddress, True)
Try
Listener.Bind(New IPEndPoint(IPAddress.Any, 55557))
Catch ex As Exception
Log(ex, "初次启动 Socket 监听核心失败,开始重试")
Thread.Sleep(1000)
Listener.Bind(New IPEndPoint(IPAddress.Any, 55557))
End Try
Listener.Listen(100)
Log("[IOI] 已启动 Socket 监听核心")
RunInNewThread(Sub()
While True
Try
'获取新的 Socket
Dim bytes(1024) As Byte
Dim ClientSocket As Socket = Listener.Accept()
'获取初始输入信息
Dim RequestInput As String = Encoding.UTF8.GetString(bytes, 0, ClientSocket.Receive(bytes))
If Not RequestInput.StartsWith("PCL - ") Then Exit Sub
Dim RawData As String
Try
RawData = SecretDecrypt(WebUtility.UrlDecode(RequestInput.Substring(6)))
Log("[IOI] 接收到新的 Socket:" & RawData)
PageLinkIoi.ReceiveJson(GetJson(RawData), ClientSocket)
Catch ex As Exception
Log(ex, "新的 Socket 处理出错(内容:" & RequestInput & ")")
End Try
Catch ex As Exception
Log(ex, "Socket 监听出错")
Thread.Sleep(3000) '防止死循环出错
End Try
End While
End Sub, "Socket Listener")
End Sub
#End Region
@@ -738,40 +181,9 @@ Done:
'请求管理
Public Socket As Socket = Nothing
Public Sub Send(Request As JObject)
If Socket Is Nothing Then Throw New Exception("该用户尚未绑定 Socket")
Dim Data As String = Request.ToString(Newtonsoft.Json.Formatting.None)
If ModeDebug Then Log("[IOI] 发送联机数据包(" & DisplayName & "):" & Data)
Data = "PCL - " & WebUtility.UrlEncode(SecretEncrypt(Data))
Me.LastSend = Date.Now
Socket.Send(Encoding.UTF8.GetBytes(Data))
End Sub
Public ListenerThread As Thread = Nothing
Public Sub StartListener()
If ListenerThread IsNot Nothing Then Exit Sub
'启动监听
ListenerThread = RunInNewThread(Sub()
Try
Dim bytes(1024) As Byte
While PageLinkIoi.UserList.ContainsValue(Me)
Dim RequestInput As String = Encoding.UTF8.GetString(bytes, 0, Socket.Receive(bytes))
If Not RequestInput.StartsWith("PCL - ") Then Exit Sub
Dim RawData As String = SecretDecrypt(WebUtility.UrlDecode(RequestInput.Substring(6)))
If ModeDebug Then Log("[IOI] 接收联机数据包(" & DisplayName & "):" & RawData)
PageLinkIoi.ReceiveJson(GetJson(RawData)) '调用去实际的联机模块
End While
Catch ex As ThreadInterruptedException
Log("[IOI] 用户监听已中断(" & DisplayName & ")")
Catch ex As Exception
If IsDisposed Then Exit Sub
If ex.GetType.Equals(GetType(SocketException)) AndAlso CType(ex, SocketException).SocketErrorCode = 10053 Then
Log("[IOI] 客户端已关闭(" & DisplayName & ")")
PageLinkIoi.UserRemove(CType(Me, PageLinkIoi.LinkUserIoi), True)
Exit Sub
End If
Log(ex, "用户监听出错(" & DisplayName & ")")
PageLinkIoi.UserRemove(CType(Me, PageLinkIoi.LinkUserIoi), True)
End Try
End Sub, "Link Listener " & DisplayName)
End Sub
Public Sub BindSocket(Socket As Socket)
If Me.Socket IsNot Nothing Then Throw New Exception("该用户已经绑定了 Socket")
@@ -846,7 +258,7 @@ Done:
Public Function GetDescription() As String
Return If(Progress < 1,
"正在连接," & Math.Round(Progress * 100) & "%",
"已连接," & If(PingRecord.Count = 0, "检查延迟中", Math.Round(PingRecord.Average) & "ms"))
"已连接," & If(Not PingRecord.Any(), "检查延迟中", Math.Round(PingRecord.Average) & "ms"))
End Function
Public Function ToListItem() As MyListItem
Dim Item As New MyListItem With {
@@ -975,135 +387,12 @@ Done:
'正向与反向连接
Public Shared Sub BtnLeftCreate_Click() Handles BtnLeftCreate.Click
''获取信息
'Dim Code As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateLength(9, 99999)}, "", "输入对方的联机码", "确定", "取消")
'If Code Is Nothing Then Exit Sub
''检查
'If Code.StartsWith("P") AndAlso Code.Length < 48 Then
' Hint("你输入的可能是 HiPer 的联机码,请在左侧的联机方式中选择 HiPer!", HintType.Critical) : Exit Sub
'End If
'Dim Id As String, DisplayName As String
'Try '解密失败检查
' Id = "12D3" & Code.Substring(0, 48)
' DisplayName = SecretDecrypt(Code.Substring(48))
'Catch
' Hint("你输入的联机码有误!", HintType.Critical)
' Exit Sub
'End Try
'If Id = IoiId Then '自我连接检查
' Hint("我连我自己?搁这卡 Bug 呢?", HintType.Critical)
' Exit Sub
'End If
''开始
'Dim User As New LinkUserIoi(Id, DisplayName)
'User.RelativeThread = RunInNewThread(Sub()
' Dim WaitCount As Integer = 0
' Try
' '加入列表
' If UserList.ContainsKey(Id) Then
' Hint(UserList(Id).DisplayName & " 已在列表中,无需再次连接!")
' Exit Sub
' Else
' UserList.Add(Id, User)
' End If
' '发送 portsub 请求(0% -> 80%)
' SendPortsubRequest(User)
' '构建 Socket(81% -> 82%)
' Dim ClientSocket As New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) With {.ReceiveTimeout = 1000000000, .SendTimeout = 1000000000}
' ClientSocket.Connect(New IPEndPoint(IPAddress.Parse(User.Ports(55557)), 55557))
' User.BindSocket(ClientSocket)
' User.Progress = 0.82
' '发送 connect 请求(83% -> 85%)
' SendConnectRequest(User)
' User.Progress = 0.85
' '等待对方向自己请求
' Log("[IOI] 加入成功,等待反向请求")
' Do While User.Progress < 0.9999
' User.Progress += 0.0002
' If User.Progress > 0.98 AndAlso User.Progress < 0.9999 Then Throw New Exception("对方未回应连接请求!")
' Thread.Sleep(100)
' Loop
' Hint("已连接到 " & User.DisplayName & "!", HintType.Finish)
' Catch ex As ThreadInterruptedException
' Log("[IOI] 已中断主动发起的连接(" & User.DisplayName & ")")
' Catch ex As InvalidOperationException
' 'API 返回的错误
' NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
' User.Dispose()
' If InitLoader.State = LoadState.Finished Then Log("与 " & DisplayName & " 建立连接失败:" & ex.Message, LogLevel.Msgbox)
' Catch ex As Exception
' '常规错误
' NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
' User.Dispose()
' If ex.InnerException IsNot Nothing AndAlso TypeOf ex.InnerException Is ThreadInterruptedException Then Exit Sub
' If InitLoader.State = LoadState.Finished Then Log(ex, "与 " & DisplayName & " 建立连接失败", LogLevel.Msgbox)
' End Try
' End Sub, "Link Create " & DisplayName)
End Sub
Private Shared Sub SendPortsubBack(User As LinkUserIoi, TargetVersion As Integer)
Try
SendPortsubRequest(User)
User.Progress = 0.9
If TargetVersion > RequestVersion Then
SendDisconnectRequest(User, "无法连接到 " & GetPlayerName() & ":对方的 PCL 版本过低!", True)
Throw New InvalidOperationException("你的 PCL 版本过低!")
ElseIf TargetVersion < RequestVersion Then
SendDisconnectRequest(User, "无法连接到 " & GetPlayerName() & ":你的 PCL 版本过低!", True)
Throw New InvalidOperationException("对方的 PCL 版本过低!")
Else
SendUpdateRequest(User, 1)
User.Progress = 1
Hint(User.DisplayName & " 已与你建立连接!")
End If
Catch ex As ThreadInterruptedException
Log("[IOI] 已中断被动建立的连接(" & User.DisplayName & ")")
Catch ex As InvalidOperationException
'API 返回的错误
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
User.Dispose()
If InitLoader.State = LoadState.Finished Then Log("与 " & User.DisplayName & " 建立连接失败:" & ex.Message, LogLevel.Hint)
Catch ex As Exception
'常规错误
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
User.Dispose()
If InitLoader.State = LoadState.Finished Then Log(ex, "与 " & User.DisplayName & " 建立连接失败", LogLevel.Hint)
End Try
End Sub
'创建房间
Private Sub LinkCreate() Handles BtnCreate.Click
'If MyMsgBox("请先进入 MC 并暂停游戏,在暂停页面选择对局域网开放,然后在下一个窗口输入 MC 显示的端口号。" & vbCrLf & "若使用服务端开服,则直接在下一个窗口输入服务器配置中的端口号即可。", "提示", "继续", "取消") = 2 Then Exit Sub
''获取端口号
'Dim Port As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {
' New ValidateInteger(0, 65535),
' New ValidateExceptSame({"55555", "55557"}, "端口不能为 %!"),
' New ValidateExceptSame(RoomListForMe.Select(AddressOf RoomEntry.SelectPort), "端口 % 已创建过房间,请在删除该房间后继续!")
' }, "", "输入端口号", "确定", "取消")
'If Port Is Nothing Then Exit Sub
''获取显示名称
'Dim DisplayName As String = MyMsgBoxInput(GetPlayerName() & " 的房间 - " & Port, New ObjectModel.Collection(Of Validate) From {
' New ValidateNullOrWhiteSpace(), New ValidateLength(1, 40), New ValidateFilter()
' }, "", "输入房间名(建议包含游戏版本等信息)", "确定", "取消")
'If DisplayName Is Nothing Then Exit Sub
'DisplayName = DisplayName.Trim
''开始
'RunInThread(Sub()
' Try
' '请求
' Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=" & Port & "&password=" & IoiPassword, "PUT", "", "", 100000))
' If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
' '成功
' RoomListForMe.Add(New RoomEntry(Port, DisplayName))
' Hint("房间 " & DisplayName & " 已创建!", HintType.Finish)
' SendUpdateRequestToAllUsers()
' Catch ex As InvalidOperationException
' 'API 返回的错误
' Log("创建房间失败:" & ex.Message, LogLevel.Msgbox)
' Catch ex As Exception
' '常规错误
' Log(ex, "创建房间失败", LogLevel.Msgbox)
' End Try
' End Sub)
End Sub
Private Shared Sub SendUpdateRequestToAllUsers()
For i = 0 To UserList.Count - 1
@@ -1119,18 +408,6 @@ Done:
End Sub
'修改房间名称
Private Shared Sub BtnRoomEdit_Click(sender As MyIconButton, e As EventArgs)
'Dim Room As RoomEntry = sender.Tag
''获取房间名
'Dim DisplayName As String = MyMsgBoxInput(Room.DisplayName, New ObjectModel.Collection(Of Validate) From {
' New ValidateNullOrWhiteSpace(),
' New ValidateLength(1, 40)
' }, "", "输入房间名(建议包含游戏版本等信息)", "确定", "取消")
'If DisplayName Is Nothing Then Exit Sub
'DisplayName = DisplayName.Trim
''修改
'Room.DisplayName = DisplayName
'FrmLinkIoi.RefreshUi()
'SendUpdateRequestToAllUsers()
End Sub
'加入房间
Private Shared Sub BtnRoom_Click(sender As MyListItem, e As EventArgs)
@@ -1141,25 +418,6 @@ Done:
End Sub
'关闭房间
Private Shared Sub BtnRoomClose_Click(sender As MyIconButton, e As EventArgs)
Dim Room As RoomEntry = sender.Tag
RunInThread(Sub()
Try
'远程移除
Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=" & Room.Port & "&password=" & IoiPassword, "DELETE", "", "", 100000))
If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
'本地移除
RoomListForMe.Remove(Room)
'成功
RunInUi(Sub() FrmLinkIoi.RefreshUi())
SendUpdateRequestToAllUsers()
Catch ex As InvalidOperationException
'API 返回的错误
If InitLoader.State = LoadState.Finished Then Log("移除房间失败:" & ex.Message, LogLevel.Msgbox)
Catch ex As Exception
'常规错误
If InitLoader.State = LoadState.Finished Then Log(ex, "移除房间失败", LogLevel.Msgbox)
End Try
End Sub)
End Sub
'获取数据包
@@ -1238,21 +496,9 @@ Done:
''' 从用户列表中移除一位用户。提示信息视作该用户主动离开。
''' </summary>
Public Shared Sub UserRemove(User As LinkUserIoi, ShowLeaveMessage As Boolean)
If Not UserList.ContainsKey(User.Id) Then Exit Sub
If ShowLeaveMessage Then Hint(User.DisplayName & " 已离开!")
NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
User.Dispose()
End Sub
'关闭联机模块按钮
Private Shared Sub ModuleStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState) Handles InitLoader.OnStateChangedUi
If FrmLinkLeft IsNot Nothing Then CType(FrmLinkLeft.ItemIoi.Buttons(0), MyIconButton).Visibility = If(NewState = LoadState.Finished, Visibility.Visible, Visibility.Collapsed)
End Sub
Public Shared Sub ModuleStopManually()
IoiStop(False)
InitLoader.Error = New Exception("联机模块已关闭,点击以重新启动")
InitLoader.State = LoadState.Failed
IoiState = LoadState.Failed
End Sub
End Class
@@ -1,6 +1,4 @@
Imports NetFwTypeLib
Public Class PageLinkLeft
Public Class PageLinkLeft
Private IsLoad As Boolean = False
Private IsPageSwitched As Boolean = False '如果在 Loaded 前切换到其他页面,会导致触发 Loaded 时再次切换一次
@@ -15,84 +13,6 @@ Public Class PageLinkLeft
IsPageSwitched = False
End Sub
#Region "Windows 防火墙"
'为联机模块添加防火墙通行权限的函数库
'不加防火墙权限你要我怎么办,这联机根本连都连不上,球球你们别看到防火墙就说是后门了,真的很恼火……
''' <summary>
''' 获取某个文件是否被 Windows 防火墙阻止。
''' </summary>
Public Shared Function FirewallIsBlock(FilePath As String) As Boolean
'获取配置
If FirewallPolicy Is Nothing Then
Try
FirewallPolicy = FirewallPolicyGet()
Catch ex As Exception
Log(ex, "Windows 防火墙:可能关闭得太死了,根本检测不到,笑死", LogLevel.Normal)
Return False
End Try
End If
'检查是否开启
If Not FirewallPolicy.CurrentProfile.FirewallEnabled Then
Log("[Link] Windows 防火墙:防火墙关闭")
Return False
End If
'检查是否允许例外
If FirewallPolicy.CurrentProfile.ExceptionsNotAllowed Then
Log("[Link] Windows 防火墙:防火墙开启,不允许例外")
Return True
End If
'检查白名单
Dim Target As String = FilePath.Replace(PathTemp.Split("\").First, "").ToLower
For Each App As INetFwAuthorizedApplication In FirewallPolicy.CurrentProfile.AuthorizedApplications
If ModeDebug Then Log("[Link] 防火墙白名单(" & App.Enabled & "):" & App.ProcessImageFileName)
If Not App.Enabled Then Continue For
'信标的奇妙盘符 E:0/xxxxx/xxx 导致误判……
Dim FileNameTrimmed As String = App.ProcessImageFileName.Replace(App.ProcessImageFileName.Split("\").First, "")
If App.ProcessImageFileName.ToLower.Contains(FilePath) Then
Log("[Link] Windows 防火墙:开启,已在白名单中(" & FilePath & ")")
Return False
End If
Next
Log("[Link] Windows 防火墙:开启,未在白名单中(" & FilePath & ")")
Return True
End Function
''' <summary>
''' 添加防火墙通行权限。需要管理员权限。
''' </summary>
Public Shared Sub FirewallAddAuthorized(DisplayName As String, FilePath As String)
Log("[Link] Windows 防火墙:添加通行权限(" & FilePath & ")")
'获取配置
If FirewallPolicy Is Nothing Then FirewallPolicy = FirewallPolicyGet()
'添加项目
FirewallPolicy.GetProfileByType(NET_FW_PROFILE_TYPE_.NET_FW_PROFILE_DOMAIN).AuthorizedApplications.Add(New FirewallApp(DisplayName, FilePath))
FirewallPolicy.GetProfileByType(NET_FW_PROFILE_TYPE_.NET_FW_PROFILE_STANDARD).AuthorizedApplications.Add(New FirewallApp(DisplayName, FilePath))
FirewallPolicy.CurrentProfile.AuthorizedApplications.Add(New FirewallApp(DisplayName, FilePath))
End Sub
Private Class FirewallApp
Implements INetFwAuthorizedApplication
Public Property Name As String Implements INetFwAuthorizedApplication.Name
Public Property ProcessImageFileName As String Implements INetFwAuthorizedApplication.ProcessImageFileName
Public Property IpVersion As NET_FW_IP_VERSION_ = NET_FW_IP_VERSION_.NET_FW_IP_VERSION_ANY Implements INetFwAuthorizedApplication.IpVersion
Public Property Scope As NET_FW_SCOPE_ = NET_FW_SCOPE_.NET_FW_SCOPE_ALL Implements INetFwAuthorizedApplication.Scope
Public Property RemoteAddresses As String = "*" Implements INetFwAuthorizedApplication.RemoteAddresses
Public Property Enabled As Boolean = True Implements INetFwAuthorizedApplication.Enabled
Public Sub New(DisplayName As String, FilePath As String)
Name = DisplayName
ProcessImageFileName = FilePath
End Sub
End Class
'获取防火墙配置
Public Shared FirewallPolicy As INetFwPolicy = Nothing
Public Shared Function FirewallPolicyGet() As INetFwPolicy
Const CLSID_FIREWALL_MANAGER As String = "{304CE942-6E39-40D8-943A-B913C40C9CD4}"
Dim objType As Type = Type.GetTypeFromCLSID(New Guid(CLSID_FIREWALL_MANAGER))
Return TryCast(Activator.CreateInstance(objType), INetFwMgr).LocalPolicy
End Function
#End Region
#Region "页面切换"
''' <summary>
@@ -184,7 +104,6 @@ Public Class PageLinkLeft
PageLinkHiper.ModuleStopManually()
End Sub
Private Sub BtnIoiStop_Loaded(sender As Object, e As RoutedEventArgs)
sender.Visibility = If(PageLinkIoi.InitLoader.State = LoadState.Finished, Visibility.Visible, Visibility.Collapsed)
End Sub
Private Sub BtnIoiStop_Click(sender As Object, e As EventArgs)
PageLinkIoi.ModuleStopManually()
@@ -149,7 +149,7 @@
'进行搜索,构造列表
Dim SearchResult = Search(QueryList, SearchBox.Text, MaxBlurCount:=5, MinBlurSimilarity:=0.08)
PanSearchList.Children.Clear()
If SearchResult.Count = 0 Then
If Not SearchResult.Any() Then
PanSearch.Title = "无搜索结果"
PanSearchList.Visibility = Visibility.Collapsed
Else
@@ -129,7 +129,7 @@
Exit Sub
End If
Next
If McFolderList.Count = 0 Then
If Not McFolderList.Any() Then
Throw New ArgumentNullException("没有可用的 Minecraft 文件夹")
Else
Setup.Set("LaunchFolderSelect", McFolderList(0).Path.Replace(Path, "$"))
@@ -237,7 +237,7 @@
If Not Version.Modable Then Continue For
'4. 该版本的隔离文件夹下不存在 mods
Dim ModIndieFolder As New DirectoryInfo(Version.Path & "mods\")
If ModIndieFolder.Exists AndAlso ModIndieFolder.EnumerateFiles.Count > 0 Then Exit Sub
If ModIndieFolder.Exists AndAlso ModIndieFolder.EnumerateFiles.Any Then Exit Sub
'满足以上全部条件则视为根目录整合包
Setup.Set("VersionArgumentIndie", 2, Version:=Version)
Log("[Setup] 已自动关闭单版本隔离:" & Version.Name, LogLevel.Debug)
@@ -301,7 +301,7 @@
End If
Next
'保存
Setup.Set("LaunchFolders", If(Folders.Count = 0, "", Join(Folders.ToArray, "|")))
Setup.Set("LaunchFolders", If(Not Folders.Any(), "", Join(Folders.ToArray, "|")))
Hint(If(Folder.Type = McFolderType.Custom, "文件夹 " & Name & " 已从列表中移除!", "文件夹名称已复原!"), HintType.Finish)
McFolderListLoader.Start(IsForceRestart:=True)
@@ -325,7 +325,7 @@
Exit For
End If
Next
Setup.Set("LaunchFolders", If(Folders.Count = 0, "", Join(Folders.ToArray, "|")))
Setup.Set("LaunchFolders", If(Not Folders.Any(), "", Join(Folders.ToArray, "|")))
End If
RunInNewThread(Sub()
'删除文件夹
@@ -79,7 +79,7 @@
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<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; · {time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号" HintText="默认" MaxLength="100" />
<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.ValidateRules>
@@ -115,7 +115,7 @@
<local:MyComboBoxItem Content="中(平衡)" IsSelected="True" />
<local:MyComboBoxItem Content="低(优先保证其他程序运行,但可能让游戏卡顿,适合挂机时使用)" />
</local:MyComboBox>
<TextBlock VerticalAlignment="Center" Grid.Row="10" HorizontalAlignment="Left" Text="游戏窗口" Margin="0,0,25,0" />
<TextBlock VerticalAlignment="Center" Grid.Row="10" HorizontalAlignment="Left" Text="窗口大小" Margin="0,0,25,0" />
<Grid x:Name="PanArgumentWindow" Grid.Row="10" Grid.ColumnSpan="2" Grid.Column="1">
<Grid.ColumnDefinitions>
<ColumnDefinition />
@@ -125,11 +125,10 @@
</Grid.ColumnDefinitions>
<local:MyComboBox x:Name="ComboArgumentWindowType" Tag="LaunchArgumentWindowType">
<local:MyComboBoxItem Content="全屏" />
<local:MyComboBoxItem Content="默认大小" IsSelected="True" ToolTip="以 854×480 的默认窗口大小启动 Minecraft" />
<local:MyComboBoxItem Content="与启动器窗口大小一致" />
<local:MyComboBoxItem Content="自定义大小" ToolTip="注意:Forge 1.12 存在 Bug,会导致高度设定无效" />
<local:MyComboBoxItem Content="默认" IsSelected="True" />
<local:MyComboBoxItem Content="与启动器尺寸一致" />
<local:MyComboBoxItem Content="自定义尺寸" ToolTip="Forge 1.12.2 等个别版本存在 Bug,会导致高度设定无效" />
<local:MyComboBoxItem Content="最大化" />
<local:MyComboBoxItem Content="保持游戏默认" />
</local:MyComboBox>
<local:MyTextBox Padding="0,0,5,0" Visibility="Collapsed" Grid.Column="1" Margin="50,0,0,0" x:Name="TextArgumentWindowWidth" Tag="LaunchArgumentWindowWidth" Width="60" HorizontalContentAlignment="Center" Text="854">
<local:MyTextBox.ValidateRules>
@@ -138,7 +137,7 @@
</local:MyTextBox>
<TextBlock x:Name="LabArgumentWindowMiddle" Visibility="Collapsed" Grid.Column="2" Text=" × " VerticalAlignment="Center" FontSize="18" />
<local:MyTextBox Padding="0,0,5,0" Visibility="Collapsed" Grid.Column="3" Width="60" HorizontalContentAlignment="Center" x:Name="TextArgumentWindowHeight" Tag="LaunchArgumentWindowHeight" Text="480"
ToolTip="注意:Forge 1.12.2 等个别版本存在 Bug,会导致高度设定无效" ToolTipService.Placement="Right" ToolTipService.HorizontalOffset="5">
ToolTip="Forge 1.12.2 等个别版本存在 Bug,会导致高度设定无效" ToolTipService.Placement="Right" ToolTipService.HorizontalOffset="5">
<local:MyTextBox.ValidateRules>
<local:ValidateInteger Min="1" Max="9999" />
</local:MyTextBox.ValidateRules>
@@ -175,11 +174,16 @@
<RowDefinition Height="Auto" />
<RowDefinition Height="9" />
<RowDefinition Height="Auto" />
<RowDefinition Height="9" />
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<local:MyRadioBox Text="自动配置" Width="110" Checked="True" x:Name="RadioRamType0" Tag="LaunchRamType/0" Margin="0,0,20,0"
ToolTip="根据安装的 Mod 量与电脑剩余内存,动态调整为游戏分配的内存" ToolTipService.Placement="Right" ToolTipService.HorizontalOffset="-10" ToolTipService.VerticalOffset="-3" />
<local:MyRadioBox Grid.Row="2" Text="自定义" x:Name="RadioRamType1" Tag="LaunchRamType/1" Margin="0,0,20,0" />
<local:MySlider Grid.Row="2" Grid.Column="1" IsEnabled="False" x:Name="SliderRamCustom" Tag="LaunchRamCustom" MaxValue="49" Value="13" />
<local:MyCheckBox Grid.Row="4" Grid.ColumnSpan="3" Text="启动游戏前进行内存优化" Height="22" x:Name="CheckArgumentRam" Tag="LaunchArgumentRam"
ToolTipService.Placement="Left" ToolTipService.HorizontalOffset="525" ToolTipService.VerticalOffset="-30"
ToolTip="内存优化能将当前物理内存占用降低约 1/3,不仅限于 MC!&#xa;如果使用机械硬盘,这还可能会导致一小段时间的严重卡顿。&#xa;使用 --memory 参数启动 PCL 可以静默执行内存优化。" />
<!--<local:MyTextBox Grid.Row="2" Grid.Column="3" Width="100" VerticalAlignment="Center" Margin="30,0,0,0" Text="2048 MB" />-->
</Grid>
<Grid x:Name="PanRamDisplay" Margin="0,11,2,0" SnapsToDevicePixels="True" Grid.Row="1" Grid.ColumnSpan="2" Grid.Column="1">
@@ -229,13 +233,13 @@
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<TextBlock Grid.Row="0" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数头" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xa;你可以通过点击左侧选项卡的初始化按钮来恢复到默认设置。" Text="-XX:+UseG1GC -XX:-UseAdaptiveSizePolicy -XX:-OmitStackTraceInFastThrow -Dfml.ignoreInvalidMinecraftCertificates=True -Dfml.ignorePatchDiscrepancies=True -Dlog4j2.formatMsgNoLookups=true"
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xa;你可以通过点击左侧选项卡的初始化按钮来恢复到默认设置。" MaxLength="4000"
Height="57" AcceptsReturn="True" TextWrapping="Wrap" VerticalContentAlignment="Top" Padding="0,5" />
<TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数尾" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xa;例如输入 --demo 则会以试玩模式启动游戏。" />
<TextBlock Grid.Row="4" VerticalAlignment="Center" HorizontalAlignment="Left" Text="启动前执行命令" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceRun" Grid.Row="4" Grid.ColumnSpan="2" Tag="LaunchAdvanceRun" Grid.Column="1" HintText=""
ToolTip="在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}option.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。" />
ToolTip="在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {date}、{time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}option.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。&#xa;执行命令时,命令行所在的目录是当前的 .minecraft 文件夹。" />
<local:MyCheckBox Grid.Row="5" Grid.Column="1" x:Name="CheckAdvanceRunWait" Tag="LaunchAdvanceRunWait" Visibility="Collapsed"
Text="等待命令执行完成后再继续启动" Margin="0,8,0,7" />
<StackPanel Margin="0,12,0,4" Orientation="Horizontal" Grid.Row="6" Grid.ColumnSpan="2">
@@ -38,6 +38,7 @@
ComboArgumentWindowType.SelectedIndex = Setup.Get("LaunchArgumentWindowType")
TextArgumentWindowWidth.Text = Setup.Get("LaunchArgumentWindowWidth")
TextArgumentWindowHeight.Text = Setup.Get("LaunchArgumentWindowHeight")
CheckArgumentRam.Checked = Setup.Get("LaunchArgumentRam")
RefreshJavaComboBox()
'游戏内存
@@ -71,6 +72,7 @@
Setup.Reset("LaunchArgumentWindowWidth")
Setup.Reset("LaunchArgumentWindowHeight")
Setup.Reset("LaunchArgumentPriority")
Setup.Reset("LaunchArgumentRam")
Setup.Reset("LaunchRamType")
Setup.Reset("LaunchRamCustom")
Setup.Reset("LaunchSkinType")
@@ -108,7 +110,7 @@
Private Shared Sub ComboChange(sender As MyComboBox, e As Object) Handles ComboArgumentIndie.SelectionChanged, ComboArgumentVisibie.SelectionChanged, ComboArgumentWindowType.SelectionChanged, ComboArgumentPriority.SelectionChanged
If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.SelectedIndex)
End Sub
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckAdvanceAssets.Change, CheckAdvanceJava.Change, CheckAdvanceRunWait.Change
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckAdvanceAssets.Change, CheckAdvanceJava.Change, CheckAdvanceRunWait.Change, CheckArgumentRam.Change
If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.Checked)
End Sub
@@ -352,19 +354,19 @@
'可安装 Mod 的版本
Dim ModDir As New DirectoryInfo(Version.PathIndie & "mods\")
Dim ModCount As Integer = If(ModDir.Exists, ModDir.GetFiles.Length, 0)
RamMininum = 0.4 + ModCount / 150
RamTarget1 = 1.5 + ModCount / 100
RamTarget2 = 3 + ModCount / 60
RamTarget3 = 6 + ModCount / 30
RamMininum = 0.5 + ModCount / 150
RamTarget1 = 1.5 + ModCount / 90
RamTarget2 = 2.7 + ModCount / 50
RamTarget3 = 4.5 + ModCount / 25
ElseIf Version IsNot Nothing AndAlso Version.Version.HasOptiFine Then
'OptiFine 版本
RamMininum = 0.3
RamMininum = 0.5
RamTarget1 = 1.5
RamTarget2 = 3
RamTarget3 = 6
RamTarget3 = 5
Else
'普通版本
RamMininum = 0.3
RamMininum = 0.5
RamTarget1 = 1.5
RamTarget2 = 2.5
RamTarget3 = 4
@@ -372,27 +374,23 @@
Dim RamDelta As Double
'预分配内存,阶段一,0 ~ T1,100%
RamDelta = RamTarget1
RamAvailable = Math.Max(0, RamAvailable - 0.1)
RamGive += Math.Min(RamAvailable * 1, RamDelta)
RamAvailable -= RamDelta / 1 + 0.1
RamGive += Math.Min(RamAvailable, RamDelta)
RamAvailable -= RamDelta
If RamAvailable < 0.1 Then GoTo PreFin
'预分配内存,阶段二,T1 ~ T2,80%
'预分配内存,阶段二,T1 ~ T2,70%
RamDelta = RamTarget2 - RamTarget1
RamAvailable = Math.Max(0, RamAvailable - 0.1)
RamGive += Math.Min(RamAvailable * 0.8, RamDelta)
RamAvailable -= RamDelta / 0.8 + 0.1
RamGive += Math.Min(RamAvailable * 0.7, RamDelta)
RamAvailable -= RamDelta / 0.7
If RamAvailable < 0.1 Then GoTo PreFin
'预分配内存,阶段三,T2 ~ T3,60%
'预分配内存,阶段三,T2 ~ T3,40%
RamDelta = RamTarget3 - RamTarget2
RamAvailable = Math.Max(0, RamAvailable - 0.2)
RamGive += Math.Min(RamAvailable * 0.6, RamDelta)
RamAvailable -= RamDelta / 0.6 + 0.2
If RamAvailable < 0.1 Then GoTo PreFin
'预分配内存,阶段四,T3 ~ T3 * 2,40%
RamDelta = RamTarget3
RamAvailable = Math.Max(0, RamAvailable - 0.3)
RamGive += Math.Min(RamAvailable * 0.4, RamDelta)
RamAvailable -= RamDelta / 0.4 + 0.3
RamAvailable -= RamDelta / 0.4
If RamAvailable < 0.1 Then GoTo PreFin
'预分配内存,阶段四,T3 ~ T3 * 2,15%
RamDelta = RamTarget3
RamGive += Math.Min(RamAvailable * 0.15, RamDelta)
RamAvailable -= RamDelta / 0.15
If RamAvailable < 0.1 Then GoTo PreFin
PreFin:
'不低于最低值
@@ -444,7 +442,7 @@ PreFin:
Log(ex, "更新设置 Java 下拉框失败", LogLevel.Feedback)
End Try
'更新选择项
If SelectedItem Is Nothing AndAlso JavaList.Count > 0 Then SelectedItem = ComboArgumentJava.Items(0) '选中 “自动选择”
If SelectedItem Is Nothing AndAlso JavaList.Any Then SelectedItem = ComboArgumentJava.Items(0) '选中 “自动选择”
ComboArgumentJava.SelectedItem = SelectedItem
'结束处理
If SelectedItem Is Nothing Then
@@ -515,15 +513,16 @@ PreFin:
Hint("正在搜索 Java,请稍候!", HintType.Critical)
Exit Sub
End If
RunInThread(Sub()
Hint("正在搜索 Java!")
JavaSearchLoader.WaitForExit(IsForceRestart:=True)
If JavaList.Count = 0 Then
Hint("未找到可用的 Java!", HintType.Critical)
Else
Hint("已找到 " & JavaList.Count & " 个 Java,请检查下拉框查看列表!", HintType.Finish)
End If
End Sub)
RunInThread(
Sub()
Hint("正在搜索 Java!")
JavaSearchLoader.WaitForExit(IsForceRestart:=True)
If Not JavaList.Any() Then
Hint("未找到可用的 Java!", HintType.Critical)
Else
Hint("已找到 " & JavaList.Count & " 个 Java,请检查下拉框查看列表!", HintType.Finish)
End If
End Sub)
End Sub
#End Region
@@ -548,12 +547,24 @@ PreFin:
If AniControlEnabled <> 0 Then Exit Sub
If ComboArgumentVisibie.SelectedIndex = 0 Then
If MyMsgBox("若在游戏启动后立即关闭启动器,崩溃检测、更改游戏标题等功能将失效。" & vbCrLf &
"如果想保留这些功能,可以选择让启动器在游戏启动后隐藏,游戏退出后自动关闭。", "提示", "继续", "取消") = 2 Then
"如果想保留这些功能,可以选择让启动器在游戏启动后隐藏,游戏退出后自动关闭。", "提醒", "继续", "取消") = 2 Then
ComboArgumentVisibie.SelectedItem = e.RemovedItems(0)
End If
End If
End Sub
'开启自动内存优化的警告
Private Sub CheckArgumentRam_Change() Handles CheckArgumentRam.Change
If AniControlEnabled <> 0 Then Exit Sub
If Not CheckArgumentRam.Checked Then Return
If MyMsgBox("内存优化耗时较长,这会拖慢游戏的启动过程,建议仅在电脑内存不充裕时开启此选项。" & vbCrLf &
"如果你在使用机械硬盘,这还可能会导致一小段时间的严重卡顿。" &
If(IsAdmin(), "", $"{vbCrLf}{vbCrLf}每次启动游戏,PCL 都需要申请管理员权限以进行内存优化。{vbCrLf}若想自动授予权限,可以右键 PCL,打开 属性 → 兼容性 → 以管理员身份运行此程序。"),
"提醒", "确定", "取消") = 2 Then
CheckArgumentRam.Checked = False
End If
End Sub
#End Region
#Region "高级设置"
@@ -26,6 +26,7 @@
<RowDefinition Height="Auto" />
<RowDefinition Height="Auto" />
<RowDefinition Height="Auto" />
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<TextBlock VerticalAlignment="Center" HorizontalAlignment="Left" Text="版本列表获取" Margin="0,0,25,0" />
<local:MyComboBox x:Name="ComboDownloadVersion" Grid.ColumnSpan="2" Tag="ToolDownloadVersion" Grid.Column="1">
@@ -55,6 +56,9 @@
<local:MyCheckBox Margin="0,2,0,4" Text="简化 Mod 加载器显示" Grid.Row="8" Height="22" Grid.ColumnSpan="2"
x:Name="CheckDownloadIgnoreQuilt" Tag="ToolDownloadIgnoreQuilt"
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;进行验证会提高安全性,但疑似会导致少部分玩家的微软登录失败。" />
</Grid>
</StackPanel>
</local:MyCard>
@@ -58,6 +58,7 @@
ComboDownloadTranslate.SelectedIndex = Setup.Get("ToolDownloadTranslate")
CheckDownloadKeepModpack.Checked = Setup.Get("ToolDownloadKeepModpack")
CheckDownloadIgnoreQuilt.Checked = Setup.Get("ToolDownloadIgnoreQuilt")
CheckDownloadCert.Checked = Setup.Get("ToolDownloadCert")
'Minecraft 更新提示
CheckUpdateRelease.Checked = Setup.Get("ToolUpdateRelease")
@@ -88,6 +89,7 @@
Setup.Reset("ToolDownloadTranslate")
Setup.Reset("ToolDownloadKeepModpack")
Setup.Reset("ToolDownloadIgnoreQuilt")
Setup.Reset("ToolDownloadCert")
Setup.Reset("ToolUpdateRelease")
Setup.Reset("ToolUpdateSnapshot")
Setup.Reset("ToolHelpChinese")
@@ -109,7 +111,7 @@
End Sub
'将控件改变路由到设置改变
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckDebugMode.Change, CheckDebugDelay.Change, CheckDebugSkipCopy.Change, CheckUpdateRelease.Change, CheckUpdateSnapshot.Change, CheckHelpChinese.Change, CheckDownloadKeepModpack.Change, CheckDownloadIgnoreQuilt.Change
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckDebugMode.Change, CheckDebugDelay.Change, CheckDebugSkipCopy.Change, CheckUpdateRelease.Change, CheckUpdateSnapshot.Change, CheckHelpChinese.Change, CheckDownloadKeepModpack.Change, CheckDownloadIgnoreQuilt.Change, CheckDownloadCert.Change
If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.Checked)
End Sub
Private Shared Sub SliderChange(sender As MySlider, e As Object) Handles SliderDebugAnim.Change, SliderDownloadThread.Change, SliderDownloadSpeed.Change
@@ -124,23 +126,21 @@
'滑动条
Private Sub SliderLoad()
SliderDownloadThread.GetHintText = Function(Value As Integer)
Return Value + 1
End Function
SliderDownloadSpeed.GetHintText = Function(Value As Integer)
If Value <= 14 Then
Return (Value + 1) * 0.1 & " M/s"
ElseIf Value <= 31 Then
Return (Value - 11) * 0.5 & " M/s"
ElseIf Value <= 41 Then
Return (Value - 21) & " M/s"
Else
Return "无限制"
End If
End Function
SliderDebugAnim.GetHintText = Function(Value As Integer)
Return If(Value > 29, "关闭", (Value / 10 + 0.1) & "x")
End Function
SliderDownloadThread.GetHintText = Function(v) v + 1
SliderDownloadSpeed.GetHintText =
Function(v)
Select Case v
Case Is <= 14
Return (v + 1) * 0.1 & " M/s"
Case Is <= 31
Return (v - 11) * 0.5 & " M/s"
Case Is <= 41
Return (v - 21) & " M/s"
Case Else
Return "无限制"
End Select
End Function
SliderDebugAnim.GetHintText = Function(v) If(v > 29, "关闭", (v / 10 + 0.1) & "x")
End Sub
Private Sub SliderDownloadThread_PreviewChange(sender As Object, e As RouteEventArgs) Handles SliderDownloadThread.PreviewChange
If SliderDownloadThread.Value < 100 Then Exit Sub
@@ -36,7 +36,7 @@
Try
#Region "更新左边栏"
If LoaderTaskbar.Count = 0 Then
If Not LoaderTaskbar.Any() Then
'无任务
LabProgress.Text = "100 %"
LabSpeed.Text = "0 B/s"
@@ -214,13 +214,14 @@
End Sub
Public Sub TaskRemove(Loader As Object)
If RightCards.ContainsKey(Loader.Name) Then
RunInUiWait(Sub()
'移除已有的卡片
Dim Card As Grid = RightCards(Loader.Name)
FrmSpeedRight.PanMain.Children.Remove(Card)
RightCards.Remove(Loader.Name)
Log($"[Watcher] 移除下载管理卡片:{Loader.Name}")
End Sub)
RunInUiWait(
Sub()
'移除已有的卡片
Dim Card As Grid = RightCards(Loader.Name)
FrmSpeedRight.PanMain.Children.Remove(Card)
RightCards.Remove(Loader.Name)
Log($"[Watcher] 移除下载管理卡片:{Loader.Name}")
End Sub)
End If
End Sub
@@ -47,6 +47,8 @@
</local:MyCard.RenderTransform>
<TextBlock x:Name="LabSelect" Text="已选择 8 个文件" HorizontalAlignment="Center" VerticalAlignment="Top" Margin="9" Foreground="{DynamicResource ColorBrush2}" />
<StackPanel Orientation="Horizontal" Margin="5,28,5,5">
<local:MyIconTextButton x:Name="BtnSelectUpdate" Text="更新"
LogoScale="1" Logo="M640 768H384l-32-32V509H213L190 454l298-298h45l298 298L810 509h-138v226z m-224-64h192V477l32-32h93L512 223 290 445H384l32 32zM352 831h320v64h-320z" />
<local:MyIconTextButton x:Name="BtnSelectEnable" Text="启用"
LogoScale="1.05" Logo="M512 0a512 512 0 1 0 512 512A512 512 0 0 0 512 0z m0 921.6a409.6 409.6 0 1 1 409.6-409.6 409.6 409.6 0 0 1-409.6 409.6z M716.8 339.968l-256 253.44L328.192 460.8A51.2 51.2 0 0 0 256 532.992l168.448 168.96a51.2 51.2 0 0 0 72.704 0l289.28-289.792A51.2 51.2 0 0 0 716.8 339.968z" />
<local:MyIconTextButton x:Name="BtnSelectDisable" Text="禁用"
@@ -25,7 +25,6 @@
''' 刷新 Mod 列表。
''' </summary>
Public Sub RefreshList(Optional ForceReload As Boolean = False)
If McModLoader.State = LoadState.Loading Then Exit Sub
If LoaderFolderRun(McModLoader, PageVersionLeft.Version.PathIndie & "mods\", If(ForceReload, LoaderFolderRunType.ForceRun, LoaderFolderRunType.RunOnUpdated)) Then
Log("[System] 已刷新 Mod 列表")
PanBack.ScrollToHome()
@@ -65,12 +64,12 @@
PanBack.Visibility = Visibility.Collapsed
Exit Sub
End If
SearchBox.Text = ""
'输出结果
ModItems.Clear()
For Each ModEntity As McMod In Mods
ModItems(ModEntity.RawFileName) = McModListItem(ModEntity)
Next
SearchBox.Text = "" '这会触发结果刷新,所以需要在 ModItems 更新之后,详见 #3124 的视频
RefreshResult(Mods)
Catch ex As Exception
Log(ex, "加载 Mod 列表 UI 失败", LogLevel.Feedback)
@@ -80,7 +79,7 @@
AniControlEnabled += 1
Dim NewItem As New MyLocalModItem With {.SnapsToDevicePixels = True, .Entry = Entry,
.ButtonHandler = AddressOf McModContent, .Checked = SelectedMods.Contains(Entry.RawFileName)}
AddHandler Entry.OnGetCompProject, AddressOf NewItem.Refresh
AddHandler Entry.OnCompUpdate, AddressOf NewItem.Refresh
NewItem.Refresh()
AniControlEnabled -= 1
Return NewItem
@@ -102,17 +101,14 @@
ToolTipService.SetVerticalOffset(BtnCont, 30)
ToolTipService.SetHorizontalOffset(BtnCont, 2)
AddHandler BtnCont.Click, AddressOf Info_Click
AddHandler sender.MouseRightButtonDown, AddressOf Info_Click
AddHandler sender.MouseRightButtonUp, AddressOf Info_Click
Dim BtnDelete As New MyIconButton With {.LogoScale = 1, .Logo = Logo.IconButtonDelete, .Tag = sender}
BtnDelete.ToolTip = "删除"
ToolTipService.SetPlacement(BtnDelete, Primitives.PlacementMode.Center)
ToolTipService.SetVerticalOffset(BtnDelete, 30)
ToolTipService.SetHorizontalOffset(BtnDelete, 2)
AddHandler BtnDelete.Click, AddressOf Delete_Click
Dim BtnED As New MyIconButton With {.LogoScale = 1, .Logo = If(sender.Entry.State = McMod.McModState.Fine,
"M508 990.4c-261.6 0-474.4-212-474.4-474.4S246.4 41.6 508 41.6s474.4 212 474.4 474.4S769.6 990.4 508 990.4zM508 136.8c-209.6 0-379.2 169.6-379.2 379.2 0 209.6 169.6 379.2 379.2 379.2s379.2-169.6 379.2-379.2C887.2 306.4 717.6 136.8 508 136.8zM697.6 563.2 318.4 563.2c-26.4 0-47.2-21.6-47.2-47.2 0-26.4 21.6-47.2 47.2-47.2l379.2 0c26.4 0 47.2 21.6 47.2 47.2C744.8 542.4 724 563.2 697.6 563.2z",
"M512 0a512 512 0 1 0 512 512A512 512 0 0 0 512 0z m0 921.6a409.6 409.6 0 1 1 409.6-409.6 409.6 409.6 0 0 1-409.6 409.6z M716.8 339.968l-256 253.44L328.192 460.8A51.2 51.2 0 0 0 256 532.992l168.448 168.96a51.2 51.2 0 0 0 72.704 0l289.28-289.792A51.2 51.2 0 0 0 716.8 339.968z"),
.Tag = sender}
Dim BtnED As New MyIconButton With {.LogoScale = 1, .Logo = If(sender.Entry.State = McMod.McModState.Fine, Logo.IconButtonStop, Logo.IconButtonCheck), .Tag = sender}
BtnED.ToolTip = If(sender.Entry.State = McMod.McModState.Fine, "禁用", "启用")
ToolTipService.SetPlacement(BtnED, Primitives.PlacementMode.Center)
ToolTipService.SetVerticalOffset(BtnED, 30)
@@ -181,7 +177,7 @@
Private Sub BtnManageCheck_Click(sender As Object, e As EventArgs) Handles BtnManageCheck.Click
Try
Dim Result = McModCheck(PageVersionLeft.Version, McModLoader.Output)
If Result.Count > 0 Then
If Result.Any Then
MyMsgBox(Join(Result, vbCrLf & vbCrLf), "Mod 检查结果")
Else
Hint("Mod 检查完成,未发现任何问题!", HintType.Finish)
@@ -240,10 +236,12 @@
If Selected Then LabSelect.Text = $"已选择 {NewCount} 个文件" '取消所有选择时不更新数字
'按钮可用性
If Selected Then
Dim HasUpdate As Boolean = False
Dim HasEnabled As Boolean = False
Dim HasDisabled As Boolean = False
For Each ModEntity In McModLoader.Output
If SelectedMods.Contains(ModEntity.RawFileName) Then
If ModEntity.CanUpdate Then HasUpdate = True
If ModEntity.State = McMod.McModState.Fine Then
HasEnabled = True
ElseIf ModEntity.State = McMod.McModState.Disabled Then
@@ -253,9 +251,9 @@
Next
BtnSelectDisable.IsEnabled = HasEnabled
BtnSelectEnable.IsEnabled = HasDisabled
BtnSelectUpdate.IsEnabled = HasUpdate
End If
'更新显示状态
CardSelect.IsHitTestVisible = Selected
If AniControlEnabled = 0 Then
If Selected Then
'仅在数量增加时播放出现/跳跃动画
@@ -333,20 +331,33 @@
End Sub
Private Sub EDMods(ModList As IEnumerable(Of McMod), IsEnable As Boolean)
Dim IsSuccessful As Boolean = True
For Each ModEntity In ModList.ToList
For Each ModE In ModList.ToList
Dim ModEntity = ModE '仅用于去除迭代变量无法修改的限制
Dim NewPath As String = Nothing
If ModEntity.State = McMod.McModState.Fine AndAlso Not IsEnable Then
'禁用
NewPath = ModEntity.Path & ".disabled"
NewPath = ModEntity.Path & If(File.Exists(ModEntity.Path & ".old"), ".old", ".disabled")
ElseIf ModEntity.State = McMod.McModState.Disabled AndAlso IsEnable Then
'启用
NewPath = ModEntity.Path.Replace(".disabled", "").Replace(".old", "")
NewPath = ModEntity.RawPath
Else
Continue For
End If
'重命名
Try
If File.Exists(NewPath) AndAlso Not File.Exists(ModEntity.Path) Then Continue For '因为未知原因 Mod 的状态已经切换完了
If File.Exists(NewPath) Then
If File.Exists(ModEntity.Path) Then
'同时存在两个名称的 Mod
If GetFileMD5(ModEntity.Path) <> GetFileMD5(NewPath) Then
MyMsgBox($"目前同时存在启用和禁用的两个 Mod 文件:{vbCrLf} - {NewPath}{vbCrLf} - {ModEntity.Path}{vbCrLf}{vbCrLf}注意,这两个文件的内容并不相同。{vbCrLf}在手动删除或重命名其中一个文件后,才能继续操作。", "存在文件冲突")
Continue For
End If
Else
'已经重命名过了
Log("[Mod] Mod 的状态已被切换", LogLevel.Debug)
Continue For
End If
End If
File.Delete(NewPath)
FileSystem.Rename(ModEntity.Path, NewPath)
Catch ex As FileNotFoundException
@@ -359,7 +370,7 @@
End Try
'更改 Loader 中的列表
Dim NewModEntity As New McMod(NewPath)
NewModEntity.Comp = ModEntity.Comp
NewModEntity.FromJson(ModEntity.ToJson)
Dim IndexOfLoader As Integer = McModLoader.Output.IndexOf(ModEntity)
McModLoader.Output.RemoveAt(IndexOfLoader)
McModLoader.Output.Insert(IndexOfLoader, NewModEntity)
@@ -380,15 +391,143 @@
End If
End Sub
'更新
Private Sub BtnSelectUpdate_Click() Handles BtnSelectUpdate.Click
UpdateMods(McModLoader.Output.Where(Function(m) SelectedMods.Contains(m.RawFileName) AndAlso m.CanUpdate))
End Sub
''' <summary>
''' 记录正在进行 Mod 更新的 mods 文件夹路径。
''' </summary>
Public Shared UpdatingVersions As New List(Of String)
Public Sub UpdateMods(ModList As IEnumerable(Of McMod))
'更新前警告
If Not Setup.Get("HintUpdateMod") Then
If MyMsgBox($"新版本 Mod 可能不兼容老版本的存档或者其他 Mod,这可能导致游戏崩溃,甚至存档损坏!{vbCrLf}除非整合包作者要求你更新,否则不要私自更新整合包里的 Mod!{vbCrLf}在更新 Mod 前,请先备份存档,并检查它的更新日志!{vbCrLf}更新时,老版本的 Mod 会被移动到回收站,以防万一。{vbCrLf}{vbCrLf}请在认真阅读上述警告后再继续!", "Mod 更新警告", "我已了解上述风险,继续更新", "取消", IsWarn:=True) = 1 Then
Setup.Set("HintUpdateMod", True)
Else
Exit Sub
End If
End If
Try
'构造下载信息
ModList = ModList.ToList() '防止刷新影响迭代器
Dim FileList As New List(Of NetFile)
Dim FileCopyList As New Dictionary(Of String, String)
For Each Entry As McMod In ModList
Dim File As CompFile = Entry.UpdateFile
If Not File.Available Then Continue For
'确认更新后的文件名
Dim CurrentReplaceName = Entry.CompFile.FileName.Replace(".jar", "").Replace(".old", "").Replace(".disabled", "")
Dim NewestReplaceName = Entry.UpdateFile.FileName.Replace(".jar", "").Replace(".old", "").Replace(".disabled", "")
Dim CurrentSegs = CurrentReplaceName.Split("-"c).ToList()
Dim NewestSegs = NewestReplaceName.Split("-"c).ToList()
Dim Shortened As Boolean = False
For Each Seg In CurrentSegs.ToList()
If Not NewestSegs.Contains(Seg) Then Continue For
CurrentSegs.Remove(Seg)
NewestSegs.Remove(Seg)
Shortened = True
Next
If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then
CurrentReplaceName = Join(CurrentSegs, "-")
NewestReplaceName = Join(NewestSegs, "-")
End If
'添加到下载列表
Dim TempAddress As String = PathTemp & "DownloadedMods\" & Entry.FileName.Replace(CurrentReplaceName, NewestReplaceName)
Dim RealAddress As String = GetPathFromFullPath(Entry.Path) & Entry.FileName.Replace(CurrentReplaceName, NewestReplaceName)
FileList.Add(File.ToNetFile(TempAddress))
FileCopyList(TempAddress) = RealAddress
Next
'构造加载器
Dim InstallLoaders As New List(Of LoaderBase)
Dim FinishedFileNames As New List(Of String)
InstallLoaders.Add(New LoaderDownload("下载新版 Mod 文件", FileList) With {.ProgressWeight = ModList.Count * 1.5}) '每个 Mod 需要 1.5s
InstallLoaders.Add(New LoaderTask(Of Integer, Integer)("替换旧版 Mod 文件",
Sub()
Try
For Each Entry As McMod In ModList
If File.Exists(Entry.Path) Then
My.Computer.FileSystem.DeleteFile(Entry.Path, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin)
Else
Log($"[Mod] 未找到更新前的 Mod 文件,跳过对它的删除:{Entry.Path}", LogLevel.Debug)
End If
Next
For Each Entry As KeyValuePair(Of String, String) In FileCopyList
If File.Exists(Entry.Value) Then
My.Computer.FileSystem.DeleteFile(Entry.Value, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin)
Log($"[Mod] 更新后的 Mod 文件已存在,将会把它放入回收站:{Entry.Value}", LogLevel.Debug)
End If
If Directory.Exists(GetPathFromFullPath(Entry.Value)) Then
File.Move(Entry.Key, Entry.Value)
FinishedFileNames.Add(GetFileNameFromPath(Entry.Value))
Else
Log($"[Mod] 更新后的目标文件夹已被删除:{Entry.Value}", LogLevel.Debug)
End If
Next
Catch ex As OperationCanceledException
Log(ex, "替换旧版 Mod 文件时被主动取消")
End Try
End Sub))
'结束处理
Dim Loader As New LoaderCombo(Of IEnumerable(Of McMod))("Mod 更新:" & PageVersionLeft.Version.Name, InstallLoaders)
Dim PathMods As String = PageVersionLeft.Version.PathIndie & "mods\"
Loader.OnStateChanged =
Sub()
'结果提示
Select Case Loader.State
Case LoadState.Finished
Hint(If(FinishedFileNames.Count > 1, $"已成功更新 {FinishedFileNames.Count} 个 Mod!", $"已成功更新:{FinishedFileNames.Single}"), HintType.Finish)
Case LoadState.Failed
Hint("Mod 更新失败:" & GetExceptionSummary(Loader.Error), HintType.Critical)
Case LoadState.Aborted
Hint("Mod 更新已中止!", HintType.Info)
Case Else
Exit Sub
End Select
UpdatingVersions.Remove(PathMods)
'清理缓存
RunInNewThread(
Sub()
Try
For Each TempFile In FileCopyList.Keys
If File.Exists(TempFile) Then File.Delete(TempFile)
Next
Catch ex As Exception
Log(ex, "清理 Mod 更新缓存失败")
End Try
End Sub, "Clean Mod Update Cache", ThreadPriority.BelowNormal)
End Sub
'启动加载器
Log($"[Mod] 开始更新 {ModList.Count} 个 Mod")
UpdatingVersions.Add(PathMods)
Loader.Start()
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
RefreshList(True)
Catch ex As Exception
Log(ex, "初始化 Mod 更新失败")
End Try
End Sub
'删除
Private Sub BtnSelectDelete_Click() Handles BtnSelectDelete.Click
Dim DeleteList As List(Of McMod) = McModLoader.Output.Where(Function(m) SelectedMods.Contains(m.RawFileName)).ToList()
DeleteMods(DeleteList)
DeleteMods(McModLoader.Output.Where(Function(m) SelectedMods.Contains(m.RawFileName)))
End Sub
Private Sub DeleteMods(ModList As IEnumerable(Of McMod))
Try
Dim IsSuccessful As Boolean = True
Dim IsShiftPressed As Boolean = My.Computer.Keyboard.ShiftKeyDown
'确认需要删除的文件
ModList = ModList.SelectMany(
Function(Target As McMod)
If Target.State = McMod.McModState.Fine Then
Return {Target.Path, Target.Path & If(File.Exists(Target.Path & ".old"), ".old", ".disabled")}
Else
Return {Target.Path, Target.RawPath}
End If
End Function).Distinct.Where(Function(m) File.Exists(m)).Select(Function(m) New McMod(m)).ToList()
'实际删除文件
For Each ModEntity In ModList
'删除
Try
@@ -410,8 +549,8 @@
'更改 Loader 和 UI 中的列表
McModLoader.Output.Remove(ModEntity)
ModItems.Remove(ModEntity.RawFileName)
Dim IndexOfUi As Integer = PanList.Children.IndexOf(PanList.Children.OfType(Of MyLocalModItem).First(Function(i) i.Entry Is ModEntity))
PanList.Children.RemoveAt(IndexOfUi)
Dim IndexOfUi As Integer = PanList.Children.IndexOf(PanList.Children.OfType(Of MyLocalModItem).FirstOrDefault(Function(i) i.Entry.Equals(ModEntity)))
If IndexOfUi >= 0 Then PanList.Children.RemoveAt(IndexOfUi)
Next
RefreshTitle()
If Not IsSuccessful Then
@@ -481,13 +620,13 @@
If ModEntry.ModId IsNot Nothing Then
DebugInfo.Add("Mod ID:" & ModEntry.ModId)
End If
If ModEntry.Dependencies.Count > 0 Then
If ModEntry.Dependencies.Any Then
DebugInfo.Add("依赖于:")
For Each Dep In ModEntry.Dependencies
DebugInfo.Add(" - " & Dep.Key & If(Dep.Value Is Nothing, "", ",版本:" & Dep.Value))
Next
End If
If DebugInfo.Count > 0 Then
If DebugInfo.Any Then
ContentLines.Add("")
ContentLines.AddRange(DebugInfo)
End If
@@ -26,7 +26,7 @@
<RowDefinition Height="28" />
</Grid.RowDefinitions>
<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="VersionArgumentTitle" Grid.Column="1" ToolTip="自定义游戏窗口的标题,若留空则使用全局设置的值。&#xa;支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {name}:游戏版本名&#xa; · {time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号" HintText="使用全局设置" MaxLength="100" />
<local:MyTextBox x:Name="TextArgumentTitle" Grid.Row="0" Grid.ColumnSpan="2" Tag="VersionArgumentTitle" 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="VersionArgumentInfo" Grid.Column="1" HintText="使用全局设置" ToolTip="该信息会显示在游戏主界面的左下角,与 F3 调试页面的左上角。&#xa;若留空,则使用全局设置的值。">
<local:MyTextBox.ValidateRules>
@@ -168,10 +168,8 @@
<Grid Height="35" Name="PanServerNide" Margin="0,12,0,0">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" SharedSizeGroup="Button" />
<ColumnDefinition Width="Auto" SharedSizeGroup="Button" />
</Grid.ColumnDefinitions>
<local:MyButton x:Name="BtnServerNideWeb" Grid.Column="0" MinWidth="140" Text="服主后台" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" ColorType="Highlight" />
<local:MyButton x:Name="BtnServerNideBbs" Grid.Column="1" MinWidth="140" Text="查看简介" Padding="13,0" Margin="0,0,20,0" HorizontalAlignment="Left" />
</Grid>
<local:MyButton x:Name="BtnServerAuthLittle" Height="35" MinWidth="150" Margin="0,12,0,0" Text="设置为 LittleSkin" HorizontalAlignment="Left" ColorType="Highlight" />
</StackPanel>
@@ -193,13 +191,13 @@
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<TextBlock Grid.Row="0" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数头" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="VersionAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xa;若留空,则使用全局设置的值。" HintText="使用全局设置"
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="VersionAdvanceJvm" Grid.Column="1" MaxLength="4000" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xa;若留空,则使用全局设置的值。" HintText="使用全局设置"
Height="57" AcceptsReturn="True" TextWrapping="Wrap" VerticalContentAlignment="Top" Padding="0,5" />
<TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数尾" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="2" Grid.ColumnSpan="2" Tag="VersionAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xa;例如输入 --demo 则会以试玩模式启动游戏。&#xa;若留空,则使用全局设置的值。" HintText="使用全局设置" />
<TextBlock Grid.Row="4" VerticalAlignment="Center" HorizontalAlignment="Left" Text="启动前执行命令" Margin="0,0,25,3" />
<local:MyTextBox x:Name="TextAdvanceRun" Grid.Row="4" Grid.ColumnSpan="2" Tag="VersionAdvanceRun" Grid.Column="1" HintText="" Margin="0,0,0,3"
ToolTip="该项不会覆盖全局设置:启动时会先执行全局设置的命令,再执行版本设置的命令。&#xa;&#xa;在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}option.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。" />
ToolTip="该项不会覆盖全局设置:启动时会先执行全局设置的命令,再执行版本设置的命令。&#xa;&#xa;在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {date}、{time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}option.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。&#xa;执行命令时,命令行所在的目录是当前的 .minecraft 文件夹。" />
<local:MyCheckBox Grid.Row="5" Grid.Column="1" x:Name="CheckAdvanceRunWait" Tag="VersionAdvanceRunWait" Visibility="Collapsed"
Text="等待命令执行完成后再继续启动" Margin="0,5,0,0" />
<StackPanel Margin="0,10,0,0" Orientation="Horizontal" Grid.Row="6" Grid.ColumnSpan="2">
@@ -33,7 +33,7 @@
If Indie = -1 Then
Dim ModFolder As New DirectoryInfo(PageVersionLeft.Version.Path & "mods\")
Dim SaveFolder As New DirectoryInfo(PageVersionLeft.Version.Path & "saves\")
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Count > 0) OrElse (SaveFolder.Exists AndAlso SaveFolder.EnumerateFiles.Count > 0) Then
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Any) OrElse (SaveFolder.Exists AndAlso SaveFolder.EnumerateFiles.Any) Then
'自动开启
Setup.Set("VersionArgumentIndie", 1, Version:=PageVersionLeft.Version)
Log("[Setup] 已自动开启单版本隔离:" & PageVersionLeft.Version.Name)
@@ -121,9 +121,10 @@
End Sub
Private Shared Sub TextBoxChange(sender As MyTextBox, e As Object) Handles TextServerEnter.ValidatedTextChanged, TextArgumentInfo.ValidatedTextChanged, TextAdvanceGame.ValidatedTextChanged, TextAdvanceJvm.ValidatedTextChanged, TextServerNide.ValidatedTextChanged, TextServerAuthName.ValidatedTextChanged, TextServerAuthRegister.ValidatedTextChanged, TextServerAuthServer.ValidatedTextChanged, TextArgumentTitle.ValidatedTextChanged, TextAdvanceRun.ValidatedTextChanged
If AniControlEnabled = 0 Then
Dim HandledText As String = sender.Text
If sender.Tag = "VersionServerAuthServer" OrElse sender.Tag = "VersionServerAuthRegister" Then HandledText = HandledText.TrimEnd("/")
Setup.Set(sender.Tag, HandledText, Version:=PageVersionLeft.Version)
'#3194,不能删减 /
'Dim HandledText As String = sender.Text
'If sender.Tag = "VersionServerAuthServer" OrElse sender.Tag = "VersionServerAuthRegister" Then HandledText = HandledText.TrimEnd("/")
Setup.Set(sender.Tag, sender.Text, Version:=PageVersionLeft.Version)
End If
End Sub
Private Shared Sub SliderChange(sender As MySlider, e As Object) Handles SliderRamCustom.Change
@@ -398,14 +399,12 @@ PreFin:
Private Sub BtnServerNideWeb_Click(sender As Object, e As EventArgs) Handles BtnServerNideWeb.Click
OpenWebsite("https://login.mc-user.com:233/server/intro")
End Sub
Private Sub BtnServerNideBbs_Click(sender As Object, e As EventArgs) Handles BtnServerNideBbs.Click
OpenWebsite("https://www.mcbbs.net/thread-729821-1-1.html")
End Sub
'LittleSkin
Private Sub BtnServerAuthLittle_Click(sender As Object, e As EventArgs) Handles BtnServerAuthLittle.Click
If TextServerAuthServer.Text <> "" AndAlso TextServerAuthServer.Text <> "https://littleskin.cn/api/yggdrasil" AndAlso
MyMsgBox("即将把第三方登录设置覆盖为自动使用 LittleSkin 登录,是否继续?", "覆盖确认", "确定", "取消") = 2 Then Exit Sub
MyMsgBox("即将把第三方登录设置覆盖为 LittleSkin 登录。" & vbCrLf & "除非你是服主,或者服主要求你这样做,否则请不要继续。" & vbCrLf & vbCrLf & "是否确实需要覆盖当前设置?",
"设置覆盖确认", "继续", "取消") = 2 Then Exit Sub
TextServerAuthServer.Text = "https://littleskin.cn/api/yggdrasil"
TextServerAuthRegister.Text = "https://littleskin.cn/auth/register"
TextServerAuthName.Text = "LittleSkin 登录"
@@ -439,7 +438,7 @@ PreFin:
Log(ex, "更新版本设置 Java 下拉框失败", LogLevel.Feedback)
End Try
'更新选择项
If SelectedItem Is Nothing AndAlso JavaList.Count > 0 Then
If SelectedItem Is Nothing AndAlso JavaList.Any Then
If SelectedBySetup = "" Then
SelectedItem = ComboArgumentJava.Items(1) '选中 “自动选择”
Else
@@ -838,9 +838,6 @@
<ItemGroup>
<Resource Include="Images\Blocks\Fabric.png" />
</ItemGroup>
<ItemGroup>
<Resource Include="Images\Heads\MCBBS.png" />
</ItemGroup>
<ItemGroup>
<None Include="Resources\forge-installer.jar" />
</ItemGroup>
@@ -916,5 +913,8 @@
<Resource Include="Images\Icons\Disabled.png" />
<Resource Include="Images\Icons\Unavaliable.png" />
</ItemGroup>
<ItemGroup>
<Resource Include="Images\Heads\MCBBS.png" />
</ItemGroup>
<Import Project="$(MSBuildToolsPath)\Microsoft.VisualBasic.targets" />
</Project>
+5 -5
View File
@@ -30,7 +30,7 @@
Text="任意项目都可以添加 Width 与 Height 属性来控制宽高。HorizontalAlignment 属性可以控制对齐:Center 代表居中,Right 代表居右,例如这段文本就被居右了。" />
<TextBlock TextWrapping="Wrap" Margin="0,0,0,6"
Text="Image 代表图片,你需要在它的 Source 属性中填写一个网址或文件路径,它会从该处获取图片并显示。通常需要使用 Height 限制它的高度。" />
<Image Height="50" HorizontalAlignment="Center" Source="https://www.mcbbs.net/template/mcbbs/image/logo_sc.png" />
<Image Height="50" HorizontalAlignment="Center" Source="https://zh.minecraft.wiki/images/Grass_Block_JE7_BE6.png?bf67e" />
</StackPanel>
</local:MyCard>
@@ -58,7 +58,7 @@
<TextBlock TextWrapping="Wrap" Margin="0,0,0,10"
Text="将按钮的 EventType 属性设为 打开网页,然后在 EventData 属性中写入网址,即可通过点击按钮打开网页。" />
<local:MyButton Width="140" Height="35" HorizontalAlignment="Left" Padding="13,0,13,0"
Text="打开 MCBBS" EventType="打开网页" EventData="https://www.mcbbs.net/" />
Text="打开 Minecraft Wiki" EventType="打开网页" EventData="https://zh.minecraft.wiki/" />
<TextBlock TextWrapping="Wrap" Margin="0,10,0,10"
Text="或者将 EventType 属性改为 弹出窗口,然后在 EventData 属性中写入弹窗的标题与内容……" />
<local:MyButton Width="140" Height="35" HorizontalAlignment="Left" Padding="13,0,13,0"
@@ -119,7 +119,7 @@
<TextBlock Margin="0,0,0,4"
Text="· 下载文件:在点击时要求选择文件保存位置,并且下载 EventData 的链接中的文件" />
<local:MyButton Margin="0,5,0,6" Width="250" Height="35"
Text="下载 MCBBS 的 Logo" EventType="下载文件" EventData="https://www.mcbbs.net/template/mcbbs/image/logo_sc.png" />
Text="下载百度的 Logo" EventType="下载文件" EventData="https://www.baidu.com/img/flexible/logo/pc/result.png" />
<TextBlock Margin="0,4,0,4"
Text="· 打开帮助:跳转到 EventData 对应的帮助文件(输入相对 Help 文件夹的路径)"/>
<local:MyButton Margin="0,5,0,6" Width="250" Height="35"
@@ -153,7 +153,7 @@
<local:MyButton Margin="0,0,10,0" Width="140" Height="35" HorizontalAlignment="Left" Padding="13,0,13,0"
Text="内存优化" EventType="内存优化" />
<local:MyButton Margin="0,0,10,0" Width="140" Height="35" HorizontalAlignment="Left" Padding="13,0,13,0"
Text="下载作者的头像" EventType="下载文件" EventData="https://www.mcbbs.net/uc_server/data/avatar/000/14/51/06_avatar_small.jpg?ts=1471402592" />
Text="下载百度的 Logo" EventType="下载文件" EventData="https://www.baidu.com/img/flexible/logo/pc/result.png" />
</StackPanel>
</StackPanel>
</local:MyCard>
@@ -227,7 +227,7 @@
<TextBlock TextWrapping="Wrap" Text=" 浓度 7 " Margin="5,0" Background="{DynamicResource ColorBrush7}" />
<TextBlock TextWrapping="Wrap" Text=" 浓度 8 " Margin="5,0" Background="{DynamicResource ColorBrush8}" />
</StackPanel>
<TextBlock Margin="0,15,0,8" Foreground="{DynamicResource ColorBrush2}" Background="{DynamicResource ColorBrush6}"
<TextBlock TextWrapping="Wrap" Margin="0,15,0,8" Foreground="{DynamicResource ColorBrush2}" Background="{DynamicResource ColorBrush6}"
Text="除了字体颜色,你也可以将主题色用于背景色、边框颜色等颜色参数。例如这行字的颜色为浓度 2,背景为浓度 6。" />
</StackPanel>
</local:MyCard>
Binary file not shown.
File diff suppressed because it is too large. Load diff
Binary file not shown.
Binary file not shown.
+3 -3
View File
@@ -29,8 +29,8 @@
<!-- Windows Vista -->
<!--<supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}" />-->
<!-- Windows 7 -->
<supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}" />
<!-- Windows 7 --><!--
<supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}" />-->
<!-- Windows 8 -->
<!--<supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}" />-->
@@ -38,7 +38,7 @@
<!-- Windows 8.1 -->
<!--<supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}" />-->
<!-- Windows 10 -->
<!-- Windows 10+ -->
<supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}" />
</application>
+16 -8
View File
@@ -1,21 +1,29 @@
## Plain Craft Launcher 2 源代码库
# Plain Craft Launcher 源代码库
[![Stars](https://img.shields.io/github/stars/Hex-Dragon/PCL2?style=flat&logo=data:image/svg%2bxml;base64,PHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcvMjAwMC9zdmciIHZlcnNpb249IjEiIHdpZHRoPSIxNiIgaGVpZ2h0PSIxNiI+PHBhdGggZD0iTTggLjI1YS43NS43NSAwIDAgMSAuNjczLjQxOGwxLjg4MiAzLjgxNSA0LjIxLjYxMmEuNzUuNzUgMCAwIDEgLjQxNiAxLjI3OWwtMy4wNDYgMi45Ny43MTkgNC4xOTJhLjc1MS43NTEgMCAwIDEtMS4wODguNzkxTDggMTIuMzQ3bC0zLjc2NiAxLjk4YS43NS43NSAwIDAgMS0xLjA4OC0uNzlsLjcyLTQuMTk0TC44MTggNi4zNzRhLjc1Ljc1IDAgMCAxIC40MTYtMS4yOGw0LjIxLS42MTFMNy4zMjcuNjY4QS43NS43NSAwIDAgMSA4IC4yNVoiIGZpbGw9IiNlYWM1NGYiLz48L3N2Zz4=&logoSize=auto&label=Stars&labelColor=666666&color=eac54f)](https://github.com/Hex-Dragon/PCL2/)
[![Issues](https://img.shields.io/github/issues/Hex-Dragon/PCL2?style=flat&label=Issues&labelColor=666666&color=1a7f37)](https://github.com/Hex-Dragon/PCL2/issues)
[![爱发电](https://img.shields.io/badge/赞助-%E7%88%B1%E5%8F%91%E7%94%B5-946ce6?style=flat&labelColor=666666&logoSize=auto)](https://afdian.net/@LTCat)
<br/>
## 介绍
这里提供了 PCL 的大多数源代码,包括 UI 库、动画模块、下载模块、Minecraft 启动模块等!
PCL 的代码绝大多数其实都是几年前学生时代的产物了……那时候英语还不过关……所以经常出现奇葩命名,还有令人高血压的高耦合啊,没做单例啊,瞎勾八乱糊啊之类的问题……额,我也不可能把这一堆玩意儿再从头写一次,各位就基于能跑就行的原则凑合凑合着看吧,求求别喷了(run
PCL 的代码绝大多数其实都是几年前学生时代的产物了……那时候英语还不过关……所以经常出现奇葩命名,还有令人高血压的高耦合啊,没做单例啊,瞎勾八乱糊啊之类的问题……额,我也不可能把这一堆玩意儿再从头写一次,各位就基于能跑就行的原则凑合凑合着看吧,求求别喷了……
你也可以丢 Pull Request,虽然这个源代码库并不能直接编译,但一些简单的修改应该还是没问题的……
 
<br/>
**相关内容:**
## 相关内容
- [PCL 功能投票](https://github.com/Hex-Dragon/PCL2/discussions/2):来参加投票吧,开发者会优先处理票数较高的帖子!
- [程序下载](https://afdian.net/p/0164034c016c11ebafcb52540025c377):下载免费的正式版 PCL。
- [帮助文档库](https://github.com/LTCatt/PCL2Help):PCL 帮助文档在 GitHub 上的存储库(是的,帮助库在另一个 Repo……)
 
<br/>
**一些无趣的小细节:**
- 别想在这里面找到解密游戏的线索,那部分的代码被我抠掉了(笑)
- 哦,对,解锁隐藏主题的相关代码也都被抠掉了,所以别想着用翻源代码这种歪门邪道来绕过解密了.jpg
## 一些无趣的小细节
- 别想在这里面找到解密游戏的线索,那部分的代码被我抠掉了
- 解锁隐藏主题的相关代码也被抠掉了,所以别想着用翻源代码这种歪门邪道来绕过解密了.jpg
- 源代码库并不是即时更新的,而是在每次 PCL 发布更新时(手动)同步一次
Binary file not shown.