diff --git a/Plain Craft Launcher 2/Application.xaml.vb b/Plain Craft Launcher 2/Application.xaml.vb index b527334..a025af9 100644 --- a/Plain Craft Launcher 2/Application.xaml.vb +++ b/Plain Craft Launcher 2/Application.xaml.vb @@ -19,6 +19,9 @@ Public Class Application '开始 Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup Try + '动态 DLL 调用（必须尽量在前面，否则模块加载 CacheCow 等 DLL 就可能导致崩溃） + AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve + '开始 SecretOnApplicationStart() '检查参数调用 If e.Args.Length > 0 Then @@ -67,15 +70,14 @@ Public Class Application If Not CheckPermission(PathTemp) Then Throw New Exception("PCL 没有对 " & PathTemp & " 的访问权限") Catch ex As Exception If PathTemp = IO.Path.GetTempPath() & "PCL\" Then - MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & "错误原因：" & GetExceptionDetail(ex), "缓存文件夹不可用") + MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用") Else - MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & "错误原因：" & GetExceptionDetail(ex), "缓存文件夹不可用") + MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用") Setup.Set("SystemSystemCache", "") PathTemp = IO.Path.GetTempPath() & "PCL\" End If End Try Directory.CreateDirectory(PathTemp & "Cache") - Directory.CreateDirectory(PathTemp & "Download") Directory.CreateDirectory(PathAppdata) '检测单例 #If Not DEBUG Then @@ -104,28 +106,34 @@ WaitRetry: ToolTipService.PlacementProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(Primitives.PlacementMode.Bottom)) ToolTipService.HorizontalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(8.0)) ToolTipService.VerticalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(4.0)) + '设置网络配置默认值 + ServicePointManager.Expect100Continue = False + ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12 + ServicePointManager.DefaultConnectionLimit = 10000 + ServicePointManager.UseNagleAlgorithm = False + ServicePointManager.EnableDnsRoundRobin = True + ServicePointManager.ReusePort = True '设置初始窗口 If Setup.Get("UiLauncherLogo") Then FrmStart = New SplashScreen("Images\icon.ico") FrmStart.Show(False, True) End If - '动态 DLL 调用 - AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve '日志初始化 LogStart() '添加日志 Log($"[Start] 程序版本：{VersionDisplayName} ({VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})") #If RELEASE Then - Log($"[Start] 识别码：{UniqueAddress}{If(ThemeCheckOne(9), "，正式版", "")}") + Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，正式版", "")}") #Else - Log($"[Start] 识别码：{UniqueAddress}{If(ThemeCheckOne(9), "，已解锁反馈主题", "")}") + Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，已解锁反馈主题", "")}") #End If Log($"[Start] 程序路径：{PathWithName}") Log($"[Start] 系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})") Log($"[Start] 管理员权限：{IsAdmin()}") '检测异常环境 If Path.Contains(IO.Path.GetTempPath()) OrElse Path.Contains("AppData\Local\Temp\") Then - MyMsgBox("请将 PCL 从压缩包中解压之后再使用！" & vbCrLf & "在当前环境下运行可能会导致丢失游戏存档或设置，部分功能也可能无法使用！", "环境警告", "我知道了", IsWarn:=True) + MyMsgBox("请将 PCL 从压缩包中解压后再使用！" & vbCrLf & "如果不会解压，可以在网上寻找教程。", "尚未解压", "我知道了", IsWarn:=True) + FormMain.EndProgramForce(ProcessReturnValues.Cancel) End If If Is32BitSystem Then MyMsgBox("PCL 和新版 Minecraft 均不再支持 32 位系统，部分功能将无法使用。" & vbCrLf & "非常建议重装为 64 位系统后再进行游戏！", "环境警告", "我知道了", IsWarn:=True) @@ -136,11 +144,6 @@ WaitRetry: Setup.Load("ToolDownloadThread") Setup.Load("ToolDownloadCert") Setup.Load("ToolDownloadSpeed") - '网络配置初始化 - ServicePointManager.Expect100Continue = True - ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12 - ServicePointManager.DefaultConnectionLimit = 1024 - ServicePointManager.UseNagleAlgorithm = False '计时 Log("[Start] 第一阶段加载用时：" & GetTimeTick() - ApplicationStartTick & " ms") ApplicationStartTick = GetTimeTick() @@ -155,7 +158,7 @@ WaitRetry: FilePath = PathWithName Catch End Try - MsgBox(GetExceptionDetail(ex, True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误") + MsgBox(ex.GetDetail(True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误") FormMain.EndProgramForce(ProcessReturnValues.Exception) End Try End Sub @@ -168,10 +171,20 @@ WaitRetry: '异常 Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException On Error Resume Next + '触发页面的 Dispatcher + If FrmMain?.PageLeft IsNot Nothing AndAlso TypeOf FrmMain.PageLeft Is IDispatcherUnhandledException Then + CType(FrmMain.PageLeft, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e) + If e.Handled Then Return + End If + If FrmMain?.PageRight IsNot Nothing AndAlso TypeOf FrmMain.PageRight Is IDispatcherUnhandledException Then + CType(FrmMain.PageRight, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e) + If e.Handled Then Return + End If + '正常处理 e.Handled = True If IsProgramEnded Then Return FeedbackInfo() - Dim Detail As String = GetExceptionDetail(e.Exception, True) + Dim Detail As String = e.Exception.GetDetail(True) If Detail.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse Detail.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse Detail.Contains("未能加载文件或程序集") OrElse Detail.Contains(".NET Framework") Then ' “自动错误判断” 的结果分析 OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net462-offline-installer") diff --git a/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb b/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb new file mode 100644 index 0000000..c508b94 --- /dev/null +++ b/Plain Craft Launcher 2/Controls/Behaviors/Interfaces.vb @@ -0,0 +1,23 @@ +Imports System.Windows.Threading + +''' +''' 指示页面可以通过按下 F5 或以其他方式刷新。 +''' +Public Interface IRefreshable + Sub Refresh() +End Interface + +''' +''' 指示页面可以处理未捕获的异常。 +''' +Public Interface IDispatcherUnhandledException + Sub DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) +End Interface + +''' +''' 指示该控件是可勾选的。 +''' +Public Interface IMyRadio + Event Check(sender As Object, e As RouteEventArgs) + Event Changed(sender As Object, e As RouteEventArgs) +End Interface diff --git a/Plain Craft Launcher 2/Controls/IMyRadio.vb b/Plain Craft Launcher 2/Controls/IMyRadio.vb deleted file mode 100644 index 8649305..0000000 --- a/Plain Craft Launcher 2/Controls/IMyRadio.vb +++ /dev/null @@ -1,4 +0,0 @@ -Public Interface IMyRadio - Event Check(sender As Object, e As RouteEventArgs) - Event Changed(sender As Object, e As RouteEventArgs) -End Interface diff --git a/Plain Craft Launcher 2/Controls/MyButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyButton.xaml.vb index 94a0677..992673e 100644 --- a/Plain Craft Launcher 2/Controls/MyButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyButton.xaml.vb @@ -140,39 +140,14 @@ Public Class MyButton End Try End Sub - '实现自定义事件 + '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） + Private IsMouseDown As Boolean = False Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp If Not IsMouseDown Then Return Log("[Control] 按下按钮：" & Text) RaiseEvent Click(sender, e) - If Not String.IsNullOrEmpty(Tag) Then - If Tag.ToString.StartsWithF("链接-") OrElse Tag.ToString.StartsWithF("启动-") Then - Hint("主页自定义按钮语法已更新，且不再兼容老版本语法，请查看新的自定义示例！") - End If - End If - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyButton), New PropertyMetadata(Nothing)) - - '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） - Private IsMouseDown As Boolean = False Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True Focus() diff --git a/Plain Craft Launcher 2/Controls/MyCard.vb b/Plain Craft Launcher 2/Controls/MyCard.vb index fc5f9a2..b84cae2 100644 --- a/Plain Craft Launcher 2/Controls/MyCard.vb +++ b/Plain Craft Launcher 2/Controls/MyCard.vb @@ -123,14 +123,6 @@ End Select '控件转换 Select Case Type - Case 5 - Dim LoadingPickaxe As New MyLoading With {.Text = "正在获取版本列表", .Margin = New Thickness(5)} - Dim Loader = New LoaderTask(Of String, List(Of DlForgeVersionEntry))("DlForgeVersion Main", AddressOf DlForgeVersionMain) - LoadingPickaxe.State = Loader - Loader.Start(Stack.Tag) - AddHandler LoadingPickaxe.StateChanged, AddressOf FrmDownloadForge.Forge_StateChanged - AddHandler LoadingPickaxe.Click, AddressOf FrmDownloadForge.Forge_Click - Stack.Children.Add(LoadingPickaxe) Case 6 ForgeDownloadListItemPreload(Stack, Stack.Tag, AddressOf ForgeSave_Click, True) Case 8 @@ -140,14 +132,13 @@ For Each Data As Object In Stack.Tag Select Case Type Case 0 - Stack.Children.Add(PageSelectRight.McVersionListItem(Data)) + Dim VersionItem As MyListItem = CType(Data, McVersion).ToListItem + VersionItem.ContentHandler = AddressOf PageSelectRight.McVersionListContent + Stack.Children.Add(VersionItem) Case 2 Stack.Children.Add(McDownloadListItem(Data, AddressOf McDownloadMenuSave, True)) Case 3 Stack.Children.Add(OptiFineDownloadListItem(Data, AddressOf OptiFineSave_Click, True)) - Case 4 - Stack.Children.Add(LiteLoaderDownloadListItem(Data, AddressOf FrmDownloadLiteLoader.DownloadStart, False)) - Case 5 Case 6 Stack.Children.Add(ForgeDownloadListItem(Data, AddressOf ForgeSave_Click, True)) Case 7 @@ -320,52 +311,58 @@ End Set End Property Private _IsSwapped As Boolean = False - ''' - ''' 是否已被折叠。(已过时，请使用 IsSwapped) - ''' Public Property IsSwaped As Boolean Get - Return IsSwapped + Return GetValue(IsSwapedProperty) End Get Set(value As Boolean) - IsSwapped = value + SetValue(IsSwapedProperty, value) End Set End Property - Public Shared ReadOnly IsSwapedProperty As DependencyProperty = DependencyProperty.Register("IsSwaped", GetType(Boolean), GetType(MyCard), New PropertyMetadata(False)) + Public Shared ReadOnly IsSwapedProperty As DependencyProperty = DependencyProperty.Register("IsSwaped", GetType(Boolean), GetType(MyCard), New PropertyMetadata(False, + Sub(sender, e) If sender IsNot Nothing AndAlso TypeOf sender Is MyCard Then CType(sender, MyCard).IsSwapped = CType(e.NewValue, Boolean))) Public Property SwapLogoRight As Boolean = False - Private IsMouseDown As Boolean = False + Private IsSwapMouseDown As Boolean = False '用于触发卡片展开/折叠的 MouseDown + Private IsCustomMouseDown As Boolean = False '用于触发自定义事件的 MouseDown Public Event PreviewSwap(sender As Object, e As RouteEventArgs) Public Event Swap(sender As Object, e As RouteEventArgs) Public Const SwapedHeight As Integer = 40 Private Sub MyCard_MouseLeftButtonDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown Dim Pos As Double = Mouse.GetPosition(Me).Y + If Not IsSwapped AndAlso + (Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return + IsCustomMouseDown = True If Not IsSwapped AndAlso (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 - IsMouseDown = True + IsSwapMouseDown = True End Sub - Private Sub MyCard_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp - If Not IsMouseDown Then Return - IsMouseDown = False + Private Sub MyCard_MouseLeftButtonUp() Handles Me.MouseLeftButtonUp + If Not IsCustomMouseDown Then Return + IsCustomMouseDown = False + RaiseCustomEvent() '触发自定义事件 + + If Not IsSwapMouseDown Then Return + IsSwapMouseDown = False Dim Pos As Double = Mouse.GetPosition(Me).Y If Not IsSwapped AndAlso (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置；或已经不在可视树上的误判 - Dim ee = New RouteEventArgs(True) - RaiseEvent PreviewSwap(Me, ee) - If ee.Handled Then - IsMouseDown = False + Dim e = New RouteEventArgs(True) + RaiseEvent PreviewSwap(Me, e) + If e.Handled Then + IsSwapMouseDown = False Return End If IsSwapped = Not IsSwapped Log("[Control] " & If(IsSwapped, "折叠卡片", "展开卡片") & If(Title Is Nothing, "", "：" & Title)) - RaiseEvent Swap(Me, ee) + RaiseEvent Swap(Me, e) End Sub Private Sub MyCard_MouseLeave_Swap(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave - IsMouseDown = False + IsSwapMouseDown = False End Sub #End Region diff --git a/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb b/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb index a0e8c9c..3703419 100644 --- a/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyCheckBox.xaml.vb @@ -12,9 +12,6 @@ Public Class MyCheckBox ''' 是否为用户手动改变的勾选状态。 Public Event Change(sender As Object, user As Boolean) Public Event PreviewChange(sender As Object, e As RouteEventArgs) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序引发本控件的 Change 事件 '自定义属性 Public Property Checked As Boolean @@ -59,6 +56,7 @@ Public Class MyCheckBox '更改动画 SyncUI() + RaiseCustomEvent() Catch ex As Exception Log(ex, "设置 Checked 失败") End Try diff --git a/Plain Craft Launcher 2/Controls/MyComboBox.vb b/Plain Craft Launcher 2/Controls/MyComboBox.vb index 874b48a..69f7ae2 100644 --- a/Plain Craft Launcher 2/Controls/MyComboBox.vb +++ b/Plain Craft Launcher 2/Controls/MyComboBox.vb @@ -117,15 +117,14 @@ Private IsTextChanging As Boolean = False Private Sub MyComboBox_TextChanged(sender As Object, e As TextChangedEventArgs) Handles Me.TextChanged If IsTextChanging OrElse Not IsEditable Then Return - If SelectedItem IsNot Nothing AndAlso Text <> SelectedItem.ToString Then - Dim RawText As String = Text - Dim RawSelectionStart As Integer = TextBox.SelectionStart - IsTextChanging = True - SelectedItem = Nothing - Text = RawText - TextBox.SelectionStart = RawSelectionStart - IsTextChanging = False - End If + If SelectedItem Is Nothing OrElse Text = SelectedItem.ToString Then Return + Dim RawText As String = Text + Dim RawSelectionStart As Integer = TextBox.SelectionStart + IsTextChanging = True + SelectedItem = Nothing + Text = RawText + TextBox.SelectionStart = RawSelectionStart + IsTextChanging = False End Sub Public ReadOnly Property ContentPresenter As ContentPresenter @@ -134,4 +133,8 @@ End Get End Property + Private Sub MyComboBox_SelectionChanged(sender As Object, e As SelectionChangedEventArgs) Handles Me.SelectionChanged + If IsLoaded AndAlso AniControlEnabled = 0 Then RaiseCustomEvent() + End Sub + End Class diff --git a/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb index 0bb1b3a..6f90827 100644 --- a/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyExtraButton.xaml.vb @@ -53,25 +53,26 @@ Set(value As Boolean) If _Show = value Then Return _Show = value - RunInUi(Sub() - If value Then - '有了 - Visibility = Visibility.Visible - AniStart({ - AaScaleTransform(Me, 0.3 - CType(RenderTransform, ScaleTransform).ScaleX, 500, 60, New AniEaseOutFluent(AniEasePower.Weak)), - AaScaleTransform(Me, 0.7, 500, 60, New AniEaseOutBack(AniEasePower.Weak)), - AaHeight(Me, 50 - Height, 200,, New AniEaseOutFluent(AniEasePower.Weak)) - }, "MyExtraButton MainScale " & Uuid) - Else - '没了 - AniStart({ - AaScaleTransform(Me, -CType(RenderTransform, ScaleTransform).ScaleX, 100,, New AniEaseInFluent(AniEasePower.Weak)), - AaHeight(Me, -Height, 400, 100, New AniEaseOutFluent()), - AaCode(Sub() Visibility = Visibility.Collapsed,, True) - }, "MyExtraButton MainScale " & Uuid) - End If - IsHitTestVisible = value '防止缩放动画中依然可以点进去 - End Sub) + RunInUi( + Sub() + If value Then + '有了 + Visibility = Visibility.Visible + AniStart({ + AaScaleTransform(Me, 0.3 - CType(RenderTransform, ScaleTransform).ScaleX, 500, 60, New AniEaseOutFluent(AniEasePower.Weak)), + AaScaleTransform(Me, 0.7, 500, 60, New AniEaseOutBack(AniEasePower.Weak)), + AaHeight(Me, 50 - Height, 200,, New AniEaseOutFluent(AniEasePower.Weak)) + }, "MyExtraButton MainScale " & Uuid) + Else + '没了 + AniStart({ + AaScaleTransform(Me, -CType(RenderTransform, ScaleTransform).ScaleX, 100,, New AniEaseInFluent(AniEasePower.Weak)), + AaHeight(Me, -Height, 400, 100, New AniEaseOutFluent()), + AaCode(Sub() Visibility = Visibility.Collapsed,, True) + }, "MyExtraButton MainScale " & Uuid) + End If + IsHitTestVisible = value '防止缩放动画中依然可以点进去 + End Sub) End Set End Property Public Delegate Function ShowCheckDelegate() As Boolean @@ -137,6 +138,7 @@ AaScaleTransform(PanScale, 1 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 300,, New AniEaseOutBack) }, "MyExtraButton Scale " & Uuid) End If + If IsLeftMouseHeld Then RaiseCustomEvent() IsLeftMouseHeld = False RefreshColor() '直接刷新颜色以判断是否已触发 MouseLeave End Sub @@ -199,16 +201,17 @@ ''' 发出一圈波浪效果提示。 ''' Public Sub Ribble() - RunInUi(Sub() - Dim Shape As New Border With {.CornerRadius = New CornerRadius(1000), .BorderThickness = New Thickness(0.001), .Opacity = 0.5, .RenderTransformOrigin = New Point(0.5, 0.5), .RenderTransform = New ScaleTransform()} - Shape.SetResourceReference(Border.BackgroundProperty, "ColorBrush5") - PanScale.Children.Insert(0, Shape) - AniStart({ - AaScaleTransform(Shape, 13, 1000, Ease:=New AniEaseInoutFluent(AniEasePower.Strong, 0.3)), - AaOpacity(Shape, -Shape.Opacity, 1000), - AaCode(Sub() PanScale.Children.Remove(Shape), After:=True) - }, "ExtraButton Ribble " & GetUuid()) - End Sub) + RunInUi( + Sub() + Dim Shape As New Border With {.CornerRadius = New CornerRadius(1000), .BorderThickness = New Thickness(0.001), .Opacity = 0.5, .RenderTransformOrigin = New Point(0.5, 0.5), .RenderTransform = New ScaleTransform()} + Shape.SetResourceReference(Border.BackgroundProperty, "ColorBrush5") + PanScale.Children.Insert(0, Shape) + AniStart({ + AaScaleTransform(Shape, 13, 1000, Ease:=New AniEaseInoutFluent(AniEasePower.Strong, 0.3)), + AaOpacity(Shape, -Shape.Opacity, 1000), + AaCode(Sub() PanScale.Children.Remove(Shape), After:=True) + }, "ExtraButton Ribble " & GetUuid()) + End Sub) End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb index 9784cd0..266ba47 100644 --- a/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyExtraTextButton.xaml.vb @@ -81,12 +81,12 @@ Public Class MyExtraTextButton '触发点击事件 Private Sub Button_LeftMouseUp(sender As Object, e As MouseButtonEventArgs) Handles PanClick.MouseLeftButtonUp - If IsLeftMouseHeld Then - Log("[Control] 按下附加图标按钮：" & Text) - RaiseEvent Click(sender, e) - e.Handled = True - Button_LeftMouseUp() - End If + If Not IsLeftMouseHeld Then Return + Log("[Control] 按下附加图标按钮：" & Text) + RaiseEvent Click(sender, e) + e.Handled = True + RaiseCustomEvent() + Button_LeftMouseUp() End Sub '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） diff --git a/Plain Craft Launcher 2/Controls/MyHint.xaml.vb b/Plain Craft Launcher 2/Controls/MyHint.xaml.vb index f26df16..9498b37 100644 --- a/Plain Craft Launcher 2/Controls/MyHint.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyHint.xaml.vb @@ -113,7 +113,7 @@ Public Class MyHint IsMouseDown = False Log("[Control] 按下提示条" & If(String.IsNullOrEmpty(Name), "", "：" & Name)) e.Handled = True - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub Private Sub MyHint_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True @@ -121,24 +121,6 @@ Public Class MyHint Private Sub MyHint_MouseLeave() Handles Me.MouseLeave IsMouseDown = False End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyHint), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyHint), New PropertyMetadata(Nothing)) End Class Partial Public Module ModAnimation diff --git a/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb index 5271696..5da1eaf 100644 --- a/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyIconButton.xaml.vb @@ -48,36 +48,16 @@ End Set End Property - '触发点击事件 + '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） + Private IsMouseDown As Boolean = False Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp If Not IsMouseDown Then Return Log("[Control] 按下图标按钮" & If(String.IsNullOrEmpty(Name), "", "：" & Name)) RaiseEvent Click(sender, e) e.Handled = True Button_MouseUp() - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyIconButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyIconButton), New PropertyMetadata(Nothing)) - - '鼠标点击判定（务必放在点击事件之后，以使得 Button_MouseUp 先于 Button_MouseLeave 执行） - Private IsMouseDown As Boolean = False Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown IsMouseDown = True Focus() @@ -102,7 +82,6 @@ RefreshAnim() '直接刷新颜色以判断是否已触发 MouseLeave End Sub - '自定义事件 '务必放在 IsMouseDown 更新之后 Private Const AnimationColorIn As Integer = 120 Private Const AnimationColorOut As Integer = 150 diff --git a/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb index 47fdbf9..dd5ed21 100644 --- a/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyIconTextButton.xaml.vb @@ -8,9 +8,6 @@ Public Class MyIconTextButton Public Uuid As Integer = GetUuid() Public Event Check(sender As Object, raiseByMouse As Boolean) Public Event Change(sender As Object, raiseByMouse As Boolean) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序可以引发本控件的 Change 事件 '自定义属性 @@ -76,7 +73,7 @@ Public Class MyIconTextButton Log("[Control] 按下带图标按钮：" & Text) IsMouseDown = False RaiseEvent Click(Me, New RouteEventArgs(True)) - ModEvent.TryStartEvent(EventType, EventData) + RaiseCustomEvent() '自定义事件 RefreshColor() End Sub Private Sub MyIconTextButton_MouseDown() Handles Me.MouseLeftButtonDown @@ -87,24 +84,6 @@ Public Class MyIconTextButton IsMouseDown = False RefreshColor() End Sub - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyIconTextButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyIconTextButton), New PropertyMetadata(Nothing)) '动画 diff --git a/Plain Craft Launcher 2/Controls/MyImage.vb b/Plain Craft Launcher 2/Controls/MyImage.vb index 06ffc39..f869400 100644 --- a/Plain Craft Launcher 2/Controls/MyImage.vb +++ b/Plain Craft Launcher 2/Controls/MyImage.vb @@ -25,7 +25,7 @@ ''' ''' 与 Image 的 Source 类似。 - ''' 若输入以 http 开头的字符串，则会尝试下载图片然后显示，图片会保存为本地缓存。 + ''' 若输入以 http 开头的字符串，则会尝试下载图片然后显示；若 EnableCache 设为 True，图片还会保存为本地缓存。 ''' 支持 WebP 格式的图片。 ''' Public Shadows Property Source As String '覆写 Image 的 Source 属性 @@ -46,7 +46,7 @@ Sub(sender, e) If sender IsNot Nothing Then CType(sender, MyImage).Source = e.NewValue.ToString()))) ''' - ''' 当 Source 首次下载失败时，会从该备用地址加载图片。 + ''' 若 Source 是一个网络图片，该地址将作为第二图片源。 ''' Public Property FallbackSource As String Get @@ -111,73 +111,47 @@ Return End If '从缓存加载网络图片 - Dim Url As String = Source - Dim Retried As Boolean = False - Dim TempPath As String = GetTempPath(Url) - Dim TempFile As New FileInfo(TempPath) Dim EnableCache As Boolean = Me.EnableCache + Dim TempPath As String = GetTempPath(Source) & If(EnableCache, "", GetUuid()) '不启用缓存时加上随机字符串，避免冲突 + Dim TempFile As New FileInfo(TempPath) If EnableCache AndAlso TempFile.Exists Then ActualSource = TempPath If (Date.Now - TempFile.LastWriteTime) < FileCacheExpiredTime Then Return '无需刷新缓存 End If RunInNewThread( Sub() - Dim TempDownloadingPath As String = Nothing + Dim IsLocalFallback As Boolean = Not String.IsNullOrEmpty(FallbackSource) AndAlso Not FallbackSource.StartsWithF("http") Try -RetryStart: '下载 - ActualSource = LoadingSource '显示加载中图片 - TempDownloadingPath = TempPath & RandomInteger(0, 10000000) - Directory.CreateDirectory(GetPathFromFullPath(TempPath)) '重新实现下载，以避免携带 Header（#5072） - Using Client As New Net.WebClient - Client.DownloadFile(Url, TempDownloadingPath) - End Using - If Url <> Source AndAlso Url <> FallbackSource Then - '已经更换了地址 - File.Delete(TempDownloadingPath) - ElseIf EnableCache Then + ActualSource = LoadingSource '显示加载中的占位图片 + NetDownloadByLoader( + If(FallbackSource?.StartsWithF("http"), {Source, FallbackSource}, {Source}), + TempPath, SimulateBrowserHeaders:=True) + If EnableCache Then '保存缓存并显示 - If File.Exists(TempPath) Then File.Delete(TempPath) - FileSystem.Rename(TempDownloadingPath, TempPath) RunInUi(Sub() ActualSource = TempPath) Else '直接显示 - RunInUiWait(Sub() ActualSource = TempDownloadingPath) - File.Delete(TempDownloadingPath) + RunInUiWait(Sub() ActualSource = TempPath) + File.Delete(TempPath) End If Catch ex As Exception Try If TempPath IsNot Nothing Then File.Delete(TempPath) - If TempDownloadingPath IsNot Nothing Then File.Delete(TempDownloadingPath) Catch End Try - If Not Retried Then - '更换备用地址 - Log(ex, $"下载图片可重试地失败（{Url}）", LogLevel.Developer) - Retried = True - Url = If(FallbackSource, Source) - '空 - If Url Is Nothing Then - ActualSource = Nothing + '加载本地备用图片 + If IsLocalFallback Then + Try + RunInUiWait(Sub() ActualSource = FallbackSource) + Log(ex, $"下载图片失败，使用本地备用图片（{Source}）") Return - End If - '本地图片 - If Not Url.StartsWithF("http") Then - ActualSource = Url - Return - End If - '从缓存加载网络图片 - TempPath = GetTempPath(Url) - TempFile = New FileInfo(TempPath) - If EnableCache AndAlso TempFile.Exists() Then - ActualSource = TempPath - If (Date.Now - TempFile.CreationTime) < FileCacheExpiredTime Then Return '无需刷新缓存 - End If - '下载 - If Source = Url Then Thread.Sleep(1000) '延迟 1s 重试 - GoTo RetryStart + Catch exx As Exception + Log(ex, $"下载图片失败（{Source}）", LogLevel.Hint) + Log(exx, $"加载备用图片失败（{FallbackSource}）", LogLevel.Hint) + End Try Else - Log(ex, $"下载图片失败（{Url}）", LogLevel.Hint) + Log(ex, $"下载图片失败（{Source}，备用：{FallbackSource}）", LogLevel.Hint) End If End Try End Sub, "MyImage PicLoader " & GetUuid() & "#", ThreadPriority.BelowNormal) diff --git a/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb b/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb index 0f5fd3f..cf462ec 100644 --- a/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyListItem.xaml.vb @@ -506,8 +506,8 @@ Public Class MyListItem RaiseEvent Click(sender, e) If e.Handled Then Return '触发自定义事件 - If Not String.IsNullOrEmpty(EventType) Then - ModEvent.TryStartEvent(EventType, EventData) + If CustomEventService.GetEventType(sender) <> CustomEvent.EventType.None Then + RaiseCustomEvent() e.Handled = True End If If e.Handled Then Return @@ -537,26 +537,6 @@ Public Class MyListItem If ButtonStack IsNot Nothing Then ButtonStack.IsHitTestVisible = True End Sub - '实现自定义事件 - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register("EventType", GetType(String), GetType(MyListItem), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register("EventData", GetType(String), GetType(MyListItem), New PropertyMetadata(Nothing)) - #End Region Private StateLast As String @@ -657,13 +637,14 @@ Public Class MyListItem SetResourceReference(ForegroundProperty, "ColorBrush1") End If ColumnPaddingRight.Width = New GridLength(MinPaddingRight) - If EventType = "打开帮助" AndAlso Not (Title <> "" AndAlso Info <> "") Then '#3266 + If CustomEventService.GetEventType(Me) = CustomEvent.EventType.打开帮助 AndAlso Not (Title <> "" AndAlso Info <> "") Then '#3266 Try - Dim Unused = New HelpEntry(GetEventAbsoluteUrls(EventData, EventType)(0)).SetToListItem(Me) + Dim Entry As New HelpEntry(CustomEvent.GetAbsoluteUrls(CustomEventService.GetEventData(Me), CustomEventService.GetEventType(Me))(0)) + Entry.SetToListItem(Me) Catch ex As Exception Log(ex, "设置帮助 MyListItem 失败", LogLevel.Msgbox) - EventType = Nothing - EventData = Nothing + CustomEventService.SetEventType(Me, CustomEvent.EventType.None) + CustomEventService.SetEventData(Me, "") End Try End If End Sub diff --git a/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb b/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb index b6a4638..e4f6785 100644 --- a/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyLoading.xaml.vb @@ -79,11 +79,7 @@ Public Class MyLoading Do While Ex.InnerException IsNot Nothing Ex = Ex.InnerException Loop - LabText.Text = StrTrim(Ex.Message) - If {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", - "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) LabText.Text.Contains(s)) Then - LabText.Text = "网络环境不佳，请稍后重试，或使用 VPN 以改善网络环境" - End If + LabText.Text = If(Ex.IsNetworkRelated(), "网络环境不佳，请稍后再试，或使用 VPN 改善网络环境", StrTrim(Ex.Message)) End If Else LabText.Text = TextError @@ -187,30 +183,29 @@ Public Class MyLoading IsLooping = True ErrorAnimationWaiting = True AniStart({ - AaRotateTransform(PathPickaxe, -20 - CType(PathPickaxe.RenderTransform, RotateTransform).Angle, 350, 250, New AniEaseInBack(AniEasePower.Weak)), - AaRotateTransform(PathPickaxe, 50, 900,, New AniEaseOutFluent, True), - AaRotateTransform(PathPickaxe, 25, 900,, New AniEaseOutElastic(AniEasePower.Weak)), - AaCode(Sub() - PathLeft.Opacity = 1 - PathLeft.Margin = New Thickness(7, 41, 0, 0) - PathRight.Opacity = 1 - PathRight.Margin = New Thickness(14, 41, 0, 0) - ErrorAnimationWaiting = False - End Sub), - AaOpacity(PathLeft, -1, 100, 50), - AaX(PathLeft, -5, 180,, New AniEaseOutFluent), - AaY(PathLeft, -6, 180,, New AniEaseOutFluent), - AaOpacity(PathRight, -1, 100, 50), - AaX(PathRight, 5, 180,, New AniEaseOutFluent), - AaY(PathRight, -6, 180,, New AniEaseOutFluent), - AaCode(Sub() - IsLooping = False - AniLoop() - End Sub,, True) - }, "MyLoader Loop " & Uuid & "/" & GetUuid()) - If ShowProgress Then - - End If + AaRotateTransform(PathPickaxe, -20 - CType(PathPickaxe.RenderTransform, RotateTransform).Angle, 350, 250, New AniEaseInBack(AniEasePower.Weak)), + AaRotateTransform(PathPickaxe, 50, 900,, New AniEaseOutFluent, True), + AaRotateTransform(PathPickaxe, 25, 900,, New AniEaseOutElastic(AniEasePower.Weak)), + AaCode( + Sub() + PathLeft.Opacity = 1 + PathLeft.Margin = New Thickness(7, 41, 0, 0) + PathRight.Opacity = 1 + PathRight.Margin = New Thickness(14, 41, 0, 0) + ErrorAnimationWaiting = False + End Sub), + AaOpacity(PathLeft, -1, 100, 50), + AaX(PathLeft, -5, 180,, New AniEaseOutFluent), + AaY(PathLeft, -6, 180,, New AniEaseOutFluent), + AaOpacity(PathRight, -1, 100, 50), + AaX(PathRight, 5, 180,, New AniEaseOutFluent), + AaY(PathRight, -6, 180,, New AniEaseOutFluent), + AaCode( + Sub() + IsLooping = False + AniLoop() + End Sub,, True) + }, "MyLoader Loop " & Uuid & "/" & GetUuid()) End Sub ''' diff --git a/Plain Craft Launcher 2/Controls/MyMenuItem.vb b/Plain Craft Launcher 2/Controls/MyMenuItem.vb index cc70ee6..4c22da3 100644 --- a/Plain Craft Launcher 2/Controls/MyMenuItem.vb +++ b/Plain Craft Launcher 2/Controls/MyMenuItem.vb @@ -54,4 +54,7 @@ End If End Sub + Private Sub MyMenuItem_Click(sender As Object, e As RoutedEventArgs) Handles Me.Click + RaiseCustomEvent() + End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyPageLeft.vb b/Plain Craft Launcher 2/Controls/MyPageLeft.vb index da00f6f..afc047f 100644 --- a/Plain Craft Launcher 2/Controls/MyPageLeft.vb +++ b/Plain Craft Launcher 2/Controls/MyPageLeft.vb @@ -3,15 +3,15 @@ Private Uuid As Integer = GetUuid() '执行逐个进入动画的控件 - Public Property AnimatedControl As FrameworkElement + Public Property AnimatedControl As String '需要在 Loaded 之后才能获取到控件，所以不能用 Binding 直接绑定（#6664） Get Return GetValue(AnimatedControlProperty) End Get - Set(value As FrameworkElement) + Set(value As String) SetValue(AnimatedControlProperty, value) End Set End Property - Public Shared ReadOnly AnimatedControlProperty As DependencyProperty = DependencyProperty.Register("AnimatedControl", GetType(FrameworkElement), GetType(MyPageLeft), New PropertyMetadata(Nothing)) + Public Shared ReadOnly AnimatedControlProperty As DependencyProperty = DependencyProperty.Register("AnimatedControl", GetType(String), GetType(MyPageLeft), New PropertyMetadata(Nothing)) Public Sub TriggerShowAnimation() If AnimatedControl Is Nothing Then @@ -84,7 +84,7 @@ '遍历获取所有需要生成动画的控件 Private Function GetAllAnimControls(Optional IgnoreInvisibility As Boolean = False) As List(Of FrameworkElement) Dim AllControls As New List(Of FrameworkElement) - GetAllAnimControls(AnimatedControl, AllControls, IgnoreInvisibility) + GetAllAnimControls(FindName(AnimatedControl), AllControls, IgnoreInvisibility) Return AllControls End Function Private Sub GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean) @@ -105,7 +105,3 @@ End Sub End Class - -Public Interface IRefreshable - Sub Refresh() -End Interface \ No newline at end of file diff --git a/Plain Craft Launcher 2/Controls/MyPageRight.vb b/Plain Craft Launcher 2/Controls/MyPageRight.vb index 59545f5..a3e85a6 100644 --- a/Plain Craft Launcher 2/Controls/MyPageRight.vb +++ b/Plain Craft Launcher 2/Controls/MyPageRight.vb @@ -3,16 +3,16 @@ Public PageUuid As Integer = GetUuid() '“返回顶部” 按钮检测的滚动区域 - Public Property PanScroll As MyScrollViewer + Public Property PanScroll As String '需要在 Loaded 之后才能获取到控件，所以不能用 Binding 直接绑定（#6664） Get Return GetValue(PanScrollProperty) End Get - Set(value As MyScrollViewer) + Set(value As String) SetValue(PanScrollProperty, value) End Set End Property Private Shared ReadOnly PanScrollProperty = - DependencyProperty.Register("PanScroll", GetType(MyScrollViewer), GetType(MyPageRight), New PropertyMetadata(Nothing)) + DependencyProperty.Register("PanScroll", GetType(String), GetType(MyPageRight), New PropertyMetadata(Nothing)) '当前状态 Public Enum PageStates @@ -130,7 +130,7 @@ Select Case PageState Case PageStates.Empty If PageLoader Is Nothing OrElse PageLoader.State = LoadState.Finished OrElse PageLoader.State = LoadState.Waiting OrElse PageLoader.State = LoadState.Aborted Then - '如果加载器在进入页面时不启动（例如 HiPer 联机），那么在此时就会有 State = Waiting + '如果加载器在进入页面时不启动（例如联机），那么在此时就会有 State = Waiting PageState = PageStates.ContentEnter TriggerEnterAnimation(PanAlways, If(PanContent, Child)) ElseIf PageLoader.State = LoadState.Loading Then @@ -152,7 +152,8 @@ PageState = PageStates.LoaderEnter TriggerEnterAnimation(PanLoader) End If - Case PageStates.ContentEnter '重复调用 PageOnEnter，直接忽略 + Case PageStates.ContentEnter + '重复调用 PageOnEnter，直接忽略 Case Else Throw New Exception("在状态为 " & GetStringFromEnum(PageState) & " 时触发了 PageOnEnter 事件。") End Select @@ -207,8 +208,8 @@ Public Sub PageOnContentExit() If ModeDebug Then Log("[UI] 已触发 PageOnContentExit") If PageLoader IsNot Nothing AndAlso PageLoader.State = LoadState.Loading Then - Throw New Exception("在调用 PageOnContentExit 时，加载器不能为 Loading 状态") 'Loading 的加载器可能触发进一步变化，难以预测会触发子页面的动画还是加载器完成的动画 + Throw New Exception("在调用 PageOnContentExit 时，加载器不能为 Loading 状态") End If Select Case PageState Case PageStates.ContentEnter, PageStates.ContentStay @@ -219,8 +220,12 @@ Case PageStates.LoaderEnter, PageStates.LoaderStayForce, PageStates.LoaderStay PageState = PageStates.ContentExit TriggerExitAnimation(PanLoader) - Case PageStates.LoaderWait, PageStates.Empty + Case PageStates.LoaderWait PageOnEnter() + Case PageStates.Empty + '可能是在离开页面后，其他后台线程调用了本函数，此时不应触发 PageOnEnter() + '例如：在加入联机房间后，切换到其他页面，然后联机房间被解散 + If IsLoaded Then PageOnEnter() End Select End Sub diff --git a/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb b/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb index 5dd839f..e629808 100644 --- a/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyRadioBox.xaml.vb @@ -89,14 +89,15 @@ Public Class MyRadioBox End If End Select - '触发事件 If IsChanged Then + '触发事件 If Checked Then RaiseEvent Check(Me, New RouteEventArgs(user)) RaiseEvent Changed(Me, New RouteEventArgs(user)) + RaiseCustomEvent() + '更改动画 + SyncUI() End If - '更改动画 - SyncUI() Catch ex As Exception Log(ex, "单选框勾选改变错误", LogLevel.Hint) End Try diff --git a/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb b/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb index 4be05b8..2753034 100644 --- a/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MyRadioButton.xaml.vb @@ -7,10 +7,6 @@ Public Class MyRadioButton Public Uuid As Integer = GetUuid() Public Event Check(sender As Object, raiseByMouse As Boolean) - Public Event Change(sender As Object, raiseByMouse As Boolean) - Public Sub RaiseChange() - RaiseEvent Change(Me, False) - End Sub '使外部程序可以引发本控件的 Change 事件 '自定义属性 @@ -46,23 +42,22 @@ Public Class MyRadioButton ''' 手动设置 Checked 属性。 ''' ''' 新的 Checked 属性。 - ''' 是否由用户引发。 + ''' 是否由用户引发。 ''' 是否执行动画。 - Public Sub SetChecked(value As Boolean, user As Boolean, anime As Boolean) + Public Sub SetChecked(value As Boolean, raiseByMouse As Boolean, anime As Boolean) Try '自定义属性基础 Dim IsChanged As Boolean = False - If IsLoaded AndAlso Not value = _Checked Then RaiseEvent Change(Me, user) - If Not value = _Checked Then + If _Checked <> value Then _Checked = value IsChanged = True End If '保证只有一个单选框选中 - If IsNothing(Parent) Then Return + If Parent Is Nothing Then Return Dim RadioboxList As New List(Of MyRadioButton) Dim CheckedCount As Integer = 0 '收集控件列表与选中个数 @@ -105,7 +100,8 @@ Public Class MyRadioButton RefreshColor(Nothing, anime) '触发事件 - If Checked Then RaiseEvent Check(Me, user) + If Checked Then RaiseEvent Check(Me, raiseByMouse) + RaiseCustomEvent() Catch ex As Exception Log(ex, "单选按钮勾选改变错误", LogLevel.Hint) diff --git a/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb b/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb index ee3bb15..a8fde05 100644 --- a/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb +++ b/Plain Craft Launcher 2/Controls/MySearchBox.xaml.vb @@ -39,4 +39,7 @@ TextBox.Focus() End Sub + Private Sub MySearchBox_KeyUp(sender As Object, e As KeyEventArgs) Handles Me.KeyUp + If e.Key = Key.Enter Then RaiseCustomEvent() + End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyTextBox.vb b/Plain Craft Launcher 2/Controls/MyTextBox.vb index 9149737..55a00b3 100644 --- a/Plain Craft Launcher 2/Controls/MyTextBox.vb +++ b/Plain Craft Launcher 2/Controls/MyTextBox.vb @@ -264,7 +264,7 @@ If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 '有动画 AniStart({ - AaColor(Me, BorderBrushProperty, ForeColorName, AnimationTime)， + AaColor(Me, BorderBrushProperty, ForeColorName, AnimationTime), AaColor(Me, BackgroundProperty, BackColorName, AnimationTime) }, "MyTextBox Color " & Uuid) Else @@ -291,4 +291,8 @@ End If End Sub + '在按下回车时触发自定义事件 + Private Sub MyTextBox_KeyUp(sender As Object, e As KeyEventArgs) Handles Me.KeyUp + If e.Key = Key.Enter Then RaiseCustomEvent() + End Sub End Class diff --git a/Plain Craft Launcher 2/Controls/MyTextButton.vb b/Plain Craft Launcher 2/Controls/MyTextButton.vb index b7e3a73..4bde410 100644 --- a/Plain Craft Launcher 2/Controls/MyTextButton.vb +++ b/Plain Craft Launcher 2/Controls/MyTextButton.vb @@ -22,15 +22,15 @@ End Set End Property Public Shared ReadOnly TextProperty As DependencyProperty = - DependencyProperty.Register("Text", GetType(String), GetType(MyTextButton), New PropertyMetadata("", Sub(sender As MyTextButton, e As DependencyPropertyChangedEventArgs) - If Not e.OldValue = e.NewValue Then - AniStart({ - AaOpacity(sender, -sender.Opacity, 50), - AaCode(Sub() sender.Content = e.NewValue,, True), - AaOpacity(sender, 1, 170) - }, "MyTextButton Text " & sender.Uuid) - End If - End Sub)) + DependencyProperty.Register("Text", GetType(String), GetType(MyTextButton), New PropertyMetadata("", + Sub(sender As MyTextButton, e As DependencyPropertyChangedEventArgs) + If e.OldValue = e.NewValue Then Return + AniStart({ + AaOpacity(sender, -sender.Opacity, 50), + AaCode(Sub() sender.Content = e.NewValue,, True), + AaOpacity(sender, 1, 170) + }, "MyTextButton Text " & sender.Uuid) + End Sub)) '鼠标事件 @@ -43,13 +43,12 @@ IsMouseDown = False End Sub Private Sub MyTextButton_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp - If IsMouseDown Then - IsMouseDown = False - Log("[Control] 按下文本按钮：" & Text) - RaiseEvent Click(Me, Nothing) - ModEvent.TryStartEvent(EventType, EventData) - e.Handled = True - End If + If Not IsMouseDown Then Return + IsMouseDown = False + Log("[Control] 按下文本按钮：" & Text) + RaiseEvent Click(Me, Nothing) + RaiseCustomEvent() + e.Handled = True End Sub '指向动画 @@ -57,7 +56,7 @@ Private Const AnimationTimeIn As Integer = 100 Private Const AnimationTimeOut As Integer = 200 Private ColorName As String - Private Sub RefreshColor() Handles Me.MouseEnter, Me.MouseLeave, Me.IsEnabledChanged, Me.MouseLeftButtonDown， Me.MouseLeftButtonUp + Private Sub RefreshColor() Handles Me.MouseEnter, Me.MouseLeave, Me.IsEnabledChanged, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp '判断当前颜色 Dim ForeName As String Dim Time As Integer @@ -85,26 +84,4 @@ End If End Sub - '实现自定义事件 - Public Property EventType As String - Get - Return GetValue(EventTypeProperty) - End Get - Set(value As String) - SetValue(EventTypeProperty, value) - End Set - End Property - Public Shared ReadOnly EventTypeProperty As DependencyProperty = DependencyProperty.Register( - "EventType", GetType(String), GetType(MyTextButton), New PropertyMetadata(Nothing)) - Public Property EventData As String - Get - Return GetValue(EventDataProperty) - End Get - Set(value As String) - SetValue(EventDataProperty, value) - End Set - End Property - Public Shared ReadOnly EventDataProperty As DependencyProperty = DependencyProperty.Register( - "EventData", GetType(String), GetType(MyTextButton), New PropertyMetadata(Nothing)) - End Class diff --git a/Plain Craft Launcher 2/FormMain.xaml.vb b/Plain Craft Launcher 2/FormMain.xaml.vb index f1befdc..cb0da8d 100644 --- a/Plain Craft Launcher 2/FormMain.xaml.vb +++ b/Plain Craft Launcher 2/FormMain.xaml.vb @@ -11,6 +11,23 @@ Public Class FormMain Dim FeatureList As New List(Of KeyValuePair(Of Integer, String)) '统计更新日志条目 #If BETA Then + If LastVersion < 372 Then 'Release 2.10.9 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：如果版本设置了自定义描述，会在标题后面以淡灰色显示其版本号")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：支持为一个控件设置多个自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：修改变量、弹出提示自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：添加大量替换标记，允许在更多设置和 XAML 中使用更多替换标记")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 MMC 整合包")) + FeatureCount += 33 + BugCount += 11 + End If + If LastVersion < 369 Then 'Release 2.10.8 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许在版本设置中设置禁止更新 Mod，以防整合包玩家误操作")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：若整合包需要 PCL 不兼容的加载器，允许选择跳过它的安装")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "删除：由于已不再需要，删除手动安装包下载功能")) + FeatureCount += 21 + BugCount += 32 + End If If LastVersion < 367 Then 'Release 2.10.6 FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：启用 MCIM 社区资源镜像源，以缓解社区资源难以下载的问题")) FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：正版登录出错时无法给出正确的错误信息")) @@ -96,6 +113,52 @@ Public Class FormMain '3：BUG+ IMP* FEAT- '2：BUG* IMP- '1：BUG- + If LastVersion < 375 Then 'Snapshot 2.11.2 + If LastVersion >= 373 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：对联机进行了各种各样的优化，以改善稳定性")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：若有加入者的网络环境比房主更好，会提示可以让那位加入者担任房主")) + End If + FeatureCount += 16 + BugCount += 4 + End If + If LastVersion < 374 Then 'Snapshot 2.11.1 + If LastVersion >= 373 Then + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：使用离线登录也可以直接加入联机房间了")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：会从所有共享节点中自动选择负载最低的进行中继连接")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：若复制了邀请码，则可以直接快速加入房间")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：关闭 PCL 时总是会提示是否退出联机，防止在关闭 PCL 时无意地关闭或退出了房间")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许自定义要连接的节点")) + End If + FeatureCount += 9 + BugCount += 7 + End If + If LastVersion < 373 Then 'Snapshot 2.11.0 + FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增：联机功能！")) + FeatureCount += 7 + BugCount += 10 + End If + If LastVersion < 371 Then 'Snapshot 2.10.9 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化：如果版本设置了自定义描述，会在标题后面以淡灰色显示其版本号")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：支持为一个控件设置多个自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：修改变量、弹出提示自定义事件")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "新增：添加大量替换标记，允许在更多设置和 XAML 中使用更多替换标记")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：无法安装 MMC 整合包")) + FeatureCount += 33 + BugCount += 11 + End If + If LastVersion < 370 Then 'Snapshot 2.10.8 + If LastVersion >= 368 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureCount += 3 + BugCount += 4 + End If + If LastVersion < 368 Then 'Snapshot 2.10.7 + FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增：允许在版本设置中设置禁止更新 Mod，以防整合包玩家误操作")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：网络与下载稳定性优化")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化：若整合包需要 PCL 不兼容的加载器，允许选择跳过它的安装")) + FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "删除：由于已不再需要，删除手动安装包下载功能")) + FeatureCount += 19 + BugCount += 28 + End If If LastVersion < 366 Then 'Snapshot 2.10.6 FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化：启用 MCIM 社区资源镜像源，以缓解社区资源难以下载的问题")) FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复：正版登录出错时无法给出正确的错误信息")) @@ -297,7 +360,7 @@ Public Class FormMain FrmLaunchRight.PageState = MyPageRight.PageStates.ContentStay '模式提醒 #If DEBUG Then - Hint("[开发者模式] PCL 正以开发者模式运行，这可能会造成严重的性能下降，请务必立即向开发者反馈此问题！", HintType.Critical) + Hint("[开发者模式] PCL 正以开发者模式运行，这可能会造成严重的性能下降，请务必立即向开发者反馈此问题！", HintType.Red) #End If If ModeDebug Then Hint("[调试模式] PCL 正以调试模式运行，这可能会导致性能下降，若无必要请不要开启！") '尽早执行的加载池 @@ -377,11 +440,16 @@ Public Class FormMain RunInNewThread( Sub() 'EULA 提示 - If Not Setup.Get("SystemEula") Then - Select Case MyMsgBox("在使用 PCL 前，请同意 PCL 的用户协议与免责声明。", "协议授权", "同意", "拒绝", "查看用户协议与免责声明", + Const EulaVersion As Integer = 2 + If Setup.Get("SystemEulaVersion") < EulaVersion Then + Select Case MyMsgBox( + If(Setup.Get("SystemEulaVersion") = 0, + "在使用 PCL 前，请先阅读用户协议与免责声明。", + $"PCL 的用户协议与免责声明已更新。{vbCrLf}请阅读更新后的用户协议与免责声明。"), + "协议授权", "同意", "拒绝", "查看用户协议与免责声明", Button3Action:=Sub() OpenWebsite("https://shimo.im/docs/rGrd8pY8xWkt6ryW")) Case 1 - Setup.Set("SystemEula", True) + Setup.Set("SystemEulaVersion", EulaVersion) Case 2 EndProgram(False) End Select @@ -392,7 +460,7 @@ Public Class FormMain Thread.Sleep(100) DlClientListMojangLoader.Start(1) 'PCL 会同时根据这里的加载结果决定是否使用官方源进行下载 RunCountSub() - ServerLoader.Start(1) + ServerLoader.Start() RunInNewThread(AddressOf TryClearTaskTemp, "TryClearTaskTemp", ThreadPriority.BelowNormal) Catch ex As Exception Log(ex, "初始化加载池运行失败", LogLevel.Feedback) @@ -446,6 +514,8 @@ Public Class FormMain Log("[Start] 最高版本号从 " & LowerVersionCode & " 升高到 " & VersionCode) End If #End If + '迁移 EULA 版本 + If Setup.Get("SystemEula") AndAlso Setup.Get("SystemEulaVersion") = 0 Then Setup.Set("SystemEulaVersion", 1) '被移除的窗口设置选项 If Setup.Get("LaunchArgumentWindowType") = 5 Then Setup.Set("LaunchArgumentWindowType", 1) '修改主题设置项名称 @@ -524,21 +594,19 @@ Public Class FormMain ''' ''' 是否在还有下载任务未完成时发出警告。 Public Sub EndProgram(SendWarning As Boolean) - '发出警告 - If SendWarning AndAlso HasDownloadingTask() Then - If MyMsgBox("还有下载任务尚未完成，是否确定退出？", "提示", "确定", "取消") = 1 Then - '强行结束下载任务 - RunInNewThread( - Sub() - Log("[System] 正在强行停止任务") - For Each Task As LoaderBase In LoaderTaskbar.ToList() - Task.Abort() - Next - End Sub, "强行停止下载任务") - Else - Return - End If + '强行结束下载任务？ + If HasDownloadingTask() Then + If SendWarning AndAlso MyMsgBox("还有下载任务尚未完成，是否确定退出？", "提示", "确定", "取消") = 2 Then Return + RunInNewThread( + Sub() + Log("[System] 正在强行停止任务") + For Each Task As LoaderBase In LoaderTaskbar.ToList() + Task.Abort() + Next + End Sub, "强行停止下载任务") End If + '关闭联机？ + If FrmLinkMain?.TryExit(Not SendWarning, True) Then Return '关闭 RunInUiWait( Sub() @@ -582,7 +650,7 @@ Public Class FormMain FeedbackInfo() Log("请在 https://github.com/Meloong-Git/PCL/issues 提交错误报告，以便于作者解决此问题！") IsLogShown = True - ShellOnly(Path & "PCL\Log1.txt") + StartProcess(Path & "PCL\Log1.txt") End If Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉 End If @@ -666,9 +734,9 @@ Public Class FormMain If e.Key = Key.F12 Then PageSetupUI.HiddenForceShow = Not PageSetupUI.HiddenForceShow If PageSetupUI.HiddenForceShow Then - Hint("功能隐藏设置已暂时关闭！", HintType.Finish) + Hint("功能隐藏设置已暂时关闭！", HintType.Green) Else - Hint("功能隐藏设置已重新开启！", HintType.Finish) + Hint("功能隐藏设置已重新开启！", HintType.Green) End If PageSetupUI.HiddenRefresh() Return @@ -714,6 +782,22 @@ Public Class FormMain Catch ex As Exception Log(ex, "切回窗口时出错", LogLevel.Feedback) End Try + '读取剪贴板，自动加入联机房间 + If PageLinkMain.LinkState <> PageLinkMain.LinkStates.Waiting Then Return '已启动联机 + If PageCurrent = PageType.Link Then Return '已在联机界面 + Dim Code = ClipboardGetText() : If Code Is Nothing Then Return '剪贴板无文本 + If Setup.Get("LinkLastAutoJoinInviteCode") = Code Then Return + If PageLinkMain.ValidateCodeFormat(Code) IsNot Nothing Then Return '不是邀请码 + Setup.Set("LinkLastAutoJoinInviteCode", Code) + RunInThread( + Sub() + If MyMsgBox("嘿，是否使用复制的邀请码加入房间？", "加入联机房间", "加入", "取消") = 2 Then Return '防止弹窗阻碍主线程，所以必须放在工作线程 + RunInUi( + Sub() + PageLinkMain.Join(Code) + ClipboardSet(Nothing, False) + End Sub) + End Sub) End Sub '文件拖放 @@ -764,12 +848,12 @@ Public Class FormMain Dim AuthlibServer As String = Net.WebUtility.UrlDecode(Str.Substring("authlib-injector:yggdrasil-server:".Length)) Log("[System] Authlib 拖拽：" & AuthlibServer) If Not String.IsNullOrEmpty(New ValidateHttp().Validate(AuthlibServer)) Then - Hint($"输入的 Authlib 验证服务器不符合网址格式（{AuthlibServer}）！", HintType.Critical) + Hint($"输入的 Authlib 验证服务器不符合网址格式（{AuthlibServer}）！", HintType.Red) Return End If Dim TargetVersion = If(PageCurrent = PageType.VersionSetup, PageVersionLeft.Version, McVersionCurrent) If TargetVersion Is Nothing Then - Hint("请先下载游戏，再设置第三方登录！", HintType.Critical) + Hint("请先下载游戏，再设置第三方登录！", HintType.Red) Return End If If AuthlibServer = "https://littleskin.cn/api/yggdrasil" Then @@ -816,7 +900,7 @@ Public Class FormMain '获取文件并检查 Dim FilePathRaw = e.Data.GetData(DataFormats.FileDrop) If FilePathRaw Is Nothing Then '#2690 - Hint("请将文件解压后再拖入！", HintType.Critical) + Hint("请将文件解压后再拖入！", HintType.Red) Return End If e.Handled = True @@ -834,10 +918,10 @@ Public Class FormMain 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) + Hint("请拖入一个文件，而非文件夹！", HintType.Red) Return ElseIf Not File.Exists(FilePathList.First) Then - Hint("拖入的文件不存在：" & FilePathList.First, HintType.Critical) + Hint("拖入的文件不存在：" & FilePathList.First, HintType.Red) Return End If '多文件拖拽 @@ -845,7 +929,7 @@ Public Class FormMain '必须要求全部为 jar 文件 For Each File In FilePathList If Not {"jar", "litemod", "disabled", "old"}.Contains(File.AfterLast(".").ToLower) Then - Hint("一次请只拖入一个文件！", HintType.Critical) + Hint("一次请只拖入一个文件！", HintType.Red) Return End If Next @@ -864,7 +948,7 @@ Public Class FormMain Sub() Setup.Set("UiCustomType", 1) FrmLaunchRight.ForceRefresh() - Hint("已加载主页自定义文件！", HintType.Finish) + Hint("已加载主页自定义文件！", HintType.Green) End Sub) Return End If @@ -974,9 +1058,9 @@ Public Class FormMain #Region "切换页面" '页面种类与属性 - '注意，这一枚举在 “切换页面” EventType 中调用，应视作公开 API 的一部分 ''' ''' 页面种类。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum PageType ''' @@ -1022,30 +1106,21 @@ Public Class FormMain End Enum ''' ''' 次要页面种类。其数值必须与 StackPanel 中的下标一致。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum PageSubType [Default] = 0 - DownloadInstall = 1 - DownloadClient = 4 - DownloadOptiFine = 5 - DownloadForge = 6 - DownloadNeoForge = 7 - DownloadFabric = 8 - DownloadLiteLoader = 9 - DownloadMod = 11 - DownloadPack = 12 - DownloadDataPack = 13 - DownloadResourcePack = 14 - DownloadShader = 15 + DownloadInstall = 0 + DownloadMod = 2 + DownloadPack = 3 + DownloadDataPack = 4 + DownloadResourcePack = 5 + DownloadShader = 6 SetupLaunch = 0 - SetupUI = 1 - SetupSystem = 2 - SetupLink = 3 - LinkHiper = 1 - LinkIoi = 2 - LinkSetup = 4 - LinkHelp = 5 - LinkFeedback = 6 + SetupLink = 1 + SetupUI = 2 + SetupSystem = 3 + LinkMain = 0 OtherHelp = 0 OtherAbout = 1 OtherTest = 2 @@ -1273,8 +1348,8 @@ Public Class FormMain 'PageGet 方法会在未设置 SubType 时指定默认值，并建立相关页面的实例 PageChangeAnim(FrmDownloadLeft, FrmDownloadLeft.PageGet(SubType)) Case PageType.Link '联机 - If FrmLinkLeft Is Nothing Then FrmLinkLeft = New PageLinkLeft - PageChangeAnim(FrmLinkLeft, FrmLinkLeft.PageGet(SubType)) + If FrmLinkMain Is Nothing Then FrmLinkMain = New PageLinkMain + PageChangeAnim(New MyPageLeft, FrmLinkMain) Case PageType.Setup '设置 If FrmSetupLeft Is Nothing Then FrmSetupLeft = New PageSetupLeft PageChangeAnim(FrmSetupLeft, FrmSetupLeft.PageGet(SubType)) @@ -1470,7 +1545,7 @@ Public Class FormMain '投降 Public Sub AprilGiveup() Handles BtnExtraApril.Click If IsAprilEnabled AndAlso Not IsAprilGiveup Then - Hint("=D", HintType.Finish) + Hint("=D", HintType.Green) IsAprilGiveup = True FrmLaunchLeft.AprilScaleTrans.ScaleX = 1 FrmLaunchLeft.AprilScaleTrans.ScaleY = 1 @@ -1488,7 +1563,7 @@ Public Class FormMain For Each Watcher In McWatcherList Watcher.Kill() Next - Hint("已关闭运行中的 Minecraft！", HintType.Finish) + Hint("已关闭运行中的 Minecraft！", HintType.Green) Catch ex As Exception Log(ex, "强制关闭所有 Minecraft 失败", LogLevel.Feedback) End Try @@ -1514,7 +1589,8 @@ Public Class FormMain End Function Private Function BtnExtraBack_GetRealChild() As MyScrollViewer If PanMainRight.Child Is Nothing OrElse TypeOf PanMainRight.Child IsNot MyPageRight Then Return Nothing - Return CType(PanMainRight.Child, MyPageRight).PanScroll + Dim Page As MyPageRight = PanMainRight.Child + Return Page.FindName(Page.PanScroll) End Function #End Region diff --git a/Plain Craft Launcher 2/Images/Heads/EasyTier.png b/Plain Craft Launcher 2/Images/Heads/EasyTier.png new file mode 100644 index 0000000..3460251 Binary files /dev/null and b/Plain Craft Launcher 2/Images/Heads/EasyTier.png differ diff --git a/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb b/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb index 06bf1a6..4248ea4 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModAnimation.vb @@ -467,7 +467,7 @@ Public Module ModAnimation ''' 按照 WPF 方式旋转控件的动画。 ''' ''' 动画的对象。它必须已经拥有了单一的 ScaleTransform 值。 - ''' 大小改变的百分比（如-0.6）。 + ''' 旋转角度（度）。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 @@ -792,44 +792,46 @@ Public Module ModAnimation AniFPSTimer = AniLastTick AniRunning = True '标记动画执行开始 - RunInNewThread(Sub() - Try - Log("[Animation] 动画线程开始") - Do While True - '两帧之间的间隔时间 - Dim DeltaTime As Long = MathClamp(GetTimeTick() - AniLastTick, 0, 100000) - If DeltaTime < 3 Then GoTo Sleeper - AniLastTick = GetTimeTick() - '记录 FPS - If ModeDebug Then - If MathClamp(AniLastTick - AniFPSTimer, 0, 100000) >= 500 Then - AniFPS = AniFPSCounter - AniFPSCounter = 0 - AniFPSTimer = AniLastTick - End If - AniFPSCounter += 2 - End If - '执行动画 - RunInUiWait(Sub() - AniCount = 0 - AniTimer(DeltaTime * AniSpeed) - '#If DEBUG Then - ' FrmMain.Title = "F " & AniFPS & ", A " & AniCount & ", R " & NetManage.FileRemain - '#Else - ' If ModeDebug Then FrmMain.Title = "FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManage.FileRemain - '#End If - If RandomInteger(0, 64 * If(ModeDebug, 5, 30)) = 0 AndAlso ((AniFPS < 62 AndAlso AniFPS > 0) OrElse AniCount > 4 OrElse NetManager.FileRemain <> 0) Then - Log("[Report] FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManager.FileRemain & "（" & GetString(NetManager.Speed) & "/s）") - End If - End Sub) + RunInNewThread( + Sub() + Try + Log("[Animation] 动画线程开始") + Do While True + '两帧之间的间隔时间 + Dim DeltaTime As Long = MathClamp(GetTimeTick() - AniLastTick, 0, 100000) + If DeltaTime < 3 Then GoTo Sleeper + AniLastTick = GetTimeTick() + '记录 FPS + If ModeDebug Then + If MathClamp(AniLastTick - AniFPSTimer, 0, 100000) >= 500 Then + AniFPS = AniFPSCounter + AniFPSCounter = 0 + AniFPSTimer = AniLastTick + End If + AniFPSCounter += 2 + End If + '执行动画 + RunInUiWait( + Sub() + AniCount = 0 + AniTimer(DeltaTime * AniSpeed) + '#If DEBUG Then + ' FrmMain.Title = "F " & AniFPS & ", A " & AniCount & ", R " & NetManage.FileRemain + '#Else + ' If ModeDebug Then FrmMain.Title = "FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManage.FileRemain + '#End If + If RandomInteger(0, 64 * If(ModeDebug, 5, 30)) = 0 AndAlso ((AniFPS < 62 AndAlso AniFPS > 0) OrElse AniCount > 4 OrElse NetManager.FileRemain <> 0) Then + Log("[Report] FPS " & AniFPS & ", 动画 " & AniCount & ", 下载中 " & NetManager.FileRemain & "（" & GetString(NetManager.Speed) & "/s）") + End If + End Sub) Sleeper: - '控制 FPS - Thread.Sleep(1) - Loop - Catch ex As Exception - Log(ex, "动画帧执行失败", LogLevel.Critical) - End Try - End Sub, "Animation", ThreadPriority.AboveNormal) + '控制 FPS + Thread.Sleep(1) + Loop + Catch ex As Exception + Log(ex, "动画帧执行失败", LogLevel.Critical) + End Try + End Sub, "Animation", ThreadPriority.AboveNormal) End Sub ''' @@ -996,7 +998,7 @@ NextAni: Case AniType.ScaleTransform Dim Obj As FrameworkElement = Ani.Obj If TypeOf Obj.RenderTransform IsNot ScaleTransform Then - Obj.RenderTransformOrigin = New Point(0.5, 0.5) + If Obj.RenderTransformOrigin = New Point(0, 0) Then Obj.RenderTransformOrigin = New Point(0.5, 0.5) Obj.RenderTransform = New ScaleTransform(1, 1) End If Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.TimeFinished / Ani.TimeTotal, Ani.TimePercent)) @@ -1006,7 +1008,7 @@ NextAni: Case AniType.RotateTransform Dim Obj As FrameworkElement = Ani.Obj If TypeOf Obj.RenderTransform IsNot RotateTransform Then - Obj.RenderTransformOrigin = New Point(0.5, 0.5) + If Obj.RenderTransformOrigin = New Point(0, 0) Then Obj.RenderTransformOrigin = New Point(0.5, 0.5) Obj.RenderTransform = New RotateTransform(0) End If Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.TimeFinished / Ani.TimeTotal, Ani.TimePercent)) diff --git a/Plain Craft Launcher 2/Modules/Base/ModBase.vb b/Plain Craft Launcher 2/Modules/Base/ModBase.vb index b4ef294..c54156d 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModBase.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModBase.vb @@ -5,6 +5,7 @@ Imports System.Runtime.CompilerServices Imports System.Security.Cryptography Imports System.Security.Principal Imports System.Text.RegularExpressions +Imports System.Threading.Tasks Imports System.Xaml Imports Newtonsoft.Json @@ -13,13 +14,13 @@ Public Module ModBase #Region "声明" '下列版本信息由更新器自动修改 - Public Const VersionBaseName As String = "2.10.6" '不含分支前缀的显示用版本名 - Public Const VersionStandardCode As String = "2.10.6." & VersionBranchCode '标准格式的四段式版本号 + Public Const VersionBaseName As String = "2.11.2" '不含分支前缀的显示用版本名 + Public Const VersionStandardCode As String = "2.11.2." & VersionBranchCode '标准格式的四段式版本号 Public Const CommitHash As String = "" 'Commit Hash，由 GitHub Workflow 自动替换 #If BETA Then - Public Const VersionCode As Integer = 367 'Release + Public Const VersionCode As Integer = 372 'Release #Else - Public Const VersionCode As Integer = 366 'Snapshot + Public Const VersionCode As Integer = 375 'Snapshot #End If '自动生成的版本信息 Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName @@ -69,7 +70,7 @@ Public Module ModBase ''' ''' 识别码。 ''' - Public UniqueAddress As String = SecretGetUniqueAddress() + Public Identify As String = SecretGetIdentify() ''' ''' 程序是否已结束。 ''' @@ -498,6 +499,7 @@ Public Module ModBase RealNum += Digit * Scale Scale *= FromRadix Next + If RealNum = 0 Then Return "0" '转换为指定进制 Dim Result = "" While RealNum > 0 @@ -761,21 +763,9 @@ Public Module ModBase 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 ''' - ''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。 - ''' - Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String - Dim Name As String = GetFileNameFromPath(FilePath) - If Name.Contains(".") Then - Return Name.Substring(0, Name.LastIndexOfF(".")) - Else - Return Name - End If - End Function - ''' ''' 从文件夹路径获取文件夹名。 ''' Public Function GetFolderNameFromPath(FolderPath As String) As String @@ -791,8 +781,8 @@ Public Module ModBase Public Sub CopyFile(FromPath As String, ToPath As String) Try '还原文件路径 - FromPath = ShortenPath(If(FromPath.Contains(":\"), FromPath, Path & FromPath)) - ToPath = ShortenPath(If(ToPath.Contains(":\"), ToPath, Path & ToPath)) + FromPath = If(FromPath.Contains(":\"), FromPath, Path & FromPath) + ToPath = If(ToPath.Contains(":\"), ToPath, Path & ToPath) '如果复制同一个文件则跳过 If FromPath = ToPath Then Return '确保目录存在 @@ -861,7 +851,7 @@ Public Module ModBase ''' 是否将文件内容追加到当前文件，而不是覆盖它。 Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) '处理相对路径 - FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath)) + FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath) '确保目录存在 Directory.CreateDirectory(GetPathFromFullPath(FilePath)) '写入文件 @@ -886,7 +876,7 @@ Public Module ModBase ''' 是否将文件内容追加到当前文件，而不是覆盖它。 Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) '处理相对路径 - FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath)) + FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath) '确保目录存在 Directory.CreateDirectory(GetPathFromFullPath(FilePath)) '写入文件 @@ -1283,7 +1273,7 @@ Re: Return Nothing Catch ex As Exception Log(ex, "检查文件出错") - Return GetExceptionSummary(ex) + Return ex.GetBrief() End Try End Function End Class @@ -1294,11 +1284,11 @@ Re: ''' Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing, Optional ProgressIncrementHandler As Action(Of Double) = Nothing) - Directory.CreateDirectory(ShortenPath(DestDirectory)) + 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(ShortenPath(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", "")), FileMode.OpenOrCreate, FileAccess.Write) + 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) @@ -1312,13 +1302,12 @@ Re: Dim TotalCount As Long = Archive.Entries.Count For Each Entry As ZipArchiveEntry In Archive.Entries If ProgressIncrementHandler IsNot Nothing AndAlso TotalCount > 0 Then ProgressIncrementHandler(1 / TotalCount) - Dim DestinationPath As String = ShortenPath(IO.Path.Combine(DestDirectory, Entry.FullName)) - If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then - Continue For '不创建空文件夹 - Else - Directory.CreateDirectory(GetPathFromFullPath(DestinationPath)) - Entry.ExtractToFile(DestinationPath, True) - End If + Dim DestinationFullPath As String = IO.Path.Combine(DestDirectory, Entry.FullName) + If Not IO.Path.GetFullPath(DestinationFullPath).StartsWithF(IO.Path.GetFullPath(DestDirectory), True) Then Continue For 'ZipSlip 漏洞修复 + If DestinationFullPath.EndsWithF("\") OrElse DestinationFullPath.EndsWithF("/") Then Continue For '不创建空文件夹 + Dim DestinationDirectory As String = GetPathFromFullPath(DestinationFullPath) + Directory.CreateDirectory(DestinationDirectory) + Entry.ExtractToFile(DestinationFullPath.Replace(DestinationDirectory, ShortenPath(DestinationDirectory)), True) '#7329 Next End Using End If @@ -1329,11 +1318,20 @@ Re: ''' Public Function DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False) As Integer If Not Directory.Exists(Path) Then Return 0 + If Not Path.EndsWithF("\") Then Path &= "\" + If Path.EndsWith(":\") OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.Desktop) & "\" OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory) & "\" OrElse + Path = Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments) & "\" Then '#7030 + Throw New UnauthorizedAccessException("这是重要的系统文件夹，无法删除：" & Path) + End If + '实际删除 Dim DeletedCount As Integer = 0 Dim Files As String() Try Files = Directory.GetFiles(Path) Catch ex As DirectoryNotFoundException '#4549 + If Not Directory.Exists(Path) Then Return 0 '可能已被其他线程删除 Log(ex, $"疑似为孤立符号链接，尝试直接删除（{Path}）", LogLevel.Developer) Directory.Delete(Path) Return 0 @@ -1364,6 +1362,7 @@ RetryFile: RetryDir: Try Directory.Delete(Path, True) + Catch ex As DirectoryNotFoundException Catch ex As Exception If Not RetriedDir AndAlso Not RunInUi() Then RetriedDir = True @@ -1397,21 +1396,24 @@ RetryDir: ''' 遍历文件夹中的所有文件。 ''' Public Function EnumerateFiles(Directory As String) As IEnumerable(Of FileInfo) - Dim Info As New DirectoryInfo(ShortenPath(Directory)) + Dim Info As New DirectoryInfo(Directory) If Not Info.Exists Then Return New List(Of FileInfo) Return Info.EnumerateFiles("*", SearchOption.AllDirectories) End Function ''' ''' 若路径长度大于指定值，则将长路径转换为短路径。 + ''' 如果路径不存在，则返回原始路径。 ''' - Public Function ShortenPath(LongPath As String, Optional ShortenThreshold As Integer = 247) As String - If LongPath.Length <= ShortenThreshold Then Return LongPath + Public Function ShortenPath(LongPath As String) As String + If LongPath.Length <= 200 OrElse LongPath.StartsWithF("http", True) Then Return LongPath + If Not Directory.Exists(LongPath) AndAlso Not File.Exists(LongPath) Then Return LongPath Dim ShortPath As New StringBuilder(260) - GetShortPathName(LongPath, ShortPath, 260) - Return ShortPath.ToString + GetShortPathName(LongPath.Replace("/", "\"), ShortPath, 260) '第一个参数也会在调用后被修改，使用 Replace 后不会影响原始字符串 + ShortenPath = ShortPath.ToString + If String.IsNullOrEmpty(ShortenPath) Then Return LongPath End Function - Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As StringBuilder, ByVal cchBuffer As Integer) As Integer + Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (lpszLongPath As String, lpszShortPath As StringBuilder, cchBuffer As Integer) As Integer #End Region @@ -1420,10 +1422,10 @@ RetryDir: Public vbRQ As Char = Convert.ToChar(8221) ''' - ''' 提取 Exception 的具体描述与堆栈。 + ''' 提取 Exception 与 Inner Exception 的详细描述与堆栈信息。返回内容总是多于一行。 ''' ''' 是否必须显示所有堆栈。通常用于判定堆栈信息。 - Public Function GetExceptionDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String + Public Function GetDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String If Ex Is Nothing Then Return "无可用错误信息！" '获取最底层的异常 @@ -1450,17 +1452,17 @@ RetryDir: Loop '构造输出信息 - Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList) - If CommonReason Is Nothing Then + Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList) + If UsualReason Is Nothing Then Return DescList.Join(vbCrLf) Else - Return CommonReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf) + Return UsualReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf) End If End Function ''' - ''' 提取 Exception 描述，汇总到一行。 + ''' 提取 Exception 与 Inner Exception 的描述，汇总到一行。 ''' - Public Function GetExceptionSummary(Ex As Exception) As String + Public Function GetBrief(Ex As Exception) As String If Ex Is Nothing Then Return "无可用错误信息！" '获取最底层的异常 @@ -1479,28 +1481,27 @@ RetryDir: Dim Desc As String = Join(DescList, vbCrLf & "→ ") '构造输出信息 - Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList) - If CommonReason IsNot Nothing Then - Return CommonReason & "详细错误：" & DescList.First + Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList) + If UsualReason IsNot Nothing Then + Return UsualReason & "详细错误：" & DescList.First Else DescList.Reverse() '让最深层错误在最左边 Return Join(DescList, " ← ") End If End Function - Private Function AnalyzeCommonReason(InnerEx As Exception, DescList As List(Of String)) As String + Private Function AnalyzeUsualReason(InnerEx As Exception, OuterEx As Exception, DescList As List(Of String)) As String If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。" ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then - Return "PCL 的权限不足。请尝试右键 PCL，选择以管理员身份运行。" + Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行。" ElseIf TypeOf InnerEx Is OutOfMemoryException Then Return "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。" ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then Return "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。" ElseIf TypeOf InnerEx Is SocketException AndAlso DescList.Any(Function(l) l.Contains("WSAStartup")) Then Return "请尝试卸载中国移动云盘，然后再试。" - ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", - "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then - Return "你的网络环境不佳，导致难以连接到服务器。请稍后重试，或使用 VPN 以改善网络环境。" + ElseIf OuterEx.IsNetworkRelated() Then + Return "你的网络环境不佳，请稍后再试，或使用 VPN 改善网络环境。" Else Return Nothing End If @@ -1514,6 +1515,19 @@ RetryDir: Return [Enum].GetName(EnumData.GetType, EnumData) End Function ''' + ''' 将字符串转换为枚举类型，支持数字或原文两种格式，若为空字符串则返回 0。 + ''' 若转换失败会抛出异常。 + ''' + Public Function ParseToEnum(Of T)(Str As String) As T + If String.IsNullOrEmpty(Str) Then + Return CType(0, Object) + ElseIf IsNumeric(Str) Then + Return CType(CInt(Str), Object) + Else + Return [Enum].Parse(GetType(T), Str, True) + End If + End Function + ''' ''' 将文件大小转化为适合的文本形式，如“1.28 M”。 ''' ''' 以字节为单位的大小表示。 @@ -1714,6 +1728,7 @@ RetryDir: ''' Public Function StartsWithF(Str As String, Prefix As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.StartsWith(Prefix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) End Function ''' @@ -1721,6 +1736,7 @@ RetryDir: ''' Public Function EndsWithF(Str As String, Suffix As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.EndsWith(Suffix, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) End Function ''' @@ -1728,6 +1744,7 @@ RetryDir: ''' Public Function ContainsF(Str As String, SubStr As String, Optional IgnoreCase As Boolean = False) As Boolean + If Str Is Nothing Then Return False Return Str.IndexOf(SubStr, If(IgnoreCase, StringComparison.OrdinalIgnoreCase, StringComparison.Ordinal)) >= 0 End Function ''' @@ -1764,6 +1781,7 @@ RetryDir: ''' 如果输入有误，返回 0。 ''' Public Function Val(Str As Object) As Double + If Str Is Nothing Then Return 0 Try Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str)) Catch @@ -2019,8 +2037,8 @@ RetryDir: '构造函数 Public Sub New() End Sub - Public Sub New(data As IEnumerable(Of KeyValuePair(Of TKey, TValue))) - For Each DataItem In data + Public Sub New(Data As IEnumerable(Of KeyValuePair(Of TKey, TValue))) + For Each DataItem In Data _Dictionary.Add(DataItem.Key, DataItem.Value) Next End Sub @@ -2134,6 +2152,29 @@ RetryDir: Return result End Function + ''' + ''' 为 Task 设置超时，在超时时抛出 TimeoutException。 + ''' + Public Function GetResultWithTimeout(Of T)(TargetTask As Task(Of T), TokenSource As CancellationTokenSource, TimeoutMs As Integer) As T + Dim DelayTask = Task.Delay(TimeoutMs) + If Task.WhenAny(TargetTask, DelayTask).GetAwaiter().GetResult() Is DelayTask Then + TokenSource.Cancel() + Throw New TimeoutException($"任务超时（{TimeoutMs} ms）") + End If + Return TargetTask.GetAwaiter().GetResult() + End Function + ''' + ''' 为 Task 设置超时，在超时时抛出 TimeoutException。 + ''' + Public Sub GetResultWithTimeout(TargetTask As Task, TokenSource As CancellationTokenSource, TimeoutMs As Integer) + Dim DelayTask = Task.Delay(TimeoutMs) + If Task.WhenAny(TargetTask, DelayTask).GetAwaiter().GetResult() Is DelayTask Then + TokenSource.Cancel() + Throw New TimeoutException($"任务超时（{TimeoutMs} ms）") + End If + TargetTask.GetAwaiter().GetResult() + End Sub + ''' ''' 可用于临时存放文件的，不含任何特殊字符的文件夹路径，以“\”结尾。 ''' @@ -2176,7 +2217,7 @@ RetryDir: ''' 返回程序的返回代码，如果运行失败将抛出异常。 ''' Public Function RunAsAdmin(Argument As String) As Integer - Dim NewProcess = Process.Start(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument}) + Dim NewProcess = StartProcess(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument}) NewProcess.WaitForExit() Return NewProcess.ExitCode End Function @@ -2335,46 +2376,21 @@ NextElement: End Class ''' - ''' 前台运行文件。 + ''' 启动进程并返回进程实例，若失败则抛出异常。 + ''' 会自动进行长路径处理。 ''' - ''' 文件名。可以为“notepad”等缩写。 - ''' 运行参数。 - Public Sub ShellOnly(FileName As String, Optional Arguments As String = "") - Try - FileName = ShortenPath(FileName) - Using Program As New Process - Program.StartInfo.Arguments = Arguments - Program.StartInfo.FileName = FileName - Log("[System] 执行外部命令：" & FileName & " " & Arguments) - Program.Start() - End Using - Catch ex As Exception - Log(ex, "打开文件或程序失败：" & FileName, LogLevel.Msgbox) - End Try - End Sub + Public Function StartProcess(FileName As String, Optional Arguments As String = "") As Process + Return StartProcess(New ProcessStartInfo With {.FileName = FileName, .Arguments = Arguments}) + End Function ''' - ''' 前台运行文件并返回返回值。 + ''' 启动进程并返回进程实例，若失败则抛出异常。 + ''' 会自动进行长路径处理。 ''' - ''' 文件名。可以为“notepad”等缩写。 - ''' 运行参数。 - ''' 等待该程序结束的最长时间（毫秒）。超时会返回 Result.Timeout。 - Public Function ShellAndGetExitCode(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000) As ProcessReturnValues - Try - Using Program As New Process - Program.StartInfo.Arguments = Arguments - Program.StartInfo.FileName = FileName - Log("[System] 执行外部命令并等待返回码：" & FileName & " " & Arguments) - Program.Start() - If Program.WaitForExit(Timeout) Then - Return Program.ExitCode - Else - Return ProcessReturnValues.Timeout - End If - End Using - Catch ex As Exception - Log(ex, "执行命令失败：" & FileName, LogLevel.Msgbox) - Return ProcessReturnValues.Fail - End Try + Public Function StartProcess(StartInfo As ProcessStartInfo) As Process + StartInfo.FileName = ShortenPath(StartInfo.FileName) + If Not String.IsNullOrEmpty(StartInfo.WorkingDirectory) Then StartInfo.WorkingDirectory = ShortenPath(StartInfo.WorkingDirectory) + Log("[System] 启动进程：" & StartInfo.FileName & " " & StartInfo.Arguments) + Return Process.Start(StartInfo) End Function ''' ''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。 @@ -2382,15 +2398,18 @@ NextElement: ''' 文件名。可以为“notepad”等缩写。 ''' 运行参数。 ''' 等待该程序结束的最长时间（毫秒）。超时会抛出错误。 - Public Function ShellAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, Optional WorkingDirectory As String = Nothing) As String + Public Function StartProcessAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, + Optional WorkingDirectory As String = Nothing, Optional Encoding As Encoding = Nothing, Optional PrintLog As Boolean = True) As String Dim Info = New ProcessStartInfo With { .Arguments = Arguments, - .FileName = FileName, + .FileName = ShortenPath(FileName), .UseShellExecute = False, .CreateNoWindow = True, .RedirectStandardError = True, .RedirectStandardOutput = True, - .WorkingDirectory = ShortenPath(If(WorkingDirectory, Path.TrimEnd("\"c))) + .WorkingDirectory = ShortenPath(If(WorkingDirectory, Path.TrimEnd("\"c))), + .StandardErrorEncoding = Encoding, + .StandardOutputEncoding = Encoding } If WorkingDirectory IsNot Nothing Then If Info.EnvironmentVariables.ContainsKey("appdata") Then @@ -2399,8 +2418,8 @@ NextElement: Info.EnvironmentVariables.Add("appdata", WorkingDirectory) End If End If - Log("[System] 执行外部命令并等待返回结果：" & FileName & " " & Arguments) - Using Program As New Process() With {.StartInfo = Info} + If PrintLog Then 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) @@ -2502,17 +2521,14 @@ NextElement: ''' ''' 尝试从字典中获取某项，如果该项不存在，则返回默认值。 ''' - Public Function GetOrDefault(Of TKey, TValue)(Dict As Dictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue - If Dict.ContainsKey(Key) Then - Return Dict(Key) - Else - Return DefaultValue - End If + Public Function GetOrDefault(Of TKey, TValue)(Dict As IDictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue + Dim Result As TValue + Return If(Dict.TryGetValue(Key, Result), Result, DefaultValue) End Function ''' ''' 将某项添加到以列表作为值的字典中。 ''' - Public Sub AddToList(Of TKey, TValue)(Dict As Dictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue) + Public Sub AddToList(Of TKey, TValue)(Dict As IDictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue) If Dict.ContainsKey(Key) Then Dict(Key).Add(Value) Else @@ -2556,11 +2572,11 @@ NextElement: ''' Public Sub OpenWebsite(Url As String) Try - If Not Url.StartsWithF("http", True) AndAlso Not Url.StartsWithF("minecraft://", True) Then + If Not Url.StartsWithF("http", True) AndAlso Not Url.StartsWithF("minecraft://", True) AndAlso Not Url.StartsWithF("minecraft-preview://", True) Then Throw New Exception(Url & " 不是一个有效的网址，它必须以 http 开头！") End If Log("[System] 正在打开网页：" & Url) - Process.Start(Url) + StartProcess(Url) Catch ex As Exception Log(ex, "无法打开网页（" & Url & "）") ClipboardSet(Url, False) @@ -2574,12 +2590,12 @@ NextElement: ''' Public Sub OpenExplorer(Location As String) Try - Location = ShortenPath(Location.Replace("/", "\").Trim(" "c, """"c)) + Location = Location.Replace("/", "\").Trim(" "c, """"c) Log("[System] 正在打开资源管理器：" & Location) If Location.EndsWith("\") Then - ShellOnly(Location) + StartProcess(Location) Else - ShellOnly("explorer", $"/select,""{Location}""") + StartProcess("explorer", $"/select,""{Location}""") End If Catch ex As Exception Log(ex, "打开资源管理器失败，请尝试关闭安全软件（如 360 安全卫士）", LogLevel.Msgbox) @@ -2598,7 +2614,7 @@ Retry: RunInUi( Sub() My.Computer.Clipboard.Clear() - My.Computer.Clipboard.SetText(Text) + If Not String.IsNullOrEmpty(Text) Then My.Computer.Clipboard.SetText(Text) End Sub) Catch ex As Exception RetryCount += 1 @@ -2609,9 +2625,24 @@ Retry: Log(ex, "可能由于剪贴板被其他程序占用，文本复制失败", LogLevel.Hint) End If End Try - If ShowSuccessHint Then Hint("已成功复制！", HintType.Finish) + If ShowSuccessHint Then Hint("已成功复制！", HintType.Green) End Sub) End Sub + ''' + ''' 获取剪贴板文本。将在 UI 线程运行，且不会抛出异常。 + ''' + Public Function ClipboardGetText() As String + Dim Result As String = Nothing + RunInUiWait( + Sub() + Try + If My.Computer.Clipboard.ContainsText() Then Result = My.Computer.Clipboard.GetText() + Catch ex As Exception + Log(ex, "获取剪贴板文本失败") + End Try + End Sub) + Return Result + End Function ''' ''' 以 Byte() 形式获取程序中的资源。 @@ -2746,6 +2777,11 @@ Retry: ''' 将 XML 转换为对应 UI 对象。 ''' Public Function GetObjectFromXML(Str As String) As Object + Str = Str. '兼容旧版自定义事件写法 + Replace("EventType=""", "local:CustomEventService.EventType="""). + Replace("EventData=""", "local:CustomEventService.EventData="""). + Replace("Property=""EventType""", "Property=""local:CustomEventService.EventType"""). + Replace("Property=""EventData""", "Property=""local:CustomEventService.EventData""") Using Stream As New MemoryStream(Encoding.UTF8.GetBytes(Str)) '类型检查 Using Reader As New XamlXmlReader(Stream) @@ -2861,7 +2897,7 @@ Retry: File.Create(Path & "PCL\Log1.txt").Dispose() Catch ex As IOException IsInitSuccess = False - Hint("可能同时开启了多个 PCL，程序可能会出现未知问题！", HintType.Critical) + Hint("可能同时开启了多个 PCL，程序可能会出现未知问题！", HintType.Red) Log(ex, "日志初始化失败（疑似文件占用问题）") Catch ex As Exception IsInitSuccess = False @@ -2914,6 +2950,7 @@ Retry: '输出日志 Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Text}{vbCrLf}" '减轻同步锁占用 + AppendText = FilterUserName(FilterAccessToken(AppendText, "*"), "*") If ModeDebug Then SyncLock LogListLock LogList.Append(AppendText) @@ -2933,16 +2970,16 @@ Retry: Select Case Level #If DEBUG Then Case LogLevel.Developer - Hint("[开发者模式] " & Text, HintType.Info, False) + Hint("[开发者模式] " & Text, HintType.Blue, False) Case LogLevel.Debug - Hint("[调试模式] " & Text, HintType.Info, False) + Hint("[调试模式] " & Text, HintType.Blue, False) #Else Case LogLevel.Developer Case LogLevel.Debug - If ModeDebug Then Hint("[调试模式] " & Text, HintType.Info, False) + If ModeDebug Then Hint("[调试模式] " & Text, HintType.Blue, False) #End If Case LogLevel.Hint - Hint(Text, HintType.Critical, False) + Hint(Text, HintType.Red, False) Case LogLevel.Msgbox MyMsgBox(Text, Title, IsWarn:=True) Case LogLevel.Feedback @@ -2981,10 +3018,11 @@ Retry: If TypeOf Ex Is ThreadInterruptedException Then Return '获取错误信息 - Dim ExFull As String = Desc & "：" & GetExceptionDetail(Ex) + Dim ExFull As String = $"{Desc}：{Ex.GetDetail()}" '输出日志 - Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}：{GetExceptionDetail(Ex, True)}{vbCrLf}" '减轻同步锁占用 + Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}：{Ex.GetDetail(True)}{vbCrLf}" '减轻同步锁占用 + AppendText = FilterUserName(FilterAccessToken(AppendText, "*"), "*") If ModeDebug Then SyncLock LogListLock LogList.Append(AppendText) @@ -3002,20 +3040,20 @@ Retry: Case LogLevel.Normal #If DEBUG Then Case LogLevel.Developer - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint("[开发者模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint("[开发者模式] " & ExLine, HintType.Blue, False) Case LogLevel.Debug - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint("[调试模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint("[调试模式] " & ExLine, HintType.Blue, False) #Else Case LogLevel.Developer Case LogLevel.Debug - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Blue, False) #End If Case LogLevel.Hint - Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex) - Hint(ExLine, HintType.Critical, False) + Dim ExLine As String = Desc & "：" & Ex.GetBrief() + Hint(ExLine, HintType.Red, False) Case LogLevel.Msgbox MyMsgBox(ExFull, Title, IsWarn:=True) Case LogLevel.Feedback @@ -3084,6 +3122,7 @@ Retry: Public Sub Telemetry([Event] As String, ParamArray Datas As String()) If Not Setup.Get("SystemSystemTelemetry") Then Return '用户关闭了遥测 If Not ClsBaseUrl.StartsWithF("http") Then Return '开源版没有设置遥测地址 + If VersionBranchName = "Debug" Then Return '开发版本不上传遥测 RunInNewThread( Sub() Try @@ -3093,8 +3132,8 @@ Retry: Url &= "&" & WebUtility.UrlEncode(Datas(i)) & "=" & WebUtility.UrlEncode(Datas(i + 1).Replace(vbCrLf, vbLf)) Next NetRequestByClient(Url, MakeLog:=False) - Catch - Log("[System] 匿名数据上报失败", LogLevel.Debug) + Catch ex As Exception + Log(ex, "匿名数据上报失败") End Try End Sub, "Telemetry", ThreadPriority.Lowest) End Sub @@ -3121,7 +3160,7 @@ Retry: End Function ''' - ''' 取随机整数。 + ''' 取随机整数（包含）。 ''' Public Function RandomInteger(min As Integer, max As Integer) As Integer Return Math.Floor((max - min + 1) * Random.NextDouble) + min @@ -3130,12 +3169,12 @@ Retry: ''' ''' 将数组随机打乱。 ''' - Public Function Shuffle(Of T)(array As IList(Of T)) As IList(Of T) - Shuffle = New List(Of T) - Do While array.Any - Dim i As Integer = RandomInteger(0, array.Count - 1) - Shuffle.Add(array(i)) - array.RemoveAt(i) + Public Iterator Function Shuffle(Of T)(Raw As IEnumerable(Of T)) As IEnumerable(Of T) + Dim RawCopy As New List(Of T)(Raw) + Do While RawCopy.Any + Dim i As Integer = RandomInteger(0, RawCopy.Count - 1) + Yield RawCopy(i) + RawCopy.RemoveAt(i) Loop End Function diff --git a/Plain Craft Launcher 2/Modules/Base/ModLoader.vb b/Plain Craft Launcher 2/Modules/Base/ModLoader.vb index 4719587..75b8b4f 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModLoader.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModLoader.vb @@ -8,6 +8,7 @@ Implements ILoadingTrigger Public ReadOnly Property IsLoader As Boolean = True Implements ILoadingTrigger.IsLoader + Protected Shared LogBlackList As String() = {"EasyTier CLI"} '基础属性 ''' @@ -89,7 +90,7 @@ Dim OldState = _State If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) _State = value - Log("[Loader] 加载器 " & Name & " 状态改变：" & GetStringFromEnum(value)) + If Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载器 {Name} 状态改变：{GetStringFromEnum(value)}") '实现 ILoadingTrigger 接口与 OnStateChanged 回调 RunInUi( Sub() @@ -170,6 +171,7 @@ '状态变化 Public MustOverride Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False) Public MustOverride Sub Abort() + Public MustOverride Sub Failed(Ex As Exception) '等待结束 Public Const WaitForExitTimeoutMessage As String = "等待加载器执行超时。" @@ -290,11 +292,13 @@ '检验输入以确定情况 If IsForceRestart Then Return True '强制要求重启 If ((Input Is Nothing) <> (Me.Input Is Nothing)) OrElse (Input IsNot Nothing AndAlso Not Input.Equals(Me.Input)) Then Return True '输入不同 - If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束 - (IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时 - Return False '则不重试 + + If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束… + (IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse + LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '…且没有超时… + Return False '…则不重试 Else - Return True '需要开始 + Return True '否则需要重启 End If End Function Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False) @@ -315,13 +319,13 @@ Sub() Try IsForceRestarting = IsForceRestart - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动") + If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动") LoadDelegate(Me) If IsAborted Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer) Return End If - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成") + If ModeDebug AndAlso Not LogBlackList.Contains(Name) Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成") RaisePreviewFinish() State = LoadState.Finished LastFinishedTime = GetTimeTick() '未中断，本次输出有效 @@ -334,25 +338,38 @@ '如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted If Not IsAborted Then State = LoadState.Aborted Catch ex As Exception - If IsAborted Then Return - Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer) - [Error] = ex - State = LoadState.Failed + Failed(ex) End Try End Sub) With {.Name = "L/" & Name, .Priority = ThreadPriority} - LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted + Try + LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted + Catch ex As ThreadStateException '若遇到偶发的 “线程正在运行或被终止”，则等待后重试 + Thread.Sleep(500) + LastRunningThread.Start() + End Try + End Sub + Public Overrides Sub Failed(ex As Exception) + [Error] = ex + SyncLock LockState + If IsAborted OrElse State >= LoadState.Finished Then Return + State = LoadState.Failed + End SyncLock + Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer) + TriggerThreadAbort() End Sub Public Overrides Sub Abort() - If State <> LoadState.Loading Then Return SyncLock LockState + If State <> LoadState.Loading Then Return State = LoadState.Aborted End SyncLock TriggerThreadAbort() End Sub Private Sub TriggerThreadAbort() If LastRunningThread Is Nothing Then Return - If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断") - If LastRunningThread.IsAlive Then LastRunningThread.Interrupt() + If LastRunningThread.IsAlive Then + LastRunningThread.Interrupt() + If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断") + End If LastRunningThread = Nothing End Sub @@ -451,6 +468,17 @@ Next End Sub) End Sub + Public Overrides Sub Failed(Ex As Exception) + [Error] = Ex '先设置错误再调整状态，防止父加载器获取不到异常 + SyncLock LockState + If State >= LoadState.Finished Then Return + State = LoadState.Failed + End SyncLock + For Each Loader In Loaders + Loader.Abort() + Next + FrmMain.BtnExtraDownload.ShowRefresh() + End Sub ''' ''' 子任务状态变更。 @@ -468,18 +496,9 @@ Case LoadState.Aborted '被中断，这个任务也中断 Abort() - Case Else + Case LoadState.Failed '完蛋，出错了 - SyncLock LockState - If State >= LoadState.Finished Then Return - [Error] = New Exception(Loader.Name & "失败", Loader.Error) - State = Loader.State - End SyncLock - For Each Loader In Loaders - Loader.Abort() - Next - FrmMain.BtnExtraDownload.ShowRefresh() - Return + Failed(New Exception(Loader.Name & "失败", Loader.Error)) End Select End Sub ''' diff --git a/Plain Craft Launcher 2/Modules/Base/ModNet.vb b/Plain Craft Launcher 2/Modules/Base/ModNet.vb index 6539356..401e8fa 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModNet.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModNet.vb @@ -1,6 +1,7 @@ Imports System.Net.Http.Headers +Imports System.Net.Sockets +Imports System.Runtime.CompilerServices Imports System.Threading.Tasks -Imports CacheCow.Client Public Module ModNet @@ -11,15 +12,28 @@ Public Module ModNet ''' Public Function NetRequestByClient(Url As String, Optional Method As HttpMethod = Nothing, Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", - Optional Timeout As Integer = 25000, Optional Headers As String(,) = Nothing, - Optional Encoding As Encoding = Nothing, Optional UseBrowserUserAgent As Boolean = False, Optional MakeLog As Boolean = True) As String + Optional Timeout As Integer = 25000, Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False, Optional MakeLog As Boolean = True) As String If Method Is Nothing Then Method = HttpMethod.Get If MakeLog Then Log("[Net] 发起网络请求（" & Method.Method & "，" & Url & "），最大超时 " & Timeout) Try Dim HeaderDictionary = If(Headers, {}).ToDictionary If ContentType IsNot Nothing Then HeaderDictionary("Content-Type") = ContentType If Accept IsNot Nothing Then HeaderDictionary("Accept") = Accept - Return If(Encoding, Encoding.UTF8).GetString(SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, UseBrowserUserAgent:=UseBrowserUserAgent)) + Dim Result = If(Encoding, Encoding.UTF8).GetString(SendRequest(Url, Method, Content, HeaderDictionary, Timeout:=Timeout, Encoding:=Encoding, SimulateBrowserHeaders:=SimulateBrowserHeaders)) + '检查结果是否为完整 JSON（在 #6683 中可能返回空，在被 GFW 截断时可能不完整） + '在此处检查并报错，可以让 NetRequestByClientRetry 等方法进行重试 + If RequireJson Then + Result = Result.Trim((vbCrLf & " ").ToCharArray) 'Authlib-Injector 的结果会在末尾附带一个空行 + If Not (Result.StartsWithF("{") AndAlso Result.EndsWithF("}")) AndAlso + Not (Result.StartsWithF("[") AndAlso Result.EndsWithF("]")) Then + Throw New FormatException("返回结果并非 JSON 格式：" & + If(Result.Length > 2000, Result.Substring(0, 1000) & "..." & Result.Substring(Result.Length - 1000), Result)) + End If + End If + Return Result + Catch ex As FormatException + Throw Catch ex As ThreadInterruptedException Throw Catch ex As Exception @@ -34,8 +48,8 @@ Public Module ModNet ''' 如果第一次尝试失败，换用的备用 URL。 Public Function NetRequestByClientRetry(Url As String, Optional Method As HttpMethod = Nothing, Optional BackupUrl As String = Nothing, Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", - Optional Headers As String(,) = Nothing, - Optional Encoding As Encoding = Nothing, Optional UseBrowserUserAgent As Boolean = False) As String + Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False) As String Dim RetryCount As Integer = 0 Dim RetryException As Exception = Nothing Dim StartTime As Long = GetTimeTick() @@ -43,15 +57,15 @@ Public Module ModNet Retry: Select Case RetryCount Case 0 '正常尝试 - Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 10000, Headers, Encoding, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 10000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Case 1 '慢速重试 Thread.Sleep(500) - Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 30000, Headers, Encoding, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 30000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Case Else '快速重试 If GetTimeTick() - StartTime > 5500 Then '若前两次加载耗费 5 秒以上，才进行重试 Thread.Sleep(500) - Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 4000, Headers, Encoding, UseBrowserUserAgent) + Return NetRequestByClient(Url, Method, Content, ContentType, Accept, 4000, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Else Throw RetryException End If @@ -59,6 +73,11 @@ Retry: Catch ex As ThreadInterruptedException Throw Catch ex As Exception + If TypeOf ex Is ResponsedWebException Then + If CType(ex, ResponsedWebException).StatusCode = HttpStatusCode.Forbidden Then Throw + If CType(ex, ResponsedWebException).StatusCode = 429 Then Thread.Sleep(10000) 'Too Many Requests + End If + '重试 Select Case RetryCount Case 0 RetryException = ex @@ -78,8 +97,8 @@ Retry: ''' Public Function NetRequestByClientMultiple(Url As String, Optional Method As HttpMethod = Nothing, Optional ThreadCount As Integer = 3, Optional Content As Object = Nothing, Optional ContentType As String = Nothing, Optional Accept As String = "*/*", - Optional Headers As String(,) = Nothing, Optional Timeout As Integer = 25000, - Optional Encoding As Encoding = Nothing, Optional UseBrowserUserAgent As Boolean = False) As String + Optional Headers As String(,) = Nothing, Optional RequireJson As Boolean = False, Optional Timeout As Integer = 25000, + Optional Encoding As Encoding = Nothing, Optional SimulateBrowserHeaders As Boolean = False) As String Dim Threads As New List(Of Thread) Dim RequestResult = Nothing Dim RequestEx As Exception = Nothing @@ -88,7 +107,7 @@ Retry: Dim th As New Thread( Sub() Try - RequestResult = NetRequestByClient(Url, Method, Content, ContentType, Accept, Timeout, Headers, Encoding, UseBrowserUserAgent) + RequestResult = NetRequestByClient(Url, Method, Content, ContentType, Accept, Timeout, Headers, RequireJson, Encoding, SimulateBrowserHeaders) Catch ex As Exception FailCount += 1 RequestEx = ex @@ -127,16 +146,16 @@ RequestFinished: ''' 以多线程下载网页文件的方式获取内容。 ''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。 ''' - Public Function NetRequestByLoader(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String - Return NetRequestByLoader({Url}, Timeout, IsJson, UseBrowserUserAgent) + Public Function NetRequestByLoader(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional SimulateBrowserHeaders As Boolean = False) As String + Return NetRequestByLoader({Url}, Timeout, IsJson, SimulateBrowserHeaders) End Function ''' ''' 以多线程下载网页文件的方式获取内容。 ''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。 ''' - Public Function NetRequestByLoader(Urls As IEnumerable(Of String), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String + Public Function NetRequestByLoader(Urls As IEnumerable(Of String), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional SimulateBrowserHeaders As Boolean = False) As String Dim Temp As String = RequestTaskTempFolder() & "download.txt" - Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, UseBrowserUserAgent)}) + Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, SimulateBrowserHeaders)}) Try NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时（第一下载源：" & Urls.First & "）") NetRequestByLoader = ReadFile(Temp) @@ -154,7 +173,7 @@ RequestFinished: ''' 通过网络请求直接下载小文件，若文件已存在将被覆盖。 ''' 不建议用于下载大文件。 ''' - Public Sub NetDownloadByClient(Url As String, LocalPath As String) + Public Sub NetDownloadByClient(Url As String, LocalPath As String, Optional SimulateBrowserHeaders As Boolean = False) Log($"[Net] 通过网络请求直接下载小文件：{Url} → {LocalPath}") '初始化文件路径 Try @@ -165,7 +184,7 @@ RequestFinished: End Try '下载 Try - File.WriteAllBytes(LocalPath, SendRequest(Url, HttpMethod.Get)) + File.WriteAllBytes(LocalPath, SendRequest(Url, HttpMethod.Get, SimulateBrowserHeaders:=SimulateBrowserHeaders)) Catch ex As Exception File.Delete(LocalPath) Throw New WebException($"通过网络请求直接下载小文件失败（{LocalPath}）", ex) @@ -175,16 +194,16 @@ RequestFinished: ''' ''' 通过多线程下载引擎下载文件。 ''' - Public Sub NetDownloadByLoader(Url As String, LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) - NetDownloadByLoader({Url}, LocalPath, LoaderToSyncProgress, Check, UseBrowserUserAgent) + Public Sub NetDownloadByLoader(Url As String, LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) + NetDownloadByLoader({Url}, LocalPath, LoaderToSyncProgress, Check, SimulateBrowserHeaders) End Sub ''' ''' 通过多线程下载引擎下载文件。 ''' ''' 文件的 Url 列表。 ''' 下载的本地地址。 - Public Sub NetDownloadByLoader(Urls As IEnumerable(Of String), LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) - Dim NewTask As New LoaderDownload($"文件下载 {GetUuid()}#", New List(Of NetFile) From {New NetFile(Urls, LocalPath, Check, UseBrowserUserAgent)}) + Public Sub NetDownloadByLoader(Urls As IEnumerable(Of String), LocalPath As String, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional Check As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) + Dim NewTask As New LoaderDownload($"文件下载 {GetUuid()}#", New List(Of NetFile) From {New NetFile(Urls, LocalPath, Check, SimulateBrowserHeaders)}) Try NewTask.WaitForExit(LoaderToSyncProgress:=LoaderToSyncProgress) Catch ex As Exception @@ -201,74 +220,164 @@ RequestFinished: '基础请求函数 Private Function SendRequest(Url As String, Method As HttpMethod, Optional Content As Object = Nothing, Optional Headers As Dictionary(Of String, String) = Nothing, - Optional UseBrowserUserAgent As Boolean = False, Optional Timeout As Integer = 25000, Optional Encoding As Encoding = Nothing) As Byte() + Optional SimulateBrowserHeaders As Boolean = False, Optional Timeout As Integer = 25000, Optional Encoding As Encoding = Nothing) As Byte() If RunInUi() AndAlso Not Url.Contains("//127.") Then Throw New Exception("在 UI 线程执行了网络请求") - Dim Request As HttpRequestMessage = Nothing, CancelToken As CancellationTokenSource = Nothing, Response As HttpResponseMessage = Nothing + Dim Request As HttpRequestMessage = Nothing, CancelToken As CancellationTokenSource = Nothing, + Response As HttpResponseMessage = Nothing, HostIp As String = Nothing Try - Static Client As HttpClient = ClientExtensions.CreateClient(New FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With { - .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None, - .UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies - }) Url = SecretCdnSign(Url) Request = New HttpRequestMessage(Method, Url) '写入 Content If Content IsNot Nothing AndAlso Request.Method <> HttpMethod.Get AndAlso Request.Method <> HttpMethod.Head Then - Dim Bytes As Byte() = If(TypeOf Content Is Byte(), Content, If(Encoding, Encoding.UTF8).GetBytes(Content.ToString)) - Request.Content = New ByteArrayContent(Bytes) - Request.Content.Headers.ContentLength = Bytes.Length + If TypeOf Content Is HttpContent Then + Request.Content = DirectCast(Content, HttpContent) + ElseIf TypeOf Content Is Byte() Then + Request.Content = New ByteArrayContent(DirectCast(Content, Byte())) + ElseIf Content IsNot Nothing Then + Request.Content = New ByteArrayContent(If(Encoding, Encoding.UTF8).GetBytes(Content.ToString())) + End If End If '写入 Headers - If Headers IsNot Nothing Then - For Each Header In Headers - If Header.Key.ToLower = "content-type" Then - Request.Content?.Headers.TryAddWithoutValidation(Header.Key, Header.Value) - Else - Request.Headers.Add(Header.Key, Header.Value) - End If - Next - End If - SecretHeadersSign(Url, Request, UseBrowserUserAgent) - '发送请求 + For Each Header In If(Headers, New Dictionary(Of String, String)) + If Header.Key.ToLower = "content-type" Then + Request.Content?.Headers.TryAddWithoutValidation(Header.Key, Header.Value) + Else + Request.Headers.Add(Header.Key, Header.Value) + End If + Next + SecretHeadersSign(Url, Request, SimulateBrowserHeaders) + 'DNS 解析 CancelToken = New CancellationTokenSource(Timeout) - Response = Client.SendAsync(Request, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult() + HostIp = DNSLookup(Request, CancelToken) + If HostIp IsNot Nothing AndAlso Not IPReliability.ContainsKey(HostIp) Then + IPReliability(HostIp) = -0.01 '预先降低一点，这样快速的重复请求会使用不同的 IP 以提高成功率 + End If + '发送请求 + SyncLock RequestClientLock + '延迟初始化，以避免在程序启动前加载 CacheCow 导致 DLL 加载失败 + If RequestClient Is Nothing Then + RequestClient = CacheCow.Client.ClientExtensions.CreateClient(New CacheCow.Client.FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With { + .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None, + .UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies + }) + End If + End SyncLock + Response = RequestClient.SendAsync(Request, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) Dim ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult() Dim ResponseBytes As Byte() Using Stream As New MemoryStream - ResponseStream.CopyToAsync(Stream, 81920, CancelToken.Token).GetAwaiter().GetResult() + ResponseStream.CopyToAsync(Stream, 81920, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) ResponseBytes = Stream.ToArray() End Using '输出 If Response.IsSuccessStatusCode Then + RecordIPReliability(HostIp, 0.5) Return ResponseBytes Else + RecordIPReliability(HostIp, -0.7) Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes) Throw New ResponsedWebException( - $"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}" & - If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), ResponseMessage) + $"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Method}，{Url}，{HostIp}" & + If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), Response.StatusCode, ResponseMessage) End If Catch ex As ThreadInterruptedException Throw Catch ex As ResponsedWebException Throw - Catch ex As TaskCanceledException 'CancellationTokenSource 超时 - Throw New WebException($"连接服务器超时，请检查你的网络环境是否良好（{Method}, {Url}）", WebExceptionStatus.Timeout) Catch ex As Exception - Throw New Exception($"网络请求出现意外异常（{Method}, {Url}）", ex) + RecordIPReliability(HostIp, -1) + If TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException Then 'CancellationToken 超时 + Throw New WebException($"连接服务器超时，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout) + ElseIf ex.IsNetworkRelated Then + Throw New WebException($"网络请求失败，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}，IP：{HostIp}）", WebExceptionStatus.Timeout) + Else + Throw New Exception($"网络请求出现意外异常（{Method}, {Url}，{HostIp}）", ex) + End If Finally Request?.Dispose() CancelToken?.Dispose() Response?.Dispose() End Try End Function + Private RequestClient As HttpClient = Nothing + Private RequestClientLock As New Object + ''' + ''' 进行 DNS 解析。它仅在选择的 IP 与系统默认的不一致时才对 URL 中的 Host 进行替换。 + ''' 返回请求时应使用的 IP；若为 IPv6，则加上了方括号。 + ''' 若解析失败，则返回 Nothing。 + ''' + Private Function DNSLookup(Request As HttpRequestMessage, CancelToken As CancellationTokenSource) As String + Dim GetIPReliability = Function(Key) IPReliability.GetOrDefault(Key.ToString, 0) + '初步 DNS 解析 + Dim Host = Request.RequestUri.Host + Dim DnsTask As Task(Of IPAddress()) = Nothing + Try + DnsTask = Dns.GetHostAddressesAsync(Host) + DnsTask.Wait(CancelToken.Token) + Catch ex As Exception + Log(ex, $"DNS 解析失败（{Host}）") + Return Nothing + End Try + Dim Candidates As IPAddress() = DnsTask.Result.ToArray + If Not Candidates.Any Then + Log($"[Net] DNS 解析无结果（{Host}）") + Return Nothing + End If + '若同时存在 IPv4 和 IPv6 地址，仅选择其中一类（因为 GFW 可能只屏蔽了 IPv4 或 IPv6） + Dim IPv4Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetwork).ToArray + Dim IPv6Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetworkV6).ToArray + If IPv4Targets.Any AndAlso IPv6Targets.Any Then + Dim IPv4Reliability = IPv4Targets.Average(Function(i) GetIPReliability(i)) + Dim IPv6Reliability = IPv6Targets.Average(Function(i) GetIPReliability(i)) + If Host = "api.modrinth.com" Then IPv6Reliability -= 0.1 '让 Modrinth 优先使用 IPv4 地址（#6887） + Candidates = If(IPv4Reliability >= IPv6Reliability, IPv4Targets, IPv6Targets) + End If + '选择可靠度最高的 IP + Dim MaxReliability As Double = Candidates.Max(Function(i) GetIPReliability(i)) + Dim Target As IPAddress = Candidates.First(Function(i) GetIPReliability(i) = MaxReliability) + Dim TargetIp As String = If(Target.AddressFamily = AddressFamily.InterNetworkV6, $"[{Target}]", Target.ToString) + If Target IsNot Candidates.First Then + '优选结果与系统默认 IP 不一致，替换域名并设置 Host 头 + If ModeDebug Then Log($"[Net] DNS 解析结果：{Host} → {Target}，所有可能的 IP 与可靠度：{DnsTask.Result.Select(Function(i) $"{i} → {GetIPReliability(i):0.000}").Join("；")}") + Request.Headers.Host = Host + Dim Builder As New UriBuilder(Request.RequestUri) + Builder.Host = TargetIp + Request.RequestUri = Builder.Uri + End If + Return TargetIp + End Function + ''' + ''' 记录每个 IP 地址的请求可靠度。 + ''' 通常取值 -1 ~ +0.5，越高越好。未尝试过的 IP 应视为 0。 + ''' + Private IPReliability As New SafeDictionary(Of String, Double) + ''' + ''' 根据请求结果，记录 IP 地址的可靠度。 + ''' + Private Sub RecordIPReliability(IP As String, Result As Double) + If IP Is Nothing Then Return + If Not IPReliability.ContainsKey(IP) Then IPReliability(IP) = 0 + IPReliability(IP) = (IPReliability(IP) + Result) / 2 + End Sub + + ''' + ''' 当 HTTP 状态码不指示成功时引发的异常。 + ''' 附带额外属性，可用于获取远程服务器给予的回复以及 HTTP 状态码。 + ''' Public Class ResponsedWebException Inherits WebException ''' + ''' HTTP 状态码。 + ''' + Public StatusCode As HttpStatusCode + ''' ''' 远程服务器给予的回复。 ''' Public Overloads Property Response As String - Public Sub New(Message As String, Response As String) + Public Sub New(Message As String, StatusCode As HttpStatusCode, Response As String) MyBase.New(Message) + Me.StatusCode = StatusCode Me.Response = Response End Sub End Class @@ -277,6 +386,10 @@ RequestFinished: #Region "多线程下载引擎" + Private ThreadClient As New HttpClient(New HttpClientHandler With { + .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None + }) + ''' ''' 最大线程数。 ''' @@ -581,12 +694,12 @@ RequestFinished: End SyncLock End Function ''' - ''' 是否已经没有可用源了。 + ''' 是否存在可用源。 ''' Public Function HasAvailableSource(Optional AllowOnceSource As Boolean = True) As Boolean SyncLock LockSource - If AllowOnceSource AndAlso SourcesOnce.Any Then Return True - If Sources.Any(Function(s) Not s.IsFailed) Then Return True + If Sources.Any(Function(s) Not s.IsFailed) Then Return True '存在多线程可用源 + If AllowOnceSource AndAlso SourcesOnce.Any Then Return True '存在单线程可用源 End SyncLock Return False End Function @@ -646,9 +759,9 @@ RequestFinished: ''' Public Check As FileChecker ''' - ''' 下载时是否添加浏览器 UA。 + ''' 是否模拟浏览器的 UserAgent 和 Referer。 ''' - Public UseBrowserUserAgent As Boolean + Public SimulateBrowserHeaders As Boolean ''' ''' 上次记速时的时间。 @@ -746,7 +859,7 @@ RequestFinished: ''' 新建一个需要下载的文件。 ''' ''' 包含文件名的本地地址。 - Public Sub New(Urls As IEnumerable(Of String), LocalPath As String, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False) + Public Sub New(Urls As IEnumerable(Of String), LocalPath As String, Optional Check As FileChecker = Nothing, Optional SimulateBrowserHeaders As Boolean = False) Dim Sources As New List(Of NetSource) Dim Count As Integer = 0 Urls = Urls.Distinct.ToArray @@ -757,7 +870,7 @@ RequestFinished: Me.Sources = Sources Me.LocalPath = LocalPath Me.Check = Check - Me.UseBrowserUserAgent = UseBrowserUserAgent + Me.SimulateBrowserHeaders = SimulateBrowserHeaders Me.LocalName = GetFileNameFromPath(LocalPath) End Sub @@ -768,17 +881,17 @@ RequestFinished: Public Function TryBeginThread() As NetThread Try - '条件检测 - If NetTaskThreadCount >= NetTaskThreadLimit OrElse Not HasAvailableSource() OrElse - (IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Error) Then Return Nothing - If State >= NetState.Merge OrElse State = NetState.WaitForCheck Then Return Nothing - SyncLock LockState - If State < NetState.Connect Then State = NetState.Connect - End SyncLock - '初始化参数 Dim StartPosition As Long, StartSource As NetSource = Nothing Dim Th As Thread, ThreadInfo As NetThread - SyncLock LockChain + '条件检测 + SyncLock LockSource + If NetTaskThreadCount >= NetTaskThreadLimit OrElse Not HasAvailableSource() OrElse + (IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads.State <> NetState.Error) Then Return Nothing + If State >= NetState.Merge OrElse State = NetState.WaitForCheck Then Return Nothing + SyncLock LockState + If State < NetState.Connect Then State = NetState.Connect + End SyncLock + '初始化参数 '获取线程起点与下载源 '不分割 If IsNoSplit Then GoTo StartSingleThreadDownload @@ -789,6 +902,8 @@ StartSingleThreadDownload: Reset() State = NetState.Get End If + End SyncLock + SyncLock LockChain '首个开始点 If Threads Is Nothing Then StartPosition = 0 @@ -805,7 +920,9 @@ StartSingleThreadDownload: End If Next '是否禁用多线程，以及规定碎片大小 - Dim TargetUrl As String = GetSource().Url + Dim Source As NetSource = GetSource() + If Source Is Nothing Then Return Nothing + Dim TargetUrl As String = Source.Url If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("bmclapi") OrElse TargetUrl.Contains("github.com") OrElse TargetUrl.Contains("optifine.net") OrElse TargetUrl.Contains("modrinth") OrElse TargetUrl.Contains("momot.rs") Then Return Nothing '寻找最大碎片 @@ -850,7 +967,7 @@ StartThread: Return ThreadInfo Catch ex As Exception - Log(ex, "尝试开始下载线程失败（" & If(LocalName, "Nothing") & "）", LogLevel.Hint) + Fail(New Exception($"尝试开始下载线程失败（{LocalName}）", ex)) Return Nothing End Try End Function @@ -859,7 +976,9 @@ StartThread: ''' Private Sub Thread(Th As NetThread) If ModeDebug OrElse Th.DownloadStart = 0 Then Log($"[Download] {LocalName}：开始，起始点 {Th.DownloadStart}，{Th.Source.Url}") - Dim ResultStream As Stream = Nothing + Dim ResultStream As Stream = Nothing, HttpRequest As HttpRequestMessage = Nothing, + Response As HttpResponseMessage = Nothing, ResponseStream As Stream = Nothing, + CancelToken As CancellationTokenSource = Nothing, HostIp As String = Nothing '部分下载源真的特别慢，并且只需要一个请求，例如 Ping 为 20s，如果增长太慢，就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟 '延迟过长会导致某些特别慢的链接迟迟不被掐死 Dim Timeout As Integer = Math.Min(Math.Max(ConnectAverage, 6000) * (1 + Th.Source.FailCount), 30000) @@ -867,145 +986,135 @@ StartThread: Try Dim HttpDataCount As Integer = 0 If SourcesOnce.Contains(Th.Source) AndAlso Th <> Th.Source.SingleThread Then GoTo SourceBreak - Dim HttpRequest As New HttpRequestMessage(HttpMethod.Get, Th.Source.Url) - SecretHeadersSign(Th.Source.Url, HttpRequest, UseBrowserUserAgent) + HttpRequest = New HttpRequestMessage(HttpMethod.Get, Th.Source.Url) + SecretHeadersSign(Th.Source.Url, HttpRequest, SimulateBrowserHeaders) + CancelToken = New CancellationTokenSource(Timeout) + HostIp = DNSLookup(HttpRequest, CancelToken) 'DNS 预解析 If Not Th.IsFirstThread Then HttpRequest.Headers.Range = New RangeHeaderValue(Th.DownloadStart, Nothing) Dim ContentLength As Long = 0 - Using CancelToken As New CancellationTokenSource(Timeout) - Static Client As New HttpClient(New HttpClientHandler With { - .AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None - }) - Using Response As HttpResponseMessage = Client.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult() - If Not Response.IsSuccessStatusCode Then Throw New Exception($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Th.Source.Url}") '状态码检查 - If State = NetState.Error Then GoTo SourceBreak '快速中断 - If ModeDebug AndAlso Response.RequestMessage.RequestUri.ToString <> Th.Source.Url Then Log($"[Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri}") - '文件大小校验 - ContentLength = Response.Content.Headers.ContentLength.GetValueOrDefault(-1) - If ContentLength = -1 Then - If FileSize > 1 Then - If Th.DownloadStart = 0 Then - Log($"[Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理") - Else - Log($"[Download] {LocalName}：ContentLength 返回了 -1，无法确定是否支持分段下载，视作不支持") - GoTo NotSupportRange - End If - Else - FileSize = -1 : IsUnknownSize = True - Log($"[Download] {LocalName}：文件大小未知") - End If - ElseIf ContentLength < 0 Then - Throw New Exception("获取片大小失败，结果为 " & ContentLength & "。") - ElseIf Th.IsFirstThread Then - If Check IsNot Nothing Then - If ContentLength < Check.MinSize AndAlso Check.MinSize > 0 Then - Throw New Exception($"文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。") - End If - If ContentLength <> Check.ActualSize AndAlso Check.ActualSize > 0 Then - Throw New Exception($"文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。") - End If - End If - FileSize = ContentLength : IsUnknownSize = False - Log($"[Download] {LocalName}：文件大小 {ContentLength}（{GetString(ContentLength)}）") - '若文件大小大于 50 M，进行剩余磁盘空间校验 - If ContentLength > 50 * 1024 * 1024 Then - For Each Drive As DriveInfo In DriveInfo.GetDrives - Dim DriveName As String = Drive.Name.First.ToString - Dim RequiredSpace = If(PathTemp.StartsWithF(DriveName), ContentLength * 1.1, 0) + - If(LocalPath.StartsWithF(DriveName), ContentLength + 5 * 1024 * 1024, 0) - If Drive.TotalFreeSpace < RequiredSpace Then - Throw New Exception(DriveName & " 盘空间不足，无法进行下载。" & vbCrLf & "需要至少 " & GetString(RequiredSpace) & " 空间，但当前仅剩余 " & GetString(Drive.TotalFreeSpace) & "。" & - If(PathTemp.StartsWithF(DriveName), vbCrLf & vbCrLf & "下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。", "")) - End If - Next - End If - ElseIf FileSize < 0 Then - Throw New Exception("非首线程运行时，尚未获取文件大小") - ElseIf Th.DownloadStart > 0 AndAlso ContentLength = FileSize Then -NotSupportRange: - SyncLock LockSource - If SourcesOnce.Contains(Th.Source) Then - GoTo SourceBreak - Else - SourcesOnce.Add(Th.Source) - End If - End SyncLock - Throw New WebException($"该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") - ElseIf Not FileSize - Th.DownloadStart = ContentLength Then - Throw New WebException($"获取到的分段大小不一致：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") - End If - 'Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，ContentLength {ContentLength}") - Th.State = NetState.Get - SyncLock LockState - If State < NetState.Get Then State = NetState.Get - End SyncLock - '创建缓存文件 - If IsNoSplit Then - Th.Temp = Nothing - Cache = New MemoryStream - ResultStream = Cache + Response = ThreadClient.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + If Not Response.IsSuccessStatusCode Then Throw New Exception($"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})，{Th.Source.Url}") '状态码检查 + If State = NetState.Error Then GoTo SourceBreak '快速中断 + If ModeDebug AndAlso Response.RequestMessage.RequestUri.ToString <> Th.Source.Url Then Log($"[Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri}") + '文件大小校验 + ContentLength = Response.Content.Headers.ContentLength.GetValueOrDefault(-1) + If ContentLength < 0 Then + If FileSize > 1 Then + If Th.DownloadStart = 0 Then + Log($"[Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理") Else - Th.Temp = $"{PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp" - ResultStream = New FileStream(Th.Temp, FileMode.Create, FileAccess.Write, FileShare.Read) + Log($"[Download] {LocalName}：ContentLength 返回了 {ContentLength}，无法确定是否支持分段下载，视作不支持") + GoTo NotSupportRange End If - '开始下载 - Using ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult() - If Setup.Get("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000)) - Dim ResponseBytes As Byte() = New Byte(16384) {} - HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetAwaiter().GetResult() - While (IsUnknownSize OrElse Th.DownloadUndone > 0) AndAlso '判断是否下载完成 - HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState.Merge AndAlso (Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th) - '限速 - While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0 - Threading.Thread.Sleep(16) - End While - Dim RealDataCount As Integer = If(IsUnknownSize, HttpDataCount, Math.Min(HttpDataCount, Th.DownloadUndone)) - SyncLock NetTaskSpeedLimitLeftLock - If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount - End SyncLock - Dim DeltaTime = GetTimeTick() - Th.LastReceiveTime - If DeltaTime > 1000000 Then DeltaTime = 1 '时间刻反转导致出现极大值 - If RealDataCount > 0 Then - '有数据 - If Th.DownloadDone = 0 Then - '第一次接受到数据 - Th.State = NetState.Download - SyncLock LockState - If State < NetState.Download Then State = NetState.Download - End SyncLock - SyncLock LockCount - ConnectCount += 1 - ConnectTime += GetTimeTick() - Th.InitTime - End SyncLock - End If - SyncLock LockCount - Th.Source.FailCount = 0 - For Each Task In Tasks - Task.FailCount = 0 - Next - End SyncLock - NetManager.DownloadDone += RealDataCount - SyncLock LockDone - DownloadDone += RealDataCount - End SyncLock - Th.DownloadDone += RealDataCount - ResultStream.Write(ResponseBytes, 0, RealDataCount) - '检查速度是否过慢 - If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 1.5s，且速度小于 1.5K/s - Th.Source.SingleThread Is Nothing Then '并非单线程下载 - Throw New TimeoutException("由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。") - End If - Th.LastReceiveTime = GetTimeTick() - '已完成 - If Th.DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While - ElseIf Th.LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then - '无数据，且已超时 - Throw New TimeoutException("操作超时，无数据。") - End If - HttpDataCount = ResponseStream.Read(ResponseBytes, 0, 16384) - End While - End Using - End Using - End Using + Else + FileSize = -1 : IsUnknownSize = True + Log($"[Download] {LocalName}：文件大小未知") + End If + ElseIf Th.IsFirstThread Then + If Check IsNot Nothing Then + If ContentLength < Check.MinSize AndAlso Check.MinSize > 0 Then + Throw New Exception($"文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。") + End If + If ContentLength <> Check.ActualSize AndAlso Check.ActualSize > 0 Then + Throw New Exception($"文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。") + End If + End If + FileSize = ContentLength : IsUnknownSize = False + Log($"[Download] {LocalName}：文件大小 {ContentLength}（{GetString(ContentLength)}）") + '若文件大小大于 50 M，进行剩余磁盘空间校验 + If ContentLength > 50 * 1024 * 1024 Then + For Each Drive As DriveInfo In DriveInfo.GetDrives + Dim DriveName As String = Drive.Name.First.ToString + Dim RequiredSpace = If(PathTemp.StartsWithF(DriveName), ContentLength * 1.1, 0) + + If(LocalPath.StartsWithF(DriveName), ContentLength + 5 * 1024 * 1024, 0) + If Drive.TotalFreeSpace < RequiredSpace Then + Throw New Exception(DriveName & " 盘空间不足，无法进行下载。" & vbCrLf & "需要至少 " & GetString(RequiredSpace) & " 空间，但当前仅剩余 " & GetString(Drive.TotalFreeSpace) & "。" & + If(PathTemp.StartsWithF(DriveName), vbCrLf & vbCrLf & "下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。", "")) + End If + Next + End If + ElseIf FileSize < 0 Then + Throw New Exception("非首线程运行时，尚未获取文件大小") + ElseIf Th.DownloadStart > 0 AndAlso ContentLength = FileSize Then +NotSupportRange: + SyncLock LockSource + If SourcesOnce.Contains(Th.Source) Then GoTo SourceBreak + End SyncLock + Throw New RangeNotSupportedException($"该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") + ElseIf Not FileSize - Th.DownloadStart = ContentLength Then + Throw New RangeNotSupportedException($"获取到的分段大小不一致：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}") + End If + 'Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，ContentLength {ContentLength}") + Th.State = NetState.Get + SyncLock LockState + If State < NetState.Get Then State = NetState.Get + End SyncLock + '创建缓存文件 + If IsNoSplit Then + Th.Temp = Nothing + Cache = New MemoryStream + ResultStream = Cache + Else + Directory.CreateDirectory(PathTemp & "Download") + Th.Temp = $"{PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp" + ResultStream = New FileStream(Th.Temp, FileMode.Create, FileAccess.Write, FileShare.Read) + End If + '开始下载 + ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult() + If Setup.Get("SystemDebugDelay") Then Threading.Thread.Sleep(RandomInteger(50, 3000)) + Dim ResponseBytes As Byte() = New Byte(16384) {} + HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + While (IsUnknownSize OrElse Th.DownloadUndone > 0) AndAlso '判断是否下载完成 + HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState.Merge AndAlso (Not Th.Source.IsFailed OrElse Th.Source.SingleThread = Th) + '限速 + While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0 + Threading.Thread.Sleep(16) + End While + Dim RealDataCount As Integer = If(IsUnknownSize, HttpDataCount, Math.Min(HttpDataCount, Th.DownloadUndone)) + SyncLock NetTaskSpeedLimitLeftLock + If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount + End SyncLock + Dim DeltaTime = GetTimeTick() - Th.LastReceiveTime + If DeltaTime > 1000000 Then DeltaTime = 1 '避免时间刻反转导致出现极大值 + If RealDataCount > 0 Then + '有数据 + If Th.DownloadDone = 0 Then + '第一次接受到数据 + Th.State = NetState.Download + SyncLock LockState + If State < NetState.Download Then State = NetState.Download + End SyncLock + SyncLock LockCount + ConnectCount += 1 + ConnectTime += GetTimeTick() - Th.InitTime + End SyncLock + End If + SyncLock LockCount + Th.Source.FailCount = 0 + For Each Task In Tasks + Task.FailCount = 0 + Next + End SyncLock + NetManager.DownloadDone += RealDataCount + SyncLock LockDone + DownloadDone += RealDataCount + End SyncLock + Th.DownloadDone += RealDataCount + ResultStream.Write(ResponseBytes, 0, RealDataCount) + '已完成 + If Th.DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While + '检查速度是否过慢 + If DeltaTime > 5000 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 5s，且速度小于 1K/s + Th.Source.SingleThread Is Nothing Then '且并非单线程下载 + Throw New TimeoutException("由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。") + End If + Th.LastReceiveTime = GetTimeTick() + ElseIf Th.LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then + '无数据，且已超时 + Throw New TimeoutException("操作超时，无数据。") + End If + HttpDataCount = ResponseStream.ReadAsync(ResponseBytes, 0, 16384, CancelToken.Token).GetResultWithTimeout(CancelToken, Timeout) + End While SourceBreak: If State = NetState.Error OrElse (Th.Source.IsFailed AndAlso Th.Source.SingleThread <> Th) OrElse (Th.DownloadUndone > 0 AndAlso Not IsUnknownSize) Then '被外部中断 @@ -1018,16 +1127,25 @@ SourceBreak: '本线程完成 Th.State = NetState.Finish If ModeDebug Then Log($"[Download] {LocalName}：完成，已下载 {Th.DownloadDone}（{Th.DownloadStart}~{Th.DownloadEnd}）") + RecordIPReliability(HostIp, 0.5) End If Catch ex As Exception - Log($"[Download] {LocalName}：出错，{If(TypeOf ex Is TaskCanceledException, $"已超时（{Timeout}ms）", GetExceptionDetail(ex))}") + Log($"[Download] {LocalName}：出错，{If(TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException, + $"已超时（{Timeout}ms）", ex.GetDetail())}，IP：{HostIp}") + RecordIPReliability(HostIp, -0.7) SourceFail(Th, ex, False) Finally + '释放资源 + HttpRequest?.Dispose() + Response?.Dispose() + ResponseStream?.Dispose() + CancelToken?.Dispose() + If Not IsNoSplit Then ResultStream?.Dispose() + '改变计数 SyncLock NetTaskThreadCountLock NetTaskThreadCount -= 1 End SyncLock '合并 - If Not IsNoSplit Then ResultStream?.Dispose() If ((FileSize >= 0 AndAlso DownloadDone >= FileSize) OrElse (FileSize = -1 AndAlso DownloadDone > 0)) AndAlso State < NetState.Merge AndAlso Th.State <> NetState.Error Then Merge(Th) End Try @@ -1043,10 +1161,11 @@ SourceBreak: Th.State = NetState.Error Th.Source.Ex = ex '根据情况判断，是否在多线程下禁用下载源（连续错误过多，或不支持断点续传） - If IsMergeFailure OrElse - ex.Message.Contains("该下载源不支持") OrElse ex.Message.Contains("未能解析") OrElse ex.Message.Contains("(404)") OrElse - ex.Message.Contains("(502)") OrElse ex.Message.Contains("无返回数据") OrElse ex.Message.Contains("空间不足") OrElse ex.Message.Contains("获取到的分段大小不一致") OrElse - (ex.Message.Contains("(403)") AndAlso Not Th.Source.Url.ContainsF("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403，所以不应因此禁用下载源 + Dim IsRangeNotSupported As Boolean = TypeOf ex Is RangeNotSupportedException OrElse ex.Message.Contains("(416)") + If IsMergeFailure OrElse IsRangeNotSupported OrElse + ex.Message.Contains("(502)") OrElse ex.Message.Contains("(404)") OrElse + ex.Message.Contains("未能解析") OrElse ex.Message.Contains("无返回数据") OrElse ex.Message.Contains("空间不足") OrElse + ((ex.Message.Contains("(403)") OrElse ex.Message.Contains("(429)")) AndAlso Not Th.Source.Url.ContainsF("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403/429，所以不应因此禁用下载源 (Th.Source.FailCount >= MathClamp(NetTaskThreadLimit, 5, 30) AndAlso DownloadDone < 1) OrElse Th.Source.FailCount > NetTaskThreadLimit + 2 Then '当一个下载源有多个线程在下载时，只选择其中一个线程进行后续处理 Dim IsThisFail As Boolean = False @@ -1058,9 +1177,9 @@ SourceBreak: End SyncLock '……后续处理 If IsThisFail Then - Log($"[Download] {LocalName}：下载源被禁用（{Th.Source.Id}）：{Th.Source.Url}") + Log($"[Download] {LocalName}：下载源被禁用（{Th.Source.Id}，Range 问题：{IsRangeNotSupported}）：{Th.Source.Url}") Log(ex, $"{If(SourcesOnce.FirstOrDefault?.SingleThread Is Nothing, "", "单线程")}下载源 {Th.Source.Id} 已被禁用", - If(ex.Message.Contains("不支持分段下载") OrElse ex.Message.Contains("(404)") OrElse ex.Message.Contains("(416)"), LogLevel.Developer, LogLevel.Debug)) + If(IsRangeNotSupported OrElse ex.Message.Contains("(404)"), LogLevel.Developer, LogLevel.Debug)) SyncLock LockSource SourcesOnce.Remove(Th.Source) End SyncLock @@ -1069,9 +1188,10 @@ SourceBreak: Fail(ex) ElseIf HasAvailableSource() AndAlso Not IsMergeFailure Then '当前源失败，但还有下载源：正常地继续执行 - ElseIf Not Retried AndAlso Sources.Count > 1 Then + ElseIf Not Retried Then '合并失败或首次下载失败，未重试：将所有下载源重新标记为不允许断点续传的下载源，逐个重新尝试下载 - Hint($"{LocalName}：文件下载失败，正在自动重试……", If(ModeDebug, HintType.Critical, HintType.Info)) '在调试模式下给出红色提示 + '若所有源均不支持 Range，也会走到这里重试 + If Not IsRangeNotSupported Then Log($"[Download] {LocalName}：文件下载失败，正在自动重试……", LogLevel.Debug) Retried = True SyncLock LockSource SourcesOnce.Clear() @@ -1140,10 +1260,10 @@ SourceBreak: Dim RetryCount As Integer = 0 Try Retry: + '创建文件夹 + If File.Exists(LocalPath) Then File.Delete(LocalPath) + Directory.CreateDirectory(GetPathFromFullPath(LocalPath)) SyncLock LockChain - '创建文件夹 - If File.Exists(LocalPath) Then File.Delete(LocalPath) - Directory.CreateDirectory(GetPathFromFullPath(LocalPath)) '合并文件 If IsNoSplit Then '仅有一个线程，从缓存中输出 @@ -1266,6 +1386,12 @@ Retry: End Sub End Class + Private Class RangeNotSupportedException + Inherits WebException + Public Sub New(Message As String) + MyBase.New(Message) + End Sub + End Class ''' ''' 下载一系列文件的加载器。 ''' @@ -1386,13 +1512,13 @@ NextElement: If File Is Nothing Then Throw New ArgumentException("存在空文件请求！") For Each Source As NetSource In File.Sources If Not (Source.Url.StartsWithF("https://", True) OrElse Source.Url.StartsWithF("http://", True)) Then - Source.Ex = New ArgumentException("输入的下载链接不正确！") + Source.Ex = New ArgumentException("输入的下载链接不正确：" & Source.Url) Source.IsFailed = True End If Next If Not File.HasAvailableSource() Then Throw New ArgumentException("输入的下载链接不正确！") - If Not File.LocalPath.ToLower.Contains(":\") Then Throw New ArgumentException("输入的本地文件地址不正确！") - If File.LocalPath.EndsWithF("\") Then Throw New ArgumentException("请输入含文件名的完整文件路径！") + If Not File.LocalPath.ToLower.Contains(":\") Then Throw New ArgumentException("输入的本地文件地址不正确：" & File.LocalPath) + If File.LocalPath.EndsWithF("\") Then Throw New ArgumentException("请输入含文件名的完整文件路径：" & File.LocalPath) '文件夹检测 Dim DirPath As String = New FileInfo(File.LocalPath).Directory.FullName If Not Directory.Exists(DirPath) Then Directory.CreateDirectory(DirPath) @@ -1517,20 +1643,23 @@ Retry: Next OnFail(File.Ex) End Sub + Public Overrides Sub Failed(Ex As Exception) + OnFail(New List(Of Exception) From {Ex}) + End Sub Public Sub OnFail(ExList As List(Of Exception)) SyncLock LockState - If State > LoadState.Loading Then Return + If State >= LoadState.Finished Then Return If ExList Is Nothing OrElse Not ExList.Any() Then ExList = New List(Of Exception) From {New Exception("未知错误！")} '寻找有效的错误信息 - Dim UsefulExs = ExList.Where(Function(e) TypeOf e IsNot TaskCanceledException AndAlso TypeOf e IsNot ThreadInterruptedException).ToList + Dim UsefulExs = ExList.Where(Function(e) TypeOf e IsNot OperationCanceledException AndAlso TypeOf e IsNot TimeoutException AndAlso TypeOf e IsNot ThreadInterruptedException).ToList [Error] = If(UsefulExs.FirstOrDefault, ExList.FirstOrDefault) '获取实际失败的文件 For Each File In Files If File.State <> NetState.Error Then Continue For - Dim Detail As String = Join(File.Sources.Select(Function(s) $"{If(s.Ex?.Message, "无错误信息。"）}（{s.Url}）"), vbCrLf) + If File.Sources.All(Function(s) TypeOf s.Ex Is OperationCanceledException OrElse TypeOf s.Ex Is TimeoutException OrElse TypeOf s.Ex Is ThreadInterruptedException) Then Continue For + Dim Detail As String = Join(File.Sources.Select(Function(s) $"{If(s.Ex Is Nothing, "无错误信息。", s.Ex.GetBrief())}（{s.Url}）"), vbCrLf) [Error] = New Exception("文件下载失败：" & File.LocalPath & vbCrLf & - "各下载源的错误如下：" & vbCrLf & Detail, - [Error]) + "各下载源的错误如下：" & vbCrLf & Detail, [Error]) '上报 Telemetry("文件下载失败", "FileName", File.LocalName, @@ -1547,7 +1676,7 @@ Retry: '在退出同步锁后再进行日志输出 Dim ErrOutput As New List(Of String) For Each Ex As Exception In ExList - ErrOutput.Add(GetExceptionDetail(Ex)) + ErrOutput.Add(Ex.GetDetail()) Next Log("[Download] " & Join(ErrOutput.Distinct.ToArray, vbCrLf)) End Sub @@ -1697,7 +1826,7 @@ Retry: For Each File As NetFile In WaitingFiles If NetTaskThreadCount >= NetTaskThreadLimit Then Continue While '最大线程数检查 Dim NewThread = File.TryBeginThread() - If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(30) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） + If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(40) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） Next '为进行中的文件追加线程 If Speed >= NetTaskSpeedLimitLow Then Continue While '下载速度足够，无需新增 @@ -1717,7 +1846,7 @@ Retry: '新增线程 If PreparingCount > DownloadingCount Then Continue For '准备中的线程已多于下载中的线程，不再新增 Dim NewThread = File.TryBeginThread() - If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(30) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） + If NewThread IsNot Nothing AndAlso NewThread.Source.Url.Contains("bmclapi") Then Thread.Sleep(40) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次） Next End While Catch ex As Exception @@ -1751,7 +1880,7 @@ Retry: End Sub Private IsManagerStarted As Boolean = False - 'Public FileRemainList As New List(Of String) + Private DownloadCacheLock As New Object Private IsDownloadCacheCleared As Boolean = False ''' ''' 开始一个下载任务。 @@ -1759,15 +1888,18 @@ Retry: Public Sub Start(Task As LoaderDownload) StartManager() '清理缓存 - If Not IsDownloadCacheCleared Then - Try - DeleteDirectory(PathTemp & "Download") - Catch ex As Exception - Log(ex, "清理下载缓存失败") - End Try + SyncLock DownloadCacheLock '防止同时开启多个下载任务时重复清理 + If Not IsDownloadCacheCleared Then + Try + Log("[Net] 开始清理下载缓存") + DeleteDirectory(PathTemp & "Download") + Log("[Net] 下载缓存已清理") + Catch ex As Exception + Log(ex, "清理下载缓存失败") + End Try + End If IsDownloadCacheCleared = True - End If - Directory.CreateDirectory(PathTemp & "Download") + End SyncLock '文件处理 SyncLock LockFiles '添加每个文件 @@ -1820,6 +1952,45 @@ Retry: Return False End Function +#End Region + +#Region "端口" + + ''' + ''' 随机获取单个可用的端口。 + ''' + Public Function FindFreePort() As Integer + Dim Listener As New TcpListener(IPAddress.Loopback, 0) + Listener.Start() + Dim port As Integer = CType(Listener.LocalEndpoint, IPEndPoint).Port + Listener.Stop() + Return port + End Function + + ''' + ''' 获取当前已被占用的端口列表。 + ''' + Public Function GetUsedPorts() As List(Of Integer) + Dim IPProperties = NetworkInformation.IPGlobalProperties.GetIPGlobalProperties() + Dim UsedPorts As New List(Of Integer) + UsedPorts.AddRange(IPProperties.GetActiveTcpListeners().Select(Function(ep) ep.Port)) + UsedPorts.AddRange(IPProperties.GetActiveUdpListeners().Select(Function(ep) ep.Port)) + UsedPorts.AddRange(IPProperties.GetActiveTcpConnections().Select(Function(conn) conn.LocalEndPoint.Port)) + Return UsedPorts.Distinct().ToList() + End Function + + ''' + ''' 寻找数个连续编号的可用端口。 + ''' + Public Function FindFreePorts(ConsecutiveCount As Integer, ParamArray ExtraBlackLists As Integer()) As List(Of Integer) + Dim UsedPorts = GetUsedPorts().Concat(ExtraBlackLists) + For port = 12000 + RandomInteger(0, 1000) To 65000 - ConsecutiveCount + Dim Range = Enumerable.Range(port, ConsecutiveCount) + If Not Range.Any(Function(p) UsedPorts.Contains(p)) Then Return Range.ToList + Next + Throw New Exception("未能找到可用的端口！") + End Function + #End Region ''' @@ -1842,4 +2013,16 @@ Retry: End If End Function + ''' + ''' 判断某个 Exception 是否为网络问题所导致。 + ''' + Public Function IsNetworkRelated(Ex As Exception) As Boolean + Dim Detail = Ex.GetDetail() + If Detail.Contains("(403)") Then Return False + Return { + "(408)", "超时", "timeout", "网络请求失败", "连接尝试失败", "远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", + "由于目标计算机积极拒绝", "基础连接已经关闭" + }.Any(Function(k) Detail.ContainsF(k, True)) + End Function + End Module diff --git a/Plain Craft Launcher 2/Modules/Base/ModValidate.vb b/Plain Craft Launcher 2/Modules/Base/ModValidate.vb index 55eaff9..d04b4f2 100644 --- a/Plain Craft Launcher 2/Modules/Base/ModValidate.vb +++ b/Plain Craft Launcher 2/Modules/Base/ModValidate.vb @@ -113,11 +113,11 @@ Public Class ValidateInteger Me.Max = Max End Sub Public Overrides Function Validate(Str As String) As String + Dim Valed As Integer + If Not Integer.TryParse(Str, Valed) Then Return "请输入一个整数！" If Str.Length > 9 Then Return "请输入一个大小合理的数字！" - Dim Valed As Integer = Val(Str) - If Valed.ToString <> Str Then Return "请输入一个整数！" - If Val(Str) > Max Then Return "不可超过 " & Max & "！" - If Val(Str) < Min Then Return "不可低于 " & Min & "！" + If Valed > Max Then Return "不可超过 " & Max & "！" + If Valed < Min Then Return "不可低于 " & Min & "！" Return "" End Function End Class @@ -148,7 +148,7 @@ End Class ''' Public Class ValidateExcept Inherits Validate - Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) + Public Property Excepts As New ObjectModel.Collection(Of String) Public Property ErrorMessage As String Public Sub New() ErrorMessage = "输入内容不能包含 %" @@ -157,12 +157,15 @@ Public Class ValidateExcept Me.Excepts = Excepts Me.ErrorMessage = ErrorMessage End Sub - Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能包含 %") - Me.Excepts = New ObjectModel.Collection(Of String) - Me.ErrorMessage = ErrorMessage - For Each Data As String In Excepts - Me.Excepts.Add(Data) - Next + Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能包含 %") + Me.New( + New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)), + ErrorMessage) + End Sub + Public Sub New(Excepts As IEnumerable(Of Char), Optional ErrorMessage As String = "输入内容不能包含 %") + Me.New( + New ObjectModel.Collection(Of String)(Excepts.Select(Function(c) c.ToString).ToList), + ErrorMessage) End Sub Public Overrides Function Validate(Str As String) As String For Each Ch As String In Excepts @@ -181,7 +184,7 @@ End Class ''' Public Class ValidateExceptSame Inherits Validate - Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) + Public Property Excepts As New ObjectModel.Collection(Of String) Public Property ErrorMessage As String Public Property IgnoreCase As Boolean = False Public Sub New() @@ -191,13 +194,15 @@ Public Class ValidateExceptSame Me.ErrorMessage = ErrorMessage Me.IgnoreCase = IgnoreCase End Sub - Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) - Me.Excepts = New ObjectModel.Collection(Of String) - For Each Data As String In Excepts - Me.Excepts.Add(Data) - Next - Me.ErrorMessage = ErrorMessage - Me.IgnoreCase = IgnoreCase + Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) + Me.New( + New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)), + ErrorMessage, IgnoreCase) + End Sub + Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) + Me.New( + New ObjectModel.Collection(Of String) From {Except}, + ErrorMessage, IgnoreCase) End Sub Public Overrides Function Validate(Str As String) As String If Str Is Nothing Then Return ErrorMessage.Replace("%", "null") diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb index c62beb9..f36ed60 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb @@ -347,7 +347,7 @@ Case 4475 : Tags.Add("冒险") Case 4476 : Tags.Add("探索") Case 4477 : Tags.Add("小游戏") - Case 4471 : Tags.Add("科幻") + Case 4474 : Tags.Add("科幻") Case 4736 : Tags.Add("空岛") Case 5128 : Tags.Add("原版改良") Case 4487 : Tags.Add("FTB") @@ -1161,9 +1161,9 @@ Retry: ElseIf [Error] IsNot Nothing Then '有结果但是有错误 If CurseForgeFailed Then - Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。" + Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。" Else - Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后重试，或使用 VPN 以改善网络环境。" + Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。" End If End If @@ -1211,11 +1211,11 @@ Retry: Function(Project As CompProject) As Double Select Case Request.Type Case CompType.Mod, CompType.ModPack - Return If(Project.FromCurseForge, 1, 7) + Return If(Project.FromCurseForge, 1, 5) Case CompType.DataPack Return If(Project.FromCurseForge, 10, 1) Case CompType.ResourcePack, CompType.Shader - Return If(Project.FromCurseForge, 1, 5) + Return If(Project.FromCurseForge, 1, 4) Case Else Return 1 End Select @@ -1354,7 +1354,7 @@ Retry: ''' ''' 目标本地文件夹，或完整的文件路径。会自动判断类型。 Public Function ToNetFile(LocalAddress As String) As NetFile - Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True) + Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), SimulateBrowserHeaders:=True) End Function '实例化 @@ -1395,10 +1395,9 @@ Retry: 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, WebUtility.UrlEncode(FileName)) '对文件名进行编码 - DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正 - DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源，这个写法是为了让镜像源排在后面 + If Url = "" Then Url = $"https://edge.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}" + DownloadUrls = HandleCurseForgeDownloadUrls(Url.Replace(FileName, WebUtility.UrlEncode(FileName))) '对脑残 CurseForge 的下载地址进行多种修正 + DownloadUrls.Add(DlSourceModGet(Url)) '添加镜像源；注意 MCIM 源不支持 URL 编码后的文件名，必须传入 URL 编码前的文件名 DownloadUrls = DownloadUrls.Distinct.ToList '最终去重 'Dependencies If Data.ContainsKey("dependencies") Then diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb index 9a5dd9a..8b97b0f 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb @@ -341,6 +341,7 @@ Extracted: ''' 导致崩溃的原因枚举。 ''' Private Enum CrashReason + Java虚拟机参数有误 Mod文件被解压 MixinBootstrap缺失 内存不足 @@ -484,10 +485,12 @@ Done: '崩溃报告分析，高优先级 If LogCrash IsNot Nothing Then If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高) + If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071 End If '游戏日志分析 If LogMc IsNot Nothing Then + If LogMc.Contains("Unrecognized option:") Then AppendReason(CrashReason.Java虚拟机参数有误) If LogMc.Contains("Found multiple arguments for option fml.forgeVersion, but you asked for only one") Then AppendReason(CrashReason.版本Json中存在多个Forge) If LogMc.Contains("The driver does not appear to support OpenGL") Then AppendReason(CrashReason.显卡不支持OpenGL) If LogMc.Contains("java.lang.ClassCastException: java.base/jdk") Then AppendReason(CrashReason.使用JDK) @@ -516,7 +519,7 @@ Done: If LogMc.Contains("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足) If LogMc.Contains("java.lang.NoSuchMethodError: net.minecraft.world.server.ChunkManager$ProxyTicketManager.shouldForceTicks(J)Z") AndAlso LogMc.Contains("OptiFine") Then AppendReason(CrashReason.OptiFine导致无法加载世界) If LogMc.Contains("Unsupported class file major version") Then AppendReason(CrashReason.Java版本不兼容) - If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") Then AppendReason(CrashReason.NightConfig的Bug) + If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") AndAlso Not CrashReasons.ContainsKey(CrashReason.Mod配置文件导致游戏崩溃) Then AppendReason(CrashReason.NightConfig的Bug) If LogMc.Contains("Cannot find launch target fmlclient, unable to launch") Then AppendReason(CrashReason.Forge安装不完整) If LogMc.Contains("Invalid paths argument, contained no existing paths") AndAlso LogMc.Contains("libraries\net\minecraftforge\fmlcore") Then AppendReason(CrashReason.Forge安装不完整) If LogMc.Contains("Invalid module name: '' is not a Java identifier") Then AppendReason(CrashReason.Mod名称包含特殊字符) @@ -539,8 +542,8 @@ Done: If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase)) If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList) If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase)) - If LogMc.Contains("Incompatible mods found!") Then '#5006 - AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "")) + If LogMc.Contains("Incompatible mods found!") Then '#5006, #5115 + AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息：").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray)) End If If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then AppendReason(CrashReason.Mod缺少前置或MC版本错误, @@ -656,7 +659,7 @@ Done: End If 'Mod 解析错误（常见于 Fabric 前置校验失败） If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错) - 'Mixin 失败可以导致大量 Mod 实例创建失败 + 'Mixin 失败可以导致大量 Mod 实例创建失败，因此需要放到低优先级中 If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf))) '注意：Fabric 的 Warnings were found! 不一定是崩溃原因，它可能是单纯的警报 End If @@ -715,7 +718,7 @@ NextStack: "preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service", "fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge", "injection", "listeners", "scheduler", "minecraft", "universal", "multipart", "neoforged", "microsoft", - "transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill" + "transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill", "concurrent" }.Contains(Word.ToLower) Then Continue For PossibleWords.Add(Word.Trim) Next @@ -868,11 +871,11 @@ NextStack: Sub() '弹窗选择：查看日志 If File.Exists(DirectFile.Value.Key) Then - ShellOnly(DirectFile.Value.Key) + StartProcess(DirectFile.Value.Key) Else Dim FilePath As String = PathTemp & "Crash.txt" WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf)) - ShellOnly(FilePath) + StartProcess(FilePath) End If End Sub)) Case 3 @@ -905,8 +908,7 @@ NextStack: If File.Exists(OutputFile) Then If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile)) Dim FileContent As String = ReadFile(OutputFile, FileEncoding) - FileContent = FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")) - FileContent = FilterUserName(FileContent, "*") + FileContent = FilterUserName(FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*")), "*") WriteFile(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding) Log($"[Crash] 导出文件：{FileName}，编码：{FileEncoding.HeaderName}") End If @@ -914,7 +916,7 @@ NextStack: '导出报告 Compression.ZipFile.CreateFromDirectory(TempFolder & "Report\", FileAddress) DeleteDirectory(TempFolder & "Report\") - Hint("错误报告已导出！", HintType.Finish) + Hint("错误报告已导出！", HintType.Green) Catch ex As Exception Log(ex, "导出错误报告失败", LogLevel.Feedback) Return @@ -946,6 +948,8 @@ NextStack: For Each Reason In CrashReasons Dim Additional As List(Of String) = Reason.Value Select Case Reason.Key + Case CrashReason.Java虚拟机参数有误 + Results.Add("由于 Java 参数有误，导致游戏无法继续运行。\n请检查高级选项中的 Java 虚拟机参数和游戏参数设置是否有误。") Case CrashReason.Mod文件被解压 Results.Add("由于 Mod 文件被解压了，导致游戏无法继续运行。\n直接把整个 Mod 文件放进 Mod 文件夹中即可，若解压就会导致游戏出错。\n\n请删除 Mod 文件夹中已被解压的 Mod，然后再启动游戏。") Case CrashReason.内存不足 @@ -1026,9 +1030,17 @@ NextStack: End If Case CrashReason.特定实体导致崩溃 If Additional.Count = 1 Then - Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况。\h") + If Additional.First.Contains("minecraft:player") Then + If Additional.First.Contains(" ") Then + Results.Add($"游戏因为位于 {Additional.First.AfterFirst(" ")} 的玩家实体导致了崩溃。\h") + Else + Results.Add($"游戏因为玩家实体导致了崩溃。\h") + End If + Else + Results.Add($"游戏因为实体 {Additional.First} 导致了崩溃。\h") + End If Else - Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，然后观察游戏的运行情况。\h") + Results.Add($"游戏因为下列实体导致了崩溃：{Additional.Join("、")}\h") End If Case CrashReason.OptiFine与Forge不兼容 Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容，导致了游戏崩溃。\n\n请前往 OptiFine 官网（https://optifine.net/downloads）查看 OptiFine 所兼容的 Forge 版本，并严格按照对应版本重新安装游戏。") diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb index e058e0b..27e1264 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb @@ -73,8 +73,10 @@ 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 + If IndexFile Is Nothing Then + Task.Output = New List(Of NetFile) + Log("[Download] 未找到版本 " & Version.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", LogLevel.Debug) + ElseIf 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} @@ -93,6 +95,11 @@ LoadersAssetsUpdate.Add(New LoaderTask(Of String, List(Of NetFile))("后台分析资源文件索引地址", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Dim BackAssetsFile As NetFile = DlClientAssetIndexGet(Version) + If BackAssetsFile Is Nothing Then + Log("[Download] 未找到版本 " & Version.Name & " 的合适的资源索引下载地址，游戏 assets 可能缺失", LogLevel.Debug) + Task.Abort() + Throw New ThreadInterruptedException + End If RealAddress = BackAssetsFile.LocalPath TempAddress = PathTemp & "Cache\" & BackAssetsFile.LocalName BackAssetsFile.LocalPath = TempAddress @@ -198,7 +205,7 @@ Private IsNewClientVersionHinted As Boolean = False Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult)) Dim StartTime As Long = GetTimeTick() - Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json")) + Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", RequireJson:=True)) Try Dim Versions As JArray = Json("versions") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）") @@ -235,7 +242,7 @@ ''' Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain) Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult)) - Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json")) + Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", RequireJson:=True)) Try Dim Versions As JArray = Json("versions") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）") @@ -413,7 +420,7 @@ ''' 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 = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList")) + Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList", RequireJson:=True)) Try Dim Versions As New List(Of DlOptiFineListEntry) For Each Token As JObject In Json @@ -483,7 +490,7 @@ ''' 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 = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", UseBrowserUserAgent:=True) + Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", SimulateBrowserHeaders:=True) If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）") '获取所有版本信息 Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)") @@ -631,9 +638,9 @@ Try Result = NetRequestByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4，#4057 - ".html", UseBrowserUserAgent:=True) + ".html", SimulateBrowserHeaders:=True) Catch ex As Exception - If GetExceptionSummary(ex).Contains("(404)") Then + If ex.GetBrief().Contains("(404)") Then Throw New Exception("不可用") Else Throw @@ -701,7 +708,7 @@ ''' Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & - Loader.Input.Replace("-", "_"))) '兼容 Forge 1.7.10-pre4，#4057 + Loader.Input.Replace("-", "_"), RequireJson:=True)) '兼容 Forge 1.7.10-pre4，#4057 Dim Versions As New List(Of DlForgeVersionEntry) Try Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input) @@ -839,8 +846,8 @@ Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain) Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) '获取版本列表 JSON - Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge") - Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge") + Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", RequireJson:=True) + Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", RequireJson:=True) If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）") '解析 Try @@ -857,8 +864,8 @@ Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain) Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) '获取版本列表 JSON - Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge") - Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge") + Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", RequireJson:=True) + Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", RequireJson:=True) If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）") '解析 Try @@ -963,7 +970,7 @@ ''' Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain) Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) - Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json")) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json", RequireJson:=True)) Try Dim Json As JObject = Result("versions") Dim Versions As New List(Of DlLiteLoaderListEntry) @@ -991,7 +998,7 @@ ''' 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 = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json")) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", RequireJson:=True)) Try Dim Json As JObject = Result("versions") Dim Versions As New List(Of DlLiteLoaderListEntry) @@ -1062,7 +1069,7 @@ ''' Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain) Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) - Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions")) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions", RequireJson:=True)) Try Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result} If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项") @@ -1077,7 +1084,7 @@ ''' 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 = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions")) + Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", RequireJson:=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("获取到的列表缺乏必要项") @@ -1134,7 +1141,7 @@ Dim Exs As String = "" For Each Source In Urls Try - Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8)) + Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8, RequireJson:=True)) Catch ex As Exception Exs += ex.Message + vbCrLf End Try diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb index 5a55344..d84592b 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb @@ -10,7 +10,7 @@ '路径 ''' - ''' Java.exe 文件的完整路径。 + ''' java.exe 文件的完整路径。 ''' Public ReadOnly Property PathJava As String Get @@ -18,15 +18,7 @@ End Get End Property ''' - ''' Javaw.exe 文件的完整路径。 - ''' - Public ReadOnly Property PathJavaw As String - Get - Return PathFolder & "javaw.exe" - End Get - End Property - ''' - ''' Javaw.exe 文件所在文件夹的路径，以 \ 结尾。 + ''' java.exe 文件所在文件夹的路径，以 \ 结尾。 ''' Public PathFolder As String ''' @@ -102,20 +94,13 @@ Dim Output As String = Nothing Try '确定文件存在 - If Not File.Exists(PathJavaw) Then - Throw New FileNotFoundException("未找到 javaw.exe 文件", PathJavaw) - End If - If Not File.Exists(PathFolder & "java.exe") Then - Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe") - End If - If File.Exists(PathFolder & "pdf-bookmark") Then - Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326 - End If + If Not File.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava) + If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326 IsJre = Not File.Exists(PathFolder & "javac.exe") '运行 -version - Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower + Output = StartProcessAndGetOutput(PathJava, "-version", 15000).ToLower If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败") - If ModeDebug Then Log("[Java] Java 检查输出：" & PathFolder & "java.exe" & vbCrLf & Output) + If ModeDebug Then Log("[Java] Java 检查输出：" & PathJava & vbCrLf & Output) If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java，请在删除 Java 文件夹中的 /lib/ext 文件夹后再试") If Output.Contains("a fatal error") Then Throw New ApplicationException("无法运行该 Java，该 Java 或系统存在问题") '获取详细信息 @@ -136,17 +121,17 @@ End If Is64Bit = Output.Contains("64-bit") If Version.Minor <= 4 OrElse Version.Minor >= 100 Then Throw New ApplicationException("分析详细信息失败，获取的版本为 " & Version.ToString) - '基于 #3649，在 64 位系统上禁用 32 位 Java + '#3649：在 64 位系统上禁用 32 位 Java If Not Is64Bit AndAlso Not Is32BitSystem Then Throw New Exception("该 Java 为 32 位版本，请安装 64 位的 Java") - '基于 #2249 发现 JRE 17 似乎也导致了 Forge 安装失败，干脆禁用更多版本的 JRE + '#2249：JRE 17 似乎会导致 Forge 安装失败，干脆禁用更多版本的 JRE If IsJre AndAlso VersionCode >= 16 Then Throw New Exception("由于高版本 JRE 对游戏的兼容性很差，因此不再允许使用。你可以使用对应版本的 JDK，而非 JRE！") Catch ex As ApplicationException Throw ex Catch ex As ThreadInterruptedException Throw ex Catch ex As Exception - Log("[Java] 检查失败的 Java 输出：" & PathFolder & "java.exe" & vbCrLf & If(Output, "无程序输出")) - Throw New Exception("检查 Java 失败（" & If(PathJavaw, "Nothing") & "）", ex) + Log("[Java] 检查失败的 Java 输出：" & If(PathJava, "Nothing") & vbCrLf & If(Output, "无程序输出")) + Throw New Exception("检查 Java 失败（" & If(PathJava, "Nothing") & "）", ex) End Try IsChecked = True End Sub @@ -460,8 +445,8 @@ NoUserJava: ''' 将 Java 按照适用性排序。 ''' Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean - Dim PathInfo As New DirectoryInfo(ShortenPath(Path)) - Dim PathMcInfo As New DirectoryInfo(ShortenPath(PathMcFolder)) + Dim PathInfo As New DirectoryInfo(Path) + Dim PathMcInfo As New DirectoryInfo(PathMcFolder) '1. 尽量在当前文件夹或当前 Minecraft 文件夹 Dim ProgramPathParent As String, MinecraftPathParent As String = "" ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName @@ -533,7 +518,7 @@ NoUserJava: JavaSearchFolder(Disk.Name, JavaPreList, False) Next '查找 .jdks 文件夹中的 Java - JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False) + JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False, True) '查找 APPDATA 文件夹中的 Java JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False) JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False) @@ -661,7 +646,7 @@ Wait: Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False) Try Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找：" & OriginalPath) - JavaSearchFolder(New DirectoryInfo(ShortenPath(OriginalPath)), Results, Source, IsFullSearch) + JavaSearchFolder(New DirectoryInfo(OriginalPath), Results, Source, IsFullSearch) Catch ex As UnauthorizedAccessException Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹：" & OriginalPath) Catch ex As Exception @@ -689,7 +674,7 @@ Wait: "应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot", "runtime", "x86", "x64", "forge", "原版", "optifine", "官方", "启动", "hmcl", "mod", "高清", "download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages", - "4297127d64ec6", "1.", "启动"} + "4297127d64ec6", "1.", "启动", "jbr"} For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接 Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).ToLower '用于搜索的字符串 diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb index f9cbe79..531f034 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb @@ -35,7 +35,7 @@ Public Module ModLaunch '预检查 If Not RunInUi() Then Throw New Exception("McLaunchStart 必须在 UI 线程调用！") If McLaunchLoader.State = LoadState.Loading Then - Hint("已有游戏正在启动中！", HintType.Critical) + Hint("已有游戏正在启动中！", HintType.Red) Return False End If '强制切换需要启动的版本 @@ -44,7 +44,7 @@ Public Module ModLaunch '检查版本 CurrentLaunchOptions.Version.Load() If CurrentLaunchOptions.Version.State = McVersionState.Error Then - Hint("无法启动 Minecraft：" & CurrentLaunchOptions.Version.Info, HintType.Critical) + Hint("无法启动 Minecraft：" & CurrentLaunchOptions.Version.Info, HintType.Red) Return False End If '切换版本 @@ -98,7 +98,7 @@ Public Module ModLaunch McLaunchPrecheck() McLaunchLog("预检测已通过") Catch ex As Exception - If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical) + If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Red) Throw End Try Dim IsSavingBatch As Boolean = CurrentLaunchOptions?.SaveBatch IsNot Nothing @@ -146,7 +146,7 @@ Public Module ModLaunch '成功与失败处理 Select Case LaunchLoader.State Case LoadState.Finished - Hint(McVersionCurrent.Name & " 启动成功！", HintType.Finish) + Hint(McVersionCurrent.Name & " 启动成功！", HintType.Green) '上报 If Not IsSavingBatch Then Telemetry("Minecraft 启动成功", @@ -155,9 +155,9 @@ Public Module ModLaunch End If Case LoadState.Aborted If AbortHint Is Nothing Then - Hint(If(IsSavingBatch, "已取消导出启动脚本！", "已取消启动！"), HintType.Info) + Hint(If(IsSavingBatch, "已取消导出启动脚本！", "已取消启动！"), HintType.Blue) Else - Hint(AbortHint, HintType.Finish) + Hint(AbortHint, HintType.Green) End If Case LoadState.Failed Throw LaunchLoader.Error @@ -178,7 +178,7 @@ NextInner: GoTo NextInner Else '没有特殊处理过的错误信息 - McLaunchLog("错误：" & GetExceptionDetail(ex)) + McLaunchLog("错误：" & ex.GetDetail()) Log(ex, If(IsSavingBatch, "导出启动脚本失败", "Minecraft 启动失败"), LogLevel.Msgbox, If(IsSavingBatch, "导出启动脚本失败", "启动失败")) @@ -187,7 +187,7 @@ NextInner: Telemetry("Minecraft 启动失败", "Version", McVersionCurrent.Version.ToString, "LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)), - "Exception", FilterUserName(FilterAccessToken(GetExceptionDetail(ex), "*"), "*")) + "Exception", FilterUserName(FilterAccessToken(ex.GetDetail(), "*"), "*")) End If Throw End If @@ -270,7 +270,7 @@ NextInner: Select Case MyMsgBox("你必须先登录正版账号，才能进行离线登录！", "正版验证", "购买正版", "试玩", "返回", Button1Action:=Sub() OpenWebsite("https://www.xbox.com/zh-cn/games/store/minecraft-java-bedrock-edition-for-pc/9nxp44l49shj")) Case 2 - Hint("游戏将以试玩模式启动！", HintType.Critical) + Hint("游戏将以试玩模式启动！", HintType.Red) CurrentLaunchOptions.ExtraArgs.Add("--demo") Case 3 Throw New Exception("$$") @@ -609,12 +609,8 @@ SkipLogin: McLoginRequestValidate(Data) GoTo LoginFinish Catch ex As Exception - Dim AllMessage = GetExceptionDetail(ex) - McLaunchLog("验证登录失败：" & AllMessage) - If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then - McLaunchLog("已触发超时登录失败") - Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。") - End If + Log(ex, "验证登录失败") + If IsNetworkRelated(ex) Then Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。") End Try Data.Progress = 0.25 '尝试刷新登录 @@ -624,7 +620,7 @@ Refresh: McLoginRequestRefresh(Data, NeedRefresh) GoTo LoginFinish Catch ex As Exception - McLaunchLog("刷新登录失败：" & GetExceptionDetail(ex)) + McLaunchLog("刷新登录失败：" & ex.GetDetail()) If WasRefreshed Then Throw New Exception("二轮刷新登录失败", ex) End Try Data.Progress = If(NeedRefresh, 0.85, 0.45) @@ -634,7 +630,7 @@ Refresh: If Data.IsAborted Then Throw New ThreadInterruptedException NeedRefresh = McLoginRequestLogin(Data) Catch ex As Exception - McLaunchLog("登录失败：" & GetExceptionDetail(ex)) + McLaunchLog("登录失败：" & ex.GetDetail()) Throw End Try If NeedRefresh Then @@ -726,7 +722,7 @@ LoginFinish: New JProperty("requestUser", True) ).ToString(Newtonsoft.Json.Formatting.None), Headers:={{"Accept-Language", "zh-CN"}}, - ContentType:="application/json; charset=utf-8")) + ContentType:="application/json; charset=utf-8", RequireJson:=True)) '将登录结果输出 If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效！") Data.Output.AccessToken = LoginJson("accessToken").ToString @@ -756,13 +752,13 @@ LoginFinish: Data.Input.BaseUrl & "/authenticate", HttpMethod.Post, Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None), Headers:={{"Accept-Language", "zh-CN"}}, - ContentType:="application/json; charset=utf-8")) + ContentType:="application/json; charset=utf-8", RequireJson:=True)) '检查登录结果 If LoginJson("availableProfiles").Count = 0 Then - If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色，无法更换！", HintType.Critical) + If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色，无法更换！", HintType.Red) Throw New Exception("$你还没有创建角色，请在创建角色后再试！") ElseIf Data.Input.ForceReselectProfile AndAlso LoginJson("availableProfiles").Count = 1 Then - Hint("你的账户中只有一个角色，无法更换！", HintType.Critical) + Hint("你的账户中只有一个角色，无法更换！", HintType.Red) End If Dim SelectedName As String = Nothing Dim SelectedId As String = Nothing @@ -814,13 +810,14 @@ LoginFinish: McLaunchLog("登录成功（Login, " & Data.Input.Token & "）") Return NeedRefresh Catch ex As Exception - Dim AllMessage As String = GetExceptionSummary(ex) + Dim AllMessage As String = ex.GetBrief() Log(ex, "登录失败原始错误信息", LogLevel.Normal) '读取服务器返回的错误 If TypeOf ex Is ResponsedWebException Then Dim ErrorMessage As String = Nothing Try - ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage") + Dim Response = DirectCast(ex, ResponsedWebException).Response + If ErrorMessage.ContainsF("errorMessage", True) Then ErrorMessage = GetJson(Response)("errorMessage") Catch End Try If Not String.IsNullOrWhiteSpace(ErrorMessage) Then @@ -838,7 +835,7 @@ LoginFinish: End If End If '通用关键字检测 - If AllMessage.Contains("403") Then + If AllMessage.Contains("(403)") Then Select Case Data.Input.Type Case McLoginType.Auth Throw New Exception("$登录失败，以下为可能的原因：" & vbCrLf & @@ -852,8 +849,8 @@ LoginFinish: If(Data.Input.UserName.Contains("@"), "", " - 登录账号应为邮箱或统一通行证账号，而非游戏角色 ID。" & vbCrLf) & " - 只注册了账号，但没有加入对应服务器。") End Select - ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then - Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后重试，或使用加速器或 VPN 以改善网络环境。") + ElseIf ex.IsNetworkRelated() Then + Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。") ElseIf ex.Message.StartsWithF("$") Then Throw Else @@ -872,7 +869,7 @@ Retry: McLaunchLog("开始微软登录步骤 1/6（原始登录）") Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post, Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", - ContentType:="application/x-www-form-urlencoded")) + ContentType:="application/x-www-form-urlencoded", RequireJson:=True)) McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString) '弹窗 @@ -907,9 +904,17 @@ Retry: Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}}, ThreadCount:=2) Catch ex As ResponsedWebException - If ex.Response.ContainsF("must sign in again", True) OrElse ex.Response.ContainsF("password expired", True) OrElse - (ex.Response.Contains("refresh_token") AndAlso ex.Response.Contains("is not valid")) Then '#269 + '修改错误列表时，同时检查 MyMsgLogin.xaml.vb 中的对应代码 + Dim Response = ex.Response + If Response.ContainsF("must sign in again", True) OrElse Response.ContainsF("password expired", True) OrElse + (Response.Contains("refresh_token") AndAlso Response.Contains("is not valid")) Then '#269 Return {"Relogin", ""} + ElseIf Response.Contains("Account security interrupt") Then + MyMsgBox("该账号由于安全问题无法登陆，请前往微软账户页获取更多信息。", "登录失败", "我知道了", IsWarn:=True) + Throw New Exception("$$") + ElseIf Response.Contains("service abuse") Then + MyMsgBox("非常抱歉，该账号已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True) + Throw New Exception("$$") Else Throw End If @@ -934,7 +939,7 @@ Retry: ""TokenType"": ""JWT"" }" Dim Result As String = NetRequestByClientMultiple("https://user.auth.xboxlive.com/user/authenticate", HttpMethod.Post, - Content:=Request, ContentType:="application/json") + Content:=Request, ContentType:="application/json", RequireJson:=True) Dim ResultJson As JObject = GetJson(Result) Dim XBLToken As String = ResultJson("Token").ToString Return XBLToken @@ -956,7 +961,7 @@ Retry: Dim Result As String Try Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post, - Content:=Request, ContentType:="application/json") + Content:=Request, ContentType:="application/json", RequireJson:=True) Catch ex As ResponsedWebException '参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js If ex.Response.Contains("2148916227") Then @@ -968,7 +973,7 @@ Retry: End If Throw New Exception("$$") ElseIf ex.Response.Contains("2148916235") Then - MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN。", "登录失败", "我知道了") + MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN，然后再试。", "登录失败", "我知道了") Throw New Exception("$$") ElseIf ex.Response.Contains("2148916238") Then If MyMsgBox("该账号年龄不足，你需要先修改出生日期，然后才能登录。" & vbCrLf & @@ -987,15 +992,11 @@ Retry: End If End Try - Try '这个 Try 块仅为了追踪 #6683 而添加 - Dim ResultJson As JObject = GetJson(Result) - Dim XSTSToken As String = ResultJson("Token").ToString - Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString - Return {XSTSToken, UHS} - Catch - Log("[Launch] 返回内容：" & vbCrLf & Result) - Throw - End Try + Dim ResultJson As JObject = GetJson(Result) + Return { + ResultJson("Token"), 'XSTSToken + ResultJson("DisplayClaims")("xui")(0)("uhs") 'UHS + } End Function '微软登录步骤 4：从 {XSTSToken, UHS} 获取 Minecraft AccessToken Private Function MsLoginStep4(Tokens As String()) As String @@ -1005,9 +1006,9 @@ Retry: Dim Result As String Try Result = NetRequestByClientRetry("https://api.minecraftservices.com/authentication/login_with_xbox", HttpMethod.Post, - Content:=Request, ContentType:="application/json") + Content:=Request, ContentType:="application/json", RequireJson:=True) Catch ex As Net.WebException - Dim Message As String = GetExceptionSummary(ex) + Dim Message As String = ex.GetBrief() If Message.Contains("(429)") Then Log(ex, "微软登录第 4 步汇报 429") Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！") @@ -1019,16 +1020,14 @@ Retry: End If End Try - Dim ResultJson As JObject = GetJson(Result) - Dim AccessToken As String = ResultJson("access_token").ToString - Return AccessToken + Return GetJson(Result)("access_token").ToString End Function '微软登录步骤 5：验证微软账号是否持有 MC，这也会刷新 XGP Private Sub MsLoginStep5(AccessToken As String) McLaunchLog("开始微软登录步骤 5/6") Dim Result As String = NetRequestByClientMultiple("https://api.minecraftservices.com/entitlements/mcstore", - ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}) + ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True) Try Dim ResultJson As JObject = GetJson(Result) If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then @@ -1050,9 +1049,9 @@ Retry: Dim Result As String Try Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile", - ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}) - Catch ex As Net.WebException - Dim Message As String = GetExceptionSummary(ex) + ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True) + Catch ex As WebException + Dim Message As String = ex.GetBrief() If Message.Contains("(429)") Then Log(ex, "微软登录第 6 步汇报 429") Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！") @@ -1123,7 +1122,7 @@ Retry: If Len(Uuid) = 32 Then Return Uuid '从官网获取 Try - Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name)) + Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, RequireJson:=True)) If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在（" & Name & "）") Uuid = If(GotJson("id"), "") Catch ex As Exception @@ -1305,7 +1304,7 @@ Retry: If McLaunchJavaSelected IsNot Nothing Then McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString) Else - Hint("没有可用的 Java，已取消启动！", HintType.Critical) + Hint("没有可用的 Java，已取消启动！", HintType.Red) Throw New Exception("$$") End If @@ -1396,7 +1395,7 @@ Retry: Next '自定义 Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent) - Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame) + Arguments += " " & ArgumentReplace(If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)) '进行参数替换 Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader) If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then @@ -1413,6 +1412,9 @@ Retry: FinalArguments += Argument & " " Next FinalArguments = FinalArguments.TrimEnd + '替换 Module Path 为短路径（Forge 会在版本 JSON 硬编码这些路径） + FinalArguments = FinalArguments.RegexReplaceEach("(?<= (-p|--module-path) "")[^""]+(?="" )", + Function(ModulePath) ModulePath.Value.RegexReplaceEach("[A-Z]{1}:\\[^;]+", Function(m) ShortenPath(m.Value))) '进服 Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp) If Server.Length > 0 Then @@ -1428,7 +1430,7 @@ Retry: '不包含端口号 FinalArguments += $" --server {Server} --port 25565" End If - If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Critical) + If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Red) End If End If '输出 @@ -1448,7 +1450,7 @@ Retry: 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.Insert(0, ArgumentReplace(ArgumentJvm)) '可变 JVM 参数 DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024 * 0.15) & "m") DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent, Not McLaunchJavaSelected.Is64Bit) * 1024) & "m") DataList.Add("""-Djava.library.path=" & GetNativesFolder() & """") @@ -1461,9 +1463,7 @@ Retry: 'Authlib-Injector If McLoginLoader.Output.Type = "Auth" Then If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#） - Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy, - "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 - Setup.Get("VersionServerAuthServer", McVersionCurrent)) + Dim Server As String = Setup.Get("VersionServerAuthServer", McVersionCurrent) Try Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8) DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server & @@ -1488,6 +1488,9 @@ Retry: DataList.Add(Version.JsonObject("mainClass")) End If + '处理 DataList 的换行符 + DataList = DataList.Select(Function(d) d.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim).ToList + Return Join(DataList, " ") End Function Private Function McLaunchArgumentsJvmNew(Version As McVersion) As String @@ -1531,9 +1534,7 @@ NextVersion: 'Authlib-Injector If McLoginLoader.Output.Type = "Auth" Then If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#） - Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy, - "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 - Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)) + Dim Server As String = Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent) Try Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8) DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server & @@ -1555,7 +1556,7 @@ NextVersion: '如果不合并，会导致 Forge 1.17 启动无效，它有两个 --add-exports，进一步导致其中一个在后面被去重 Dim DeDuplicateDataList As New List(Of String) For i = 0 To DataList.Count - 1 - Dim CurrentEntry As String = DataList(i) + Dim CurrentEntry As String = DataList(i).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim If DataList(i).StartsWithF("-") Then Do While i < DataList.Count - 1 If DataList(i + 1).StartsWithF("-") Then @@ -1571,7 +1572,7 @@ NextVersion: '去重 DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M") '#3511 的清理 - Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ") + Dim Result As String = DeDuplicateDataList.Distinct.Join(" ") '添加 MainClass If Version.JsonObject("mainClass") Is Nothing Then @@ -1592,7 +1593,7 @@ NextVersion: If Not BasicString.Contains("--height") Then BasicString += " --height ${resolution_height} --width ${resolution_width}" DataList.Add(BasicString) - Dim Result As String = Join(DataList, " ") + Dim Result As String = DataList.Join(" ") '特别改变 OptiFineTweaker If (Version.Version.HasForge OrElse Version.Version.HasLiteLoader) AndAlso Version.Version.HasOptiFine Then @@ -1697,7 +1698,7 @@ NextVersion: GameArguments.Add("${launcher_version}", VersionCode) GameArguments.Add("${version_name}", Version.Name) Dim ArgumentInfo As String = Setup.Get("VersionArgumentInfo", Version:=McVersionCurrent) - GameArguments.Add("${version_type}", If(ArgumentInfo = "", Setup.Get("LaunchArgumentInfo"), ArgumentInfo)) + GameArguments.Add("${version_type}", ArgumentReplace(If(ArgumentInfo = "", Setup.Get("LaunchArgumentInfo"), ArgumentInfo))) GameArguments.Add("${game_directory}", ShortenPath(Left(McVersionCurrent.PathIndie, McVersionCurrent.PathIndie.Count - 1))) GameArguments.Add("${assets_root}", ShortenPath(PathMcFolder & "assets")) GameArguments.Add("${user_properties}", "{}") @@ -1707,7 +1708,7 @@ NextVersion: GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken) GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken) GameArguments.Add("${user_type}", "msa") '#1221 - GameArguments.Add("${primary_jar}", Version.Path & Version.Name & ".jar") '#6942 + GameArguments.Add("${primary_jar}", ShortenPath(Version.Path & Version.Name & ".jar")) '#6942 '窗口尺寸参数 Dim GameSize As Size @@ -1796,7 +1797,7 @@ NextVersion: File.Delete(FilePath) Catch ex As UnauthorizedAccessException McLaunchLog("删除原 dll 访问被拒绝，这通常代表有一个 MC 正在运行，跳过解压：" & FilePath) - McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex)) + McLaunchLog("实际的错误信息：" & ex.GetDetail()) Exit For End Try End If @@ -1816,7 +1817,7 @@ NextVersion: File.Delete(FileName) Catch ex As UnauthorizedAccessException McLaunchLog("删除多余文件访问被拒绝，跳过删除步骤") - McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex)) + McLaunchLog("实际的错误信息：" & ex.GetDetail()) Return End Try Next @@ -1827,10 +1828,14 @@ NextVersion: ''' 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" + If Not (IsGBKEncoding OrElse Result.IsASCII()) Then + Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives" + If Not Result.IsASCII() Then + Result = OsDrive & "ProgramData\PCL\natives" + End If + End If + Directory.CreateDirectory(Result) '提前创建，这样 ShortenPath 才有结果（否则在长路径下首次启动 Forge 会崩溃） + Return ShortenPath(Result) End Function #End Region @@ -1842,7 +1847,7 @@ NextVersion: '要求 Java 使用高性能显卡 If Setup.Get("LaunchAdvanceGraphicCard") Then Try - SetGPUPreference(McLaunchJavaSelected.PathJavaw) + SetGPUPreference(McLaunchJavaSelected.PathJava) SetGPUPreference(PathWithName) Catch ex As Exception If IsAdmin() Then @@ -1850,7 +1855,7 @@ NextVersion: Else Log(ex, "直接调整显卡设置失败，将以管理员权限重启 PCL 再次尝试") Try - If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJavaw}""") = ProcessReturnValues.TaskDone Then + If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJava}""") = ProcessReturnValues.TaskDone Then McLaunchLog("以管理员权限重启 PCL 并调整显卡设置成功") Else Throw New Exception("调整过程中出现异常") @@ -1981,7 +1986,7 @@ NextVersion: McLoginLoader.Input.Type = McLoginType.Legacy AndAlso '离线登录 (Setup.Get("LaunchSkinType") = 2 OrElse '强制 Alex (Setup.Get("LaunchSkinType") = 4 AndAlso Setup.Get("LaunchSkinSlim"))) Then '或选用 Alex 皮肤 - Hint("此 Minecraft 版本尚不支持 Alex 皮肤，你的皮肤可能会显示为 Steve！", HintType.Critical) + Hint("此 Minecraft 版本尚不支持 Alex 皮肤，你的皮肤可能会显示为 Steve！", HintType.Red) End If '离线皮肤资源包 @@ -2125,9 +2130,9 @@ IgnoreCustomSkin: '获取自定义命令 Dim CustomCommandGlobal As String = Setup.Get("LaunchAdvanceRun") - If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal, True) + If CustomCommandGlobal <> "" Then CustomCommandGlobal = ArgumentReplace(CustomCommandGlobal) Dim CustomCommandVersion As String = Setup.Get("VersionAdvanceRun", Version:=McVersionCurrent) - If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion, True) + If CustomCommandVersion <> "" Then CustomCommandVersion = ArgumentReplace(CustomCommandVersion) '输出 bat Try @@ -2159,14 +2164,15 @@ IgnoreCustomSkin: '执行自定义命令 If CustomCommandGlobal <> "" Then McLaunchLog("正在执行全局自定义命令：" & CustomCommandGlobal) - Dim CustomProcess As New Process + Dim CustomProcess As Process = Nothing Try - CustomProcess.StartInfo.FileName = "cmd.exe" - CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandGlobal & """" - CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) - CustomProcess.StartInfo.UseShellExecute = False - CustomProcess.StartInfo.CreateNoWindow = True - CustomProcess.Start() + CustomProcess = StartProcess(New ProcessStartInfo With { + .FileName = "cmd.exe", + .Arguments = $"/c ""{CustomCommandGlobal}""", + .WorkingDirectory = PathMcFolder, + .UseShellExecute = False, + .CreateNoWindow = True + }) If Setup.Get("LaunchAdvanceRunWait") Then Do Until CustomProcess.HasExited OrElse Loader.IsAborted Thread.Sleep(10) @@ -2175,7 +2181,7 @@ IgnoreCustomSkin: Catch ex As Exception Log(ex, "执行全局自定义命令失败", LogLevel.Hint) Finally - If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then + If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183 CustomProcess.Kill() End If @@ -2183,14 +2189,15 @@ IgnoreCustomSkin: End If If CustomCommandVersion <> "" Then McLaunchLog("正在执行版本自定义命令：" & CustomCommandVersion) - Dim CustomProcess As New Process + Dim CustomProcess As Process = Nothing Try - CustomProcess.StartInfo.FileName = "cmd.exe" - CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandVersion & """" - CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) - CustomProcess.StartInfo.UseShellExecute = False - CustomProcess.StartInfo.CreateNoWindow = True - CustomProcess.Start() + CustomProcess = StartProcess(New ProcessStartInfo With { + .FileName = "cmd.exe", + .Arguments = $"/c ""{CustomCommandVersion}""", + .WorkingDirectory = PathMcFolder, + .UseShellExecute = False, + .CreateNoWindow = True + }) If Setup.Get("VersionAdvanceRunWait", Version:=McVersionCurrent) Then Do Until CustomProcess.HasExited OrElse Loader.IsAborted Thread.Sleep(10) @@ -2199,7 +2206,7 @@ IgnoreCustomSkin: Catch ex As Exception Log(ex, "执行版本自定义命令失败", LogLevel.Hint) Finally - If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then + If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183 CustomProcess.Kill() End If @@ -2210,27 +2217,27 @@ IgnoreCustomSkin: Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process)) '启动信息 - Dim GameProcess = New Process() - Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJavaw) + Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263 '设置环境变量 - Dim Paths As New List(Of String)(StartInfo.EnvironmentVariables("Path").Split(";")) + Dim PathEnv As String = StartInfo.EnvironmentVariables("Path") + Dim Paths As New List(Of String) + If Not String.IsNullOrEmpty(PathEnv) Then Paths.AddRange(PathEnv.Split(";")) Paths.Add(ShortenPath(McLaunchJavaSelected.PathFolder)) StartInfo.EnvironmentVariables("Path") = Join(Paths.Distinct.ToList, ";") StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder) '设置其他参数 - StartInfo.WorkingDirectory = ShortenPath(McVersionCurrent.PathIndie) + StartInfo.WorkingDirectory = McVersionCurrent.PathIndie StartInfo.UseShellExecute = False StartInfo.RedirectStandardOutput = True StartInfo.RedirectStandardError = True - StartInfo.CreateNoWindow = False + StartInfo.CreateNoWindow = True StartInfo.Arguments = McLaunchArgument - GameProcess.StartInfo = StartInfo '开始进程 - GameProcess.Start() - McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJavaw) + Dim GameProcess = StartProcess(StartInfo) + McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJava) If Loader.IsAborted Then McLaunchLog("由于取消启动，已强制结束游戏进程") '#1631 GameProcess.Kill() @@ -2283,7 +2290,7 @@ IgnoreCustomSkin: '获取窗口标题 Dim WindowTitle As String = Setup.Get("VersionArgumentTitle", Version:=McVersionCurrent) If WindowTitle = "" Then WindowTitle = Setup.Get("LaunchArgumentTitle") - WindowTitle = ArgumentReplace(WindowTitle, False) + WindowTitle = ArgumentReplace(WindowTitle, ReplaceTime:=False) '初始化等待 Dim Watcher As New Watcher(Loader, McVersionCurrent, WindowTitle) @@ -2332,47 +2339,6 @@ IgnoreCustomSkin: End Sub - ''' - ''' 在启动结束时，对 PCL 约定的替换标记进行处理。 - ''' - Private Function ArgumentReplace(Raw As String, ReplaceTimeAndDate As Boolean) As String - If Raw Is Nothing Then Return Nothing - '路径替换 - Raw = Raw.Replace("{minecraft}", PathMcFolder) - Raw = Raw.Replace("{verpath}", McVersionCurrent.Path) - Raw = Raw.Replace("{verindie}", McVersionCurrent.PathIndie) - Raw = Raw.Replace("{java}", McLaunchJavaSelected.PathFolder) - '普通替换 - 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 - Raw = Raw.Replace("{login}", "联机离线") - Else - Raw = Raw.Replace("{login}", "离线") - End If - Case McLoginType.Ms - Raw = Raw.Replace("{login}", "正版") - Case McLoginType.Nide - Raw = Raw.Replace("{login}", "统一通行证") - Case McLoginType.Auth - Raw = Raw.Replace("{login}", "Authlib-Injector") - End Select - Raw = Raw.Replace("{name}", McVersionCurrent.Name) - If {"unknown", "old", "pending"}.Contains(McVersionCurrent.Version.McName.ToLower) Then - Raw = Raw.Replace("{version}", McVersionCurrent.Name) - Else - Raw = Raw.Replace("{version}", McVersionCurrent.Version.McName) - End If - Raw = Raw.Replace("{path}", Path) - Return Raw - End Function - #End Region End Module diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb index 6c11868..00f2b11 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb @@ -68,7 +68,7 @@ Public Module ModMinecraft For Each Folder As String In Setup.Get("LaunchFolders").Split("|") If Folder = "" Then Continue For If Not Folder.Contains(">") OrElse Not Folder.EndsWithF("\") Then - Hint("无效的 Minecraft 文件夹：" & Folder, HintType.Critical) + Hint("无效的 Minecraft 文件夹：" & Folder, HintType.Red) Continue For End If Dim Name As String = Folder.Split(">")(0) @@ -86,7 +86,7 @@ Public Module ModMinecraft Next If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = Name, .Path = Path, .Type = McFolderType.Custom}) Catch ex As Exception - MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & Path & vbCrLf & vbCrLf & GetExceptionSummary(ex), "Minecraft 文件夹失效", IsWarn:=True) + MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & Path & vbCrLf & vbCrLf & ex.GetBrief(), "Minecraft 文件夹失效", IsWarn:=True) Log(ex, $"无法访问 Minecraft 文件夹 {Path}") End Try Next @@ -261,6 +261,12 @@ Public Module ModMinecraft ''' 显示的描述文本。 ''' Public Info As String = "该版本未被加载，请向作者反馈此问题" + Public ReadOnly Property HasCustomInfo As Boolean + Get + Return ReadIni(Path & "PCL\Setup.ini", "CustomInfo") <> "" + End Get + End Property + ''' ''' 该版本的列表检查原始结果，不受自定义影响。 ''' @@ -695,7 +701,7 @@ Recheck: Catch ex As Exception Log(ex, "依赖版本检查出错（" & Name & "）") State = McVersionState.Error - Info = "未知错误：" & GetExceptionSummary(ex) + Info = "未知错误：" & ex.GetBrief() Return False End Try @@ -784,7 +790,17 @@ ExitDataLoad: End If '确定版本描述 Dim CustomInfo As String = ReadIni(Path & "PCL\Setup.ini", "CustomInfo") - Info = If(CustomInfo <> "", CustomInfo, GetDefaultDescription()) + If CustomInfo <> "" Then + Info = CustomInfo + Else + Info = GetVersionDescription() + If State = McVersionState.Fool Then + Info = GetMcFoolName(Version.McName) + ElseIf State <> McVersionState.Error Then + If Setup.Get("VersionServerLogin", Version:=Me) = 3 Then Info += ", 统一通行证验证" + If Setup.Get("VersionServerLogin", Version:=Me) = 4 Then Info += ", Authlib 验证" + End If + End If '确定版本收藏状态 IsStar = ReadIni(Path & "PCL\Setup.ini", "IsStar", False) '确定版本显示种类 @@ -808,7 +824,7 @@ ExitDataLoad: WriteIni(Path & "PCL\Setup.ini", "VersionOriginalSub", Version.McCodeSub) End If Catch ex As Exception - Info = "未知错误：" & GetExceptionSummary(ex) + Info = "未知错误：" & ex.GetBrief() Logo = PathImage & "Blocks/RedstoneBlock.png" State = McVersionState.Error Log(ex, "加载版本失败（" & Name & "）", LogLevel.Feedback) @@ -817,11 +833,13 @@ ExitDataLoad: End Try Return Me End Function + Public IsLoaded As Boolean = False ''' - ''' 获取版本的默认描述。 + ''' 获取对该版本的简短描述。 + ''' 例如 “快照 16w01a”、“原版 1.12.2”、“愚人节版本 2.0”。 ''' - Public Function GetDefaultDescription() As String - Dim Info As String = "" + Public Function GetVersionDescription() As String + Dim Info As String Select Case State Case McVersionState.Snapshot If Version.McName.ContainsF("pre", True) Then @@ -838,21 +856,38 @@ ExitDataLoad: Case McVersionState.Original, McVersionState.Forge, McVersionState.NeoForge, McVersionState.Fabric, McVersionState.OptiFine, McVersionState.LiteLoader Info = Version.ToString Case McVersionState.Fool - Info = GetMcFoolName(Version.McName) + Info = "愚人节版本 " & Version.McName Case McVersionState.Error Return Me.Info '已有错误信息 Case Else Info = "发生了未知错误，请向作者反馈此问题" End Select - If Not State = McVersionState.Error Then - If Setup.Get("VersionServerLogin", Version:=Me) = 3 Then Info += ", 统一通行证验证" - If Setup.Get("VersionServerLogin", Version:=Me) = 4 Then Info += ", Authlib 验证" - End If Return Info End Function - Public IsLoaded As Boolean = False + Public Function ToListItem() As MyListItem + Dim NewItem As New MyListItem With {.Info = Info, .Height = 42, .Tag = Me, .SnapsToDevicePixels = True, .Type = MyListItem.CheckType.Clickable} + '标题 + NewItem.Inlines.Clear() + NewItem.Inlines.Add(New Run(Name)) + If HasCustomInfo Then '如果版本设置了自定义描述，在标题后面以淡灰色显示其版本号 + NewItem.Inlines.Add(New Run(" | " & GetVersionDescription()) With {.Foreground = New MyColor(215, 215, 215), .FontSize = 12}) + End If + 'Logo + Try + If Logo.EndsWith("PCL\Logo.png") Then + NewItem.Logo = Path & "PCL\Logo.png" '修复老版本中，存储的自定义 Logo 使用完整路径，导致移动后无法加载的 Bug + Else + NewItem.Logo = Logo + End If + Catch ex As Exception + Log(ex, "加载版本图标失败", LogLevel.Hint) + NewItem.Logo = "pack://application:,,,/images/Blocks/RedstoneBlock.png" + End Try + Return NewItem + End Function + '运算符支持 Public Overrides Function Equals(obj As Object) As Boolean Dim version = TryCast(obj, McVersion) Return version IsNot Nothing AndAlso Path = version.Path @@ -865,7 +900,6 @@ ExitDataLoad: Public Shared Operator <>(a As McVersion, b As McVersion) As Boolean Return Not (a = b) End Operator - End Class Public Enum McVersionState [Error] @@ -1186,6 +1220,7 @@ OnLoaded: If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 3000)) Catch ex As ThreadInterruptedException Catch ex As Exception + If Loader.IsAborted Then Return '#5617 WriteIni(Path & "PCL.ini", "VersionCache", "") '要求下次重新加载 Log(ex, "加载 .minecraft 版本列表失败", LogLevel.Feedback) End Try @@ -1566,12 +1601,12 @@ OnLoaded: Try Dim Image As New MyBitmap(FileName) If Image.Pic.Width <> 64 OrElse Not (Image.Pic.Height = 32 OrElse Image.Pic.Height = 64) Then - Hint("皮肤图片大小应为 64x32 像素或 64x64 像素！", HintType.Critical) + Hint("皮肤图片大小应为 64x32 像素或 64x64 像素！", HintType.Red) Return New McSkinInfo With {.IsVaild = False} End If Dim FileInfo As New FileInfo(FileName) If FileInfo.Length > 24 * 1024 Then - Hint("皮肤文件大小需小于 24 KB，而所选文件大小为 " & Math.Round(FileInfo.Length / 1024, 2) & " KB", HintType.Critical) + Hint("皮肤文件大小需小于 24 KB，而所选文件大小为 " & Math.Round(FileInfo.Length / 1024, 2) & " KB", HintType.Red) Return New McSkinInfo With {.IsVaild = False} End If Catch ex As Exception @@ -1592,11 +1627,11 @@ OnLoaded: ''' ''' 获取 Uuid 对应的皮肤文件地址，失败将抛出异常。 ''' - Public Function McSkinGetAddress(Uuid As String, Type As String) As String - If Uuid = "" Then Throw New Exception("Uuid 为空。") - If Uuid.StartsWithF("00000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。") + Public Function McSkinGetAddress(UUID As String, Type As String) As String + If UUID = "" Then Throw New Exception("UUID 为空。") + If UUID.StartsWithF("00000") AndAlso Type <> "Auth" Then Throw New Exception("离线 UUID 无正版皮肤文件：" & UUID) '尝试读取缓存 - Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid) + Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID) If Not CacheSkinAddress = "" Then Return CacheSkinAddress '获取皮肤地址 Dim Url As String @@ -1610,7 +1645,7 @@ OnLoaded: Case Else Throw New ArgumentException("皮肤地址种类无效：" & If(Type, "null")) End Select - Dim SkinString = NetRequestByClientRetry(Url & Uuid) + Dim SkinString = NetRequestByClientRetry(Url & UUID, RequireJson:=True) If SkinString = "" Then Throw New Exception("皮肤返回值为空，可能是未设置自定义皮肤的用户") '处理皮肤地址 Dim SkinValue As String @@ -1635,8 +1670,8 @@ OnLoaded: SkinValue = If(SkinUrl.Contains("minecraft.net/"), SkinUrl.Replace("http://", "https://"), SkinUrl) End If '保存缓存 - WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue) - Log("[Skin] UUID " & Uuid & " 对应的皮肤文件为 " & SkinValue) + WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID, SkinValue) + Log("[Skin] UUID " & UUID & " 对应的皮肤文件为 " & SkinValue) Return SkinValue End Function @@ -1891,17 +1926,29 @@ OnLoaded: .OriginalName = Library("name"), .Url = If(RootUrl, Library("downloads")("classifiers")("natives-windows")("url")), .LocalPath = If(Library("downloads")("classifiers")("natives-windows")("path") Is Nothing, - McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), - CustomMcFolder & "libraries\" & Library("downloads")("classifiers")("natives-windows")("path").ToString.Replace("/", "\")), + McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), + $"{CustomMcFolder}libraries\{Library("downloads")("classifiers")("natives-windows")("path").ToString.Replace("/", "\")}"), .Size = Val(Library("downloads")("classifiers")("natives-windows")("size").ToString), .IsNatives = True, .SHA1 = Library("downloads")("classifiers")("natives-windows")("sha1").ToString}) Else - BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing}) + BasicArray.Add( + New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .Size = 0, .IsNatives = True, .SHA1 = Nothing, + .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", $"-{Library("natives")("windows")}.jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")) + }) End If Catch ex As Exception Log(ex, "处理实际支持库列表失败（有 Natives，" & If(Library("name"), "Nothing").ToString & "）") - BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing}) + BasicArray.Add( + New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .Size = 0, .IsNatives = True, .SHA1 = Nothing, + .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder). + Replace(".jar", $"-{Library("natives")("windows")}.jar"). + Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")) + }) End Try End If @@ -1966,7 +2013,7 @@ OnLoaded: Try Log("[Minecraft] 开始获取统一通行证下载信息") '测试链接：https://auth.mc-user.com:233/00000000000000000000000000000000/ - DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version))) + DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version), RequireJson:=True)) Catch ex As Exception Log(ex, "获取统一通行证下载信息失败") End Try @@ -1983,16 +2030,20 @@ OnLoaded: 'Authlib-Injector 文件 If Setup.Get("VersionServerLogin", Version:=Version) = 4 Then - Dim TargetFile = PathPure & "\authlib-injector.jar" + Dim TargetFile = PathPure & "authlib-injector.jar" Dim DownloadInfo As JObject = Nothing '获取下载信息 Try Log("[Minecraft] 开始获取 Authlib-Injector 下载信息") DownloadInfo = GetJson(NetRequestByClientRetry( "https://authlib-injector.yushi.moe/artifact/latest.json", - BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json")) + BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json", RequireJson:=True)) Catch ex As Exception - Log(ex, "获取 Authlib-Injector 下载信息失败") + If File.Exists(TargetFile) Then + Log(ex, "获取 Authlib-Injector 下载信息失败") + Else + Throw New Exception("获取 Authlib-Injector 下载信息失败", ex) + End If End Try '校验文件 If DownloadInfo IsNot Nothing Then @@ -2091,19 +2142,12 @@ OnLoaded: ''' 是否包含 Lib 文件夹头部，若不包含，则会类似以 com\xxx\ 开头。 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) + '有时候原始的有四段，例如 net.minecraftforge:forge:1.21.4-54.0.34:client + '文件夹名应该忽略最后一段（client），但文件名需要保留 + '参见 #7306（以及 #5376 也是因为这里没有处理好导致的） Dim Splited = Original.Split(":") McLibGet = If(WithHead, CustomMcFolder & "libraries\", "") & - Splited(0).Replace(".", "\") & "\" & Splited(1) & "\" & Splited(2) & "\" & Splited(1) & "-" & Splited(2) & ".jar" - '判断 OptiFine 是否应该使用 installer - If McLibGet.Contains("optifine\OptiFine\1.") AndAlso Splited(2).Split(".").Count > 1 Then - Dim MajorVersion As Integer = Val(Splited(2).Split(".")(1).BeforeFirst("_")) - Dim MinorVersion As Integer = If(Splited(2).Split(".").Count > 2, Val(Splited(2).Split(".")(2).BeforeFirst("_")), 0) - If (MajorVersion = 12 OrElse (MajorVersion = 20 AndAlso MinorVersion >= 4) OrElse MajorVersion >= 21) AndAlso '仅在 1.12 (无法追溯) 和 1.20.4+ (#5376) 遇到此问题 - File.Exists($"{CustomMcFolder}libraries\{Splited(0).Replace(".", "\")}\{Splited(1)}\{Splited(2)}\{Splited(1)}-{Splited(2)}-installer.jar") Then - McLaunchLog("已将 " & Original & " 替换为对应的 Installer 文件") - McLibGet = McLibGet.Replace(".jar", "-installer.jar") - End If - End If + $"{Splited(0).Replace(".", "\")}\{Splited(1)}\{Splited(2)}\{Splited.Skip(1).Join("-")}.jar" End Function ''' @@ -2415,7 +2459,12 @@ NextEntry: Public Function FilterUserName(Raw As String, FilterChar As Char) As String If Raw.Contains(":\Users\") Then For Each Token In RegexSearch(Raw, "(?<=:\\Users\\)[^\\]+") - Raw = Raw.Replace("\" & Token, "\" & New String(FilterChar, Token.Count)) + Raw = Raw.Replace("\Users\" & Token, "\Users\" & New String(FilterChar, Token.Count)) + Next + End If + If Raw.Contains(":/Users/") Then + For Each Token In RegexSearch(Raw, "(?<=:/Users/)[^/]+") + Raw = Raw.Replace("/Users/" & Token, "/Users/" & New String(FilterChar, Token.Count)) Next End If Return Raw diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb index e6225e4..764bafb 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb @@ -73,7 +73,7 @@ Public Module ModMod Get If _Name Is Nothing Then Load() If _Name Is Nothing Then _Name = _ModId - If _Name Is Nothing Then _Name = GetFileNameWithoutExtentionFromPath(Path) + If _Name Is Nothing Then _Name = IO.Path.GetFileNameWithoutExtension(Path) Return _Name End Get Set(value As String) @@ -688,7 +688,7 @@ Finished: ''' Public ReadOnly Property CanUpdate As Boolean Get - Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso ChangelogUrls.Any() + Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso Not Setup.Get("VersionAdvanceDisableModUpdate", Version:=PageVersionLeft.Version) AndAlso ChangelogUrls.Any() End Get End Property @@ -1113,8 +1113,8 @@ Finished: End Sub, "Mod List Detail Loader CurseForge") '等待线程结束 Do Until EndedThreadCount = 2 - If Loader.IsAborted Then Return Thread.Sleep(10) + If Loader.IsAborted Then Return Loop '保存缓存 Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList() @@ -1126,6 +1126,7 @@ Finished: Next WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None))) '刷新边栏 + If Loader.IsAborted Then Return If FrmVersionMod?.Filter = PageVersionMod.FilterType.CanUpdate Then RunInUi(Sub() FrmVersionMod?.RefreshUI()) '同步 “可更新” 列表 (#4677) Else @@ -1212,7 +1213,7 @@ Finished: If ReqVersionHead = ReqVersionTail Then VersionRequire = "应为 " & ReqVersionHead ElseIf ReqVersionHead.Contains(".") AndAlso ReqVersionTail.Contains(".") Then - VersionRequire = "应为 " & ReqVersionHead & " 至 " & ReqVersionTail + VersionRequire = $"应为 {ReqVersionHead} 至 {ReqVersionTail}" ElseIf ReqVersionHead.Contains(".") Then If ReqVersionHeadCanEqual Then VersionRequire = "最低应为 " & ReqVersionHead @@ -1230,7 +1231,7 @@ Finished: End If '检查前置 Mod 是否存在，并获取其版本 If Not CurrentDependencies.ContainsKey(ReqId) Then - Result.Add("缺少前置 Mod：" & ReqId & If(VersionRequire = "", "", "，其版本" & VersionRequire) & "。" & vbCrLf & " - " & ModEntity.FileName) + Result.Add($"缺少前置 Mod：{ReqId}{If(VersionRequire = "", "", "，其版本" & VersionRequire)}。{vbCrLf} - {ModEntity.FileName}") Continue For End If Dim CurrentVersion As String = If(CurrentDependencies(ReqId)(0), "0.0") @@ -1239,7 +1240,7 @@ Finished: If ReqVersionHead.Contains(".") Then If VersionSortInteger(ReqVersionHead, CurrentVersion) > If(ReqVersionHeadCanEqual, 0, -1) Then Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过低，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf & - " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), "")) + " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置：{CurrentDependencies(ReqId)(1)}", "")) Continue For End If End If @@ -1247,26 +1248,26 @@ Finished: If ReqVersionTail.Contains(".") Then If VersionSortInteger(CurrentVersion, ReqVersionTail) > If(ReqVersionTailCanEqual, 0, -1) Then Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过高，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf & - " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), "")) + " - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置：{CurrentDependencies(ReqId)(1)}", "")) Continue For End If End If Else If Not CurrentDependencies.ContainsKey(Dependency.Key) Then - Result.Add("缺少前置 Mod：" & Dependency.Key & "。" & vbCrLf & " - " & ModEntity.FileName) + Result.Add($"缺少前置 Mod：{Dependency.Key}。{vbCrLf} - {ModEntity.FileName}") Continue For End If End If Next Catch ex As Exception - Result.Add("检查 Mod 时出错：" & GetExceptionSummary(ex) & vbCrLf & " - " & ModEntity.FileName) + Result.Add($"检查 Mod 时出错：{ex.GetBrief()}{vbCrLf} - {ModEntity.FileName}") Log(ex, "检查 Mod 时出错") End Try Next If Not Result.Any() Then Log("[Minecraft] Mod 检查未发现异常") Else - Log("[Minecraft] Mod 检查异常结果：" & vbCrLf & Join(Result, vbCrLf)) + Log($"[Minecraft] Mod 检查异常结果：{vbCrLf}{Join(Result, vbCrLf)}") End If Return Result End Function diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb index d1de713..5769826 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb @@ -31,7 +31,7 @@ Public Module ModModpack Try '字符校验 Dim TargetFolder As String = $"{PathMcFolder}versions\{VersionName}\" - If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("游戏路径中不能含有感叹号或分号：" & TargetFolder, HintType.Critical) : Throw New CancelledException + If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("游戏路径中不能含有感叹号或分号：" & TargetFolder, HintType.Red) : Throw New CancelledException '获取整合包种类与关键 Json Dim PackType As Integer = -1 Try @@ -72,7 +72,7 @@ Public Module ModModpack If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包 Next Catch ex As Exception - If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then + If ex.GetDetail(True).Contains("Error.WinIOError") Then Throw New Exception("打开整合包文件失败", ex) ElseIf File.EndsWithF(".rar", True) Then Throw New Exception("PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", ex) @@ -158,6 +158,7 @@ Retry: If File.Exists(OverridesIni) Then WriteIni(OverridesIni, "VersionArgumentIndie", 1) '开启版本隔离 WriteIni(OverridesIni, "VersionArgumentIndieV2", True) + WriteIni(OverridesIni, "IsStar", False) CopyFile(OverridesIni, VersionIni) '覆写已有的 ini Else WriteIni(VersionIni, "VersionArgumentIndie", 1) '开启版本隔离 @@ -165,6 +166,15 @@ Retry: End If IniClearCache(VersionIni) '重置缓存，避免被安装过程中写入的 ini 覆盖 End Sub + ''' + ''' 弹窗提示整合包中存在不兼容的加载器。 + ''' 如果取消，则抛出 CancelledException。 + ''' + ''' + Private Sub NotifyIncompatibleLoader(LoaderName As String) + If MyMsgBox($"整合包中存在不兼容的加载器：{LoaderName}{vbCrLf}如果你知道如何手动安装它，可以先选择跳过，然后在整合包下载结束后手动安装。", + "不兼容的加载器", "取消", $"不安装 {LoaderName} 并继续") = 1 Then Throw New CancelledException + End Sub #Region "不同类型整合包的安装方法" @@ -210,7 +220,8 @@ Retry: Log("[ModPack] 整合包 Fabric 版本：" & Id) FabricVersion = Id.Replace("fabric-", "") Else - Log("[ModPack] 未知 Mod 加载器：" & Id) + 'ElseIf Id.StartsWithF("quilt-") Then + NotifyIncompatibleLoader(Id) End If Next '解压 @@ -324,7 +335,7 @@ Retry: File.Delete(Target) End If Next - If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then + If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then Log("[ModPack] 删除安装整合包文件：" & FileAddress) File.Delete(FileAddress) End If @@ -333,7 +344,7 @@ Retry: '重复任务检查 Dim LoaderName As String = "CurseForge 整合包安装：" & VersionName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If @@ -375,12 +386,9 @@ Retry: Case "fabric-loader" 'eg. 0.14.14 FabricVersion = Entry.Value.ToString Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion) - Case "quilt-loader" 'eg. 1.0.0 - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) - Throw New CancelledException Case Else - Hint($"无法安装整合包，其中出现了未知的 Mod 加载器 {Entry.Value}！", HintType.Critical) - Throw New CancelledException + 'Case "quilt-loader" 'eg. 1.0.0 + NotifyIncompatibleLoader(Entry.Name) End Select Next '获取版本名 @@ -468,7 +476,7 @@ Retry: File.Delete(Target) End If Next - If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then + If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then Log("[ModPack] 删除安装整合包文件：" & FileAddress) File.Delete(FileAddress) End If @@ -477,7 +485,7 @@ Retry: '重复任务检查 Dim LoaderName As String = $"Modrinth 整合包安装：{VersionName} " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If @@ -532,7 +540,7 @@ Retry: '重复任务检查 Dim LoaderName As String = "HMCL 整合包安装：" & VersionName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If '启动 @@ -631,8 +639,9 @@ Retry: '构造版本安装请求 If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息，无法安装！") Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"} - For Each Component In PackJson("components") - Select Case If(Component("uid"), "").ToString + For Each Component As JObject In PackJson("components") + If Not Component.ContainsKey("uid") Then Continue For + Select Case Component("uid").ToString Case "org.lwjgl" Log("[ModPack] 已跳过 LWJGL 项") Case "net.minecraft" @@ -643,9 +652,9 @@ Retry: Request.NeoForgeVersion = Component("version") Case "net.fabricmc.fabric-loader" Request.FabricVersion = Component("version") - Case "org.quiltmc.quilt-loader" 'eg. 1.0.0 - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) - Throw New CancelledException + Case Else + 'Case "org.quiltmc.quilt-loader" 'eg. 1.0.0 + NotifyIncompatibleLoader(Component("uid")) End Select Next '构造加载器 @@ -658,7 +667,7 @@ Retry: '重复任务检查 Dim LoaderName As String = "MMC 整合包安装：" & VersionName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If @@ -716,7 +725,7 @@ Retry: Next If Not Addons.ContainsKey("game") Then Throw New Exception("该 MCBBS 整合包未提供游戏版本信息，无法安装！") If Addons.ContainsKey("quilt") Then - Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical) + Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Red) Throw New CancelledException End If Dim Request As New McInstallRequest With { @@ -737,7 +746,7 @@ Retry: '重复任务检查 Dim LoaderName As String = "MCBBS 整合包安装：" & VersionName & " " If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then - Hint("该整合包正在安装中！", HintType.Critical) + Hint("该整合包正在安装中！", HintType.Red) Throw New CancelledException End If @@ -757,7 +766,7 @@ Retry: MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True) Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）") If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException - If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Throw New CancelledException + If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException '解压 Dim Loader As New LoaderCombo(Of String)("解压压缩包", { New LoaderTask(Of String, Integer)("解压压缩包", @@ -786,7 +795,7 @@ Retry: Log("[Modpack] 找到压缩包中附带的启动器：" & Launcher) If MyMsgBox($"整合包里似乎自带了启动器，是否换用它继续安装？{vbCrLf}即将打开：{Launcher}", "换用整合包启动器？", "换用", "不换用") = 1 Then OpenExplorer(TargetFolder) - ShellOnly(Launcher, "--wait") '要求等待已有的 PCL 退出 + StartProcess(Launcher, "--wait") '要求等待已有的 PCL 退出 Log("[Modpack] 为换用整合包中的启动器启动，强制结束程序") FrmMain.EndProgram(False) Return @@ -834,8 +843,8 @@ Retry: MyMsgBox("接下来请选择一个空文件夹，它会被安装到这个文件夹里。", "安装", "继续", ForceWait:=True) Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）") If String.IsNullOrEmpty(TargetFolder) Then Throw New CancelledException - If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Throw New CancelledException - If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Throw New CancelledException + If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Red) : Throw New CancelledException + If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Red) : Throw New CancelledException '解压 Dim Loader As New LoaderCombo(Of String)("解压压缩包", { New LoaderTask(Of String, Integer)("解压压缩包", diff --git a/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb b/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb index c4f08a4..d6259a0 100644 --- a/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb +++ b/Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb @@ -349,7 +349,7 @@ State = MinecraftState.Crashed '崩溃分析 WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析") - Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Critical) + Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Red) FeedbackInfo() RunInNewThread( Sub() diff --git a/Plain Craft Launcher 2/Modules/ModEvent.vb b/Plain Craft Launcher 2/Modules/ModEvent.vb index 87e9bf5..06204f9 100644 --- a/Plain Craft Launcher 2/Modules/ModEvent.vb +++ b/Plain Craft Launcher 2/Modules/ModEvent.vb @@ -1,129 +1,305 @@ -Public Module ModEvent + +#Region "附加属性" - Public Sub TryStartEvent(Type As String, Data As String) - If String.IsNullOrWhiteSpace(Type) Then Return - Dim RealData As String() = {""} - If Data IsNot Nothing Then RealData = Data.Split("|") - StartEvent(Type, RealData) +''' +''' 用于在 XAML 中初始化列表对象。 +''' 附加属性无法在 XAML 中为每个对象初始化独立的列表对象，因此需要一个包装类，然后在 XAML 中显式初始化。 +''' + +Public Class CustomEventCollection + Implements IEnumerable(Of CustomEvent) + Dim _Events As New List(Of CustomEvent) + Public ReadOnly Property Events As List(Of CustomEvent) + Get + Return _Events + End Get + End Property + Public Function GetEnumerator() As IEnumerator(Of CustomEvent) Implements IEnumerable(Of CustomEvent).GetEnumerator + Return DirectCast(Events, IEnumerable(Of CustomEvent)).GetEnumerator() + End Function + Private Function IEnumerable_GetEnumerator() As IEnumerator Implements IEnumerable.GetEnumerator + Return DirectCast(Events, IEnumerable).GetEnumerator() + End Function +End Class + +''' +''' 提供自定义事件的附加属性。 +''' +Public Class CustomEventService + + 'Events + Public Shared ReadOnly EventsProperty As DependencyProperty = + DependencyProperty.RegisterAttached("Events", GetType(CustomEventCollection), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEvents(d As DependencyObject, value As CustomEventCollection) + d.SetValue(EventsProperty, value) End Sub - Public Sub StartEvent(Type As String, Data As String()) + + Public Shared Function GetEvents(d As DependencyObject) As CustomEventCollection + If d.GetValue(EventsProperty) Is Nothing Then d.SetValue(EventsProperty, New CustomEventCollection) + Return d.GetValue(EventsProperty) + End Function + + 'EventType + Public Shared ReadOnly EventTypeProperty As DependencyProperty = + DependencyProperty.RegisterAttached("EventType", GetType(CustomEvent.EventType), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEventType(d As DependencyObject, value As CustomEvent.EventType) + d.SetValue(EventTypeProperty, value) + End Sub + + Public Shared Function GetEventType(d As DependencyObject) As CustomEvent.EventType + Return d.GetValue(EventTypeProperty) + End Function + + 'EventData + Public Shared ReadOnly EventDataProperty As DependencyProperty = + DependencyProperty.RegisterAttached("EventData", GetType(String), GetType(CustomEventService), New PropertyMetadata(Nothing)) + + Public Shared Sub SetEventData(d As DependencyObject, value As String) + d.SetValue(EventDataProperty, value) + End Sub + + Public Shared Function GetEventData(d As DependencyObject) As String + Return d.GetValue(EventDataProperty) + End Function + +End Class + +Partial Public Module ModMain + + ''' + ''' 触发该控件上的自定义事件。 + ''' 事件会在新线程中执行。 + ''' + + Public Sub RaiseCustomEvent(Control As DependencyObject) + '收集事件列表 + Dim Events = CustomEventService.GetEvents(Control).ToList + Dim EventType = CustomEventService.GetEventType(Control) + If EventType <> CustomEvent.EventType.None Then Events.Add(New CustomEvent(EventType, CustomEventService.GetEventData(Control))) + '执行事件 + If Not Events.Any Then Return + RunInNewThread( + Sub() + For Each e In Events + e.Raise() + Next + End Sub, "执行自定义事件 " & GetUuid()) + End Sub + +End Module + +#End Region + +''' +''' 自定义事件。 +''' +Public Class CustomEvent + +#Region "属性与触发" + + Public Property Type As EventType = EventType.None + Public Property Data As String = Nothing + Public Sub New() + End Sub + Public Sub New(Type As EventType, Data As String) + Me.Type = Type + Me.Data = Data + End Sub + + ''' + ''' 在当前线程中触发该自定义事件。 + ''' + Public Sub Raise() + Raise(Type, Data) + End Sub + +#End Region + + Public Enum EventType + None = 0 + 打开网页 + 打开文件 + 打开帮助 + 执行命令 + 启动游戏 + 复制文本 + 刷新主页 + 刷新页面 + 刷新帮助 + 今日人品 + 内存优化 + 清理垃圾 + 弹出窗口 + 弹出提示 + 切换页面 + 导入整合包 + 安装整合包 + 下载文件 + 修改设置 + 写入设置 + 修改变量 + 写入变量 + 加入房间 + End Enum + + ''' + ''' 在当前线程中触发一个自定义事件。 + ''' + Public Shared Sub Raise(Type As EventType, Arg As String) + If Type = EventType.None Then Return + Log($"[Control] 执行自定义事件：{Type}, {Arg}") Try - Log("[Control] 执行自定义事件：" & Type & ", " & Join(Data, ", ")) + Dim Args As String() = If(Arg?.Split("|"), {""}) Select Case Type - Case "打开网页" - Data(0) = Data(0).Replace("\", "/") - If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议（#2200） + Case EventType.打开网页 + Arg = Arg.Replace("\", "/") + If Not Arg.Contains("://") OrElse Arg.StartsWithF("file", True) Then '为了支持更多协议（#2200） MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败") Return End If - Hint("正在开启中，请稍候……") - OpenWebsite(Data(0)) + Hint("正在开启中，请稍候：" & Arg) + RunInThread(Sub() OpenWebsite(Arg)) - Case "打开文件", "打开帮助", "执行命令" + Case EventType.打开文件, EventType.打开帮助, EventType.执行命令 RunInThread( Sub() Try '确认实际路径 - Dim ActualPaths = GetEventAbsoluteUrls(Data(0), Type) + Dim ActualPaths = GetAbsoluteUrls(Args(0), Type) Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1) Log($"[Control] 打开类自定义事件实际路径：{Location}，工作目录：{WorkingDir}") '执行 - If Type = "打开帮助" Then + If Type = EventType.打开帮助 Then PageOtherHelp.EnterHelpPage(Location) Else - If Not Setup.Get("HintCustomCommand") Then - Select Case MyMsgBox( - "即将执行：" & Location & If(Data.Length >= 2, " " & Data(1), "") & vbCrLf & - "请在确认该操作没有安全隐患后继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消") - Case 2 - Setup.Set("HintCustomCommand", True) - Case 3 - Return - End Select - End If + If Not EventSafetyConfirm("即将执行：" & Location & If(Args.Length >= 2, " " & Args(1), "")) Then Return Dim Info As New ProcessStartInfo With { - .Arguments = If(Data.Length >= 2, Data(1), ""), + .Arguments = If(Args.Length >= 2, Args(1), ""), .FileName = Location, - .WorkingDirectory = ShortenPath(WorkingDir) + .WorkingDirectory = WorkingDir } - Process.Start(Info) + StartProcess(Info) End If Catch ex As Exception Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox) End Try End Sub) - Case "启动游戏" - If Data(0) = "\current" Then + Case EventType.启动游戏 + If Args(0) = "\current" Then If McVersionCurrent Is Nothing Then - Hint("请先选择一个 Minecraft 版本！", HintType.Critical) + Hint("请先选择一个 Minecraft 版本！", HintType.Red) Return Else - Data(0) = McVersionCurrent.Name + Args(0) = McVersionCurrent.Name End If End If - If McLaunchStart(New McLaunchOptions With - {.ServerIp = If(Data.Length >= 2, Data(1), Nothing), .Version = New McVersion(Data(0))}) Then - Hint("正在启动 " & Data(0) & "……") + RunInUi( + Sub() + If McLaunchStart(New McLaunchOptions With + {.ServerIp = If(Args.Length >= 2, Args(1), Nothing), .Version = New McVersion(Args(0))}) Then + Hint($"正在启动 {Args(0)}……") + End If + End Sub) + + Case EventType.复制文本 + ClipboardSet(Arg) + + Case EventType.刷新主页 + RunInUi( + Sub() + FrmLaunchRight.ForceRefresh() + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) + End Sub) + + Case EventType.刷新页面 + If TypeOf FrmMain.PageRight Is IRefreshable Then + RunInUiWait(Sub() CType(FrmMain.PageRight, IRefreshable).Refresh()) + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) + Else + Hint("当前页面不支持刷新操作！", HintType.Red) End If - Case "复制文本" - ClipboardSet(Join(Data, "|")) + Case EventType.刷新帮助 + RunInUiWait(Sub() PageOtherLeft.RefreshHelp()) + If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green) - Case "刷新主页" - FrmLaunchRight.ForceRefresh() - If Data(0) = "" Then Hint("已刷新主页！", HintType.Finish) - - Case "刷新帮助" - PageOtherLeft.RefreshHelp() - - Case "今日人品" + Case EventType.今日人品 PageOtherTest.Jrrp() - Case "内存优化" + Case EventType.内存优化 RunInThread(Sub() PageOtherTest.MemoryOptimize(True)) - Case "清理垃圾" + Case EventType.清理垃圾 RunInThread(Sub() PageOtherTest.RubbishClear()) - Case "弹出窗口" - MyMsgBox(Data(1).Replace("\n", vbCrLf), Data(0).Replace("\n", vbCrLf)) + Case EventType.弹出窗口 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 弹窗标题|弹窗内容") + MyMsgBox(Args(1).Replace("\n", vbCrLf), Args(0).Replace("\n", vbCrLf), If(Args.Length > 2, Args(2), "确定")) - Case "切换页面" - FrmMain.PageChange(Val(Data(0)), Val(Data(1))) + Case EventType.弹出提示 + Hint(Args(0).Replace("\n", vbCrLf), If(Args.Length = 1, HintType.Blue, Args(1).ParseToEnum(Of HintType))) - Case "导入整合包", "安装整合包" + Case EventType.切换页面 + RunInUi(Sub() FrmMain.PageChange( + Args(0).ParseToEnum(Of FormMain.PageType), + If(Args.Length = 1, FormMain.PageSubType.Default, Args(1).ParseToEnum(Of FormMain.PageSubType)))) + + Case EventType.导入整合包, EventType.安装整合包 RunInUi(Sub() ModpackInstall()) - Case "下载文件" - Data(0) = Data(0).Replace("\", "/") - If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then + Case EventType.下载文件 + Args(0) = Args(0).Replace("\", "/") + If Not (Args(0).StartsWithF("http://", True) OrElse Args(0).StartsWithF("https://", True)) Then MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败") Return End If - Try - Select Case Data.Length - Case 1 - PageOtherTest.StartCustomDownload(Data(0), GetFileNameFromPath(Data(0))) - Case 2 - PageOtherTest.StartCustomDownload(Data(0), Data(1)) - Case Else - PageOtherTest.StartCustomDownload(Data(0), Data(1), Data(2)) - End Select - Catch - PageOtherTest.StartCustomDownload(Data(0), "未知") - End Try + If Not EventSafetyConfirm("即将从该网址下载文件：" & vbCrLf & Args(0)) Then Return + RunInUi( + Sub() + Try + Select Case Args.Length + Case 1 + PageOtherTest.StartCustomDownload(Args(0), GetFileNameFromPath(Args(0))) + Case 2 + PageOtherTest.StartCustomDownload(Args(0), Args(1)) + Case Else + PageOtherTest.StartCustomDownload(Args(0), Args(1), Args(2)) + End Select + Catch + PageOtherTest.StartCustomDownload(Args(0), "未知") + End Try + End Sub) - Case "修改设置" - Setup.Set(Data(0), Data(1)) - Hint($"已写入设置：{Data(0)} → {Data(1)}", HintType.Finish) + Case EventType.修改设置, EventType.写入设置 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 UiLauncherTransparent|400") + Setup.SetSafe(Args(0), Args(1), Version:=McVersionCurrent) + If Args.Length = 2 Then Hint($"已写入设置：{Args(0)} → {Args(1)}", HintType.Green) + + Case EventType.修改变量, EventType.写入变量 + If Args.Length = 1 Then Throw New Exception($"EventType {Type} 需要至少 2 个以 | 分割的参数，例如 VariableName|SomeValue") + WriteReg("CustomEvent" & Args(0), Args(1)) + If Args.Length = 2 Then Hint($"已写入变量：{Args(0)} → {Args(1)}", HintType.Green) + + Case EventType.加入房间 + RunInUi( + Sub() + If String.IsNullOrWhiteSpace(Arg) Then + PageLinkMain.Join() + Else + If Not EventSafetyConfirm("即将加入第三方联机房间。") Then Return + PageLinkMain.Join(Arg) + End If + End Sub) Case Else MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败") End Select Catch ex As Exception - Log(ex, "事件执行失败", LogLevel.Msgbox) + Log(ex, $"事件执行失败（{Type}, {Arg}）", LogLevel.Msgbox) End Try End Sub @@ -131,7 +307,7 @@ ''' 返回自定义事件的绝对 Url。实际返回 {绝对 Url, WorkingDir}。 ''' 失败会抛出异常。 ''' - Public Function GetEventAbsoluteUrls(RelativeUrl As String, EventType As String) As String() + Public Shared Function GetAbsoluteUrls(RelativeUrl As String, Type As EventType) As String() '网页确认 If RelativeUrl.StartsWithF("http", True) Then @@ -172,25 +348,25 @@ If RelativeUrl.Contains(":\") Then '绝对路径 Location = RelativeUrl - Log("[Control] 自定义事件中由绝对路径" & EventType & "：" & Location) + Log("[Control] 自定义事件中由绝对路径" & Type & "：" & Location) ElseIf File.Exists(Path & "PCL\" & RelativeUrl) Then '相对 PCL 文件夹的路径 Location = Path & "PCL\" & RelativeUrl - Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & EventType & "：" & Location) + Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & Type & "：" & Location) ElseIf File.Exists(Path & "PCL\Help\" & RelativeUrl) Then '相对 PCL 本地帮助文件夹的路径 Location = Path & "PCL\Help\" & RelativeUrl WorkingDir = Path & "PCL\Help\" - Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & EventType & "：" & Location) - ElseIf EventType = "打开帮助" AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then + Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & Type & "：" & Location) + ElseIf Type = EventType.打开帮助 AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then '相对 PCL 自带帮助文件夹的路径 Location = PathTemp & "Help\" & RelativeUrl WorkingDir = PathTemp & "Help\" - Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & EventType & "：" & Location) - ElseIf EventType = "打开文件" OrElse EventType = "执行命令" Then + Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & Type & "：" & Location) + ElseIf Type = EventType.打开文件 OrElse Type = EventType.执行命令 Then '直接使用原有路径启动程序 Location = RelativeUrl - Log("[Control] 自定义事件中直接" & EventType & "：" & Location) + Log("[Control] 自定义事件中直接" & Type & "：" & Location) Else '打开帮助，但是格式不对劲 Throw New FileNotFoundException("未找到 EventData 指向的本地 xaml 文件：" & RelativeUrl, RelativeUrl) @@ -199,4 +375,20 @@ Return {Location, WorkingDir} End Function -End Module + ''' + ''' 弹出安全确认弹窗。返回是否继续执行。 + ''' + Private Shared Function EventSafetyConfirm(Message As String) As Boolean + If Setup.Get("HintCustomCommand") Then Return True + Select Case MyMsgBox(Message & vbCrLf & "请在确认没有安全隐患后再继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消") + Case 1 + Return True + Case 2 + Setup.Set("HintCustomCommand", True) + Return True + Case Else + Return False + End Select + End Function + +End Class diff --git a/Plain Craft Launcher 2/Modules/ModMain.vb b/Plain Craft Launcher 2/Modules/ModMain.vb index 2ceb04c..c8c325c 100644 --- a/Plain Craft Launcher 2/Modules/ModMain.vb +++ b/Plain Craft Launcher 2/Modules/ModMain.vb @@ -7,23 +7,12 @@ Public Module ModMain ''' ''' 提示信息的种类。 + ''' 该枚举在自定义事件中使用，是公开 API 的一部分。 ''' Public Enum HintType - ''' - ''' 信息，通常是蓝色的“i”。 - ''' - ''' - Info - ''' - ''' 已完成，通常是绿色的“√”。 - ''' - ''' - Finish - ''' - ''' 错误，通常是红色的“×”。 - ''' - ''' - Critical + Blue + Green + Red End Enum Private Structure HintMessage Public Text As String @@ -38,7 +27,7 @@ Public Module ModMain ''' ''' 在窗口左下角弹出提示文本。 ''' - Public Sub Hint(Text As String, Optional Type As HintType = HintType.Info, Optional Log As Boolean = True) + Public Sub Hint(Text As String, Optional Type As HintType = HintType.Blue, Optional Log As Boolean = True) If HintWaiting Is Nothing Then HintWaiting = New SafeList(Of HintMessage) HintWaiting.Add(New HintMessage With {.Text = If(Text, ""), .Type = Type, .Log = Log}) End Sub @@ -68,13 +57,13 @@ Public Module ModMain Dim TargetColor0, TargetColor1 As MyColor Dim Percent As Double = 0.3 Select Case CurrentHint.Type - Case HintType.Info + Case HintType.Blue TargetColor0 = New MyColor(215, 37, 155, 252) TargetColor1 = New MyColor(215, 10, 142, 252) - Case HintType.Finish + Case HintType.Green TargetColor0 = New MyColor(215, 33, 177, 33) TargetColor1 = New MyColor(215, 29, 160, 29) - Case Else 'HintType.Critical + Case Else 'HintType.Red TargetColor0 = New MyColor(215, 255, 53, 11) TargetColor1 = New MyColor(215, 255, 43, 0) End Select @@ -248,10 +237,6 @@ EndHint: '将弹窗列入队列 Dim Converter As New MyMsgBoxConverter With {.Type = MyMsgBoxType.Text, .Button1 = Button1, .Button2 = Button2, .Button3 = Button3, .Text = Caption, .IsWarn = IsWarn, .Title = Title, .HighLight = HighLight, .ForceWait = True, .Button1Action = Button1Action, .Button2Action = Button2Action, .Button3Action = Button3Action} WaitingMyMsgBox.Add(Converter) - If RunInUi() Then - '若为 UI 线程，立即执行弹窗刻， 避免快速（连点器）点击时多次弹窗 - MyMsgBoxTick() - End If If Button2.Length > 0 OrElse ForceWait Then '若有多个按钮则开始等待 If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing AndAlso RunInUi() Then @@ -275,6 +260,7 @@ EndHint: Else Try FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -306,6 +292,7 @@ EndHint: '虽然我也不知道这是啥但是能用就成了 :) Try If FrmMain IsNot Nothing Then FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -328,6 +315,7 @@ EndHint: '虽然我也不知道这是啥但是能用就成了 :) Try If FrmMain IsNot Nothing Then FrmMain.DragStop() + If RunInUi() Then MyMsgBoxTick() ComponentDispatcher.PushModal() Dispatcher.PushFrame(Converter.WaitFrame) Finally @@ -350,7 +338,7 @@ EndHint: ElseIf WaitingMyMsgBox.Any Then '没有弹窗，显示一个等待的弹窗 FrmMain.PanMsg.Visibility = Visibility.Visible - Select Case CType(WaitingMyMsgBox(0), MyMsgBoxConverter).Type + Select Case WaitingMyMsgBox(0).Type Case MyMsgBoxType.Input FrmMain.PanMsg.Children.Add(New MyMsgInput(WaitingMyMsgBox(0))) Case MyMsgBoxType.Select @@ -363,7 +351,7 @@ EndHint: WaitingMyMsgBox.RemoveAt(0) Else '没有弹窗，没有等待的弹窗 - If Not FrmMain.PanMsg.Visibility = Visibility.Collapsed Then FrmMain.PanMsg.Visibility = Visibility.Collapsed + If FrmMain.PanMsg.Visibility <> Visibility.Collapsed Then FrmMain.PanMsg.Visibility = Visibility.Collapsed End If Catch ex As Exception Log(ex, "处理等待中的弹窗失败", LogLevel.Feedback) @@ -388,21 +376,11 @@ EndHint: Public FrmSpeedRight As PageSpeedRight '联机页面声明 - Public FrmLinkLeft As PageLinkLeft - Public FrmLinkIoi As PageLinkIoi - Public FrmLinkHiper As PageLinkHiper - Public FrmLinkHelp As PageOtherHelpDetail - Public FrmLinkFeedback As PageLinkFeedback + Public FrmLinkMain As PageLinkMain '下载页面声明 Public FrmDownloadLeft As PageDownloadLeft Public FrmDownloadInstall As PageDownloadInstall - Public FrmDownloadClient As PageDownloadClient - Public FrmDownloadOptiFine As PageDownloadOptiFine - Public FrmDownloadLiteLoader As PageDownloadLiteLoader - Public FrmDownloadForge As PageDownloadForge - Public FrmDownloadNeoForge As PageDownloadNeoForge - Public FrmDownloadFabric As PageDownloadFabric Public FrmDownloadMod As PageDownloadMod Public FrmDownloadPack As PageDownloadPack Public FrmDownloadDataPack As PageDownloadDataPack @@ -496,7 +474,7 @@ EndHint: ''' 是否为 “执行事件”。 ''' Public IsEvent As Boolean - Public EventType As String + Public EventType As CustomEvent.EventType Public EventData As String ''' ''' 若非执行事件，其对应的 .xaml 本地文件内容。 @@ -510,7 +488,7 @@ EndHint: ''' Public Sub New(FilePath As String) RawPath = FilePath - Dim JsonData As JObject = GetJson(HelpArgumentReplace(ReadFile(FilePath))) + Dim JsonData As JObject = GetJson(ArgumentReplace(ReadFile(FilePath), AddressOf EscapeXML)) If JsonData Is Nothing Then Throw New FileNotFoundException("未找到帮助文件：" & FilePath, FilePath) '加载常规信息 If JsonData("Title") IsNot Nothing Then @@ -530,8 +508,7 @@ EndHint: Next '加载事件信息 If If(JsonData("IsEvent"), False) Then - EventType = JsonData("EventType") - If EventType Is Nothing Then Throw New ArgumentException("未找到 EventType 项") + EventType = [Enum].Parse(GetType(CustomEvent.EventType), JsonData("EventType").ToString) EventData = If(JsonData("EventData"), "") IsEvent = True Else @@ -556,7 +533,7 @@ EndHint: Public Function SetToListItem(Item As MyListItem) As MyListItem Dim Logo As String If IsEvent Then - If EventType = "弹出窗口" Then + If EventType = CustomEvent.EventType.弹出窗口 Then Logo = PathImage & "Blocks/GrassPath.png" Else Logo = PathImage & "Blocks/CommandBlock.png" @@ -573,9 +550,9 @@ EndHint: .Height = 42 .Type = MyListItem.CheckType.Clickable .Tag = Me - .EventType = Nothing - .EventData = Nothing End With + CustomEventService.SetEventType(Item, CustomEvent.EventType.None) '清空自定义事件属性，它们会被下面的点击事件处理 + CustomEventService.SetEventData(Item, Nothing) '项目的点击事件 AddHandler Item.Click, Sub(sender, e) PageOtherHelp.OnItemClick(sender.Tag) Return Item @@ -675,15 +652,6 @@ NextFile: Log("[Help] 已解压内置帮助文件，目前状态：" & File.Exists(PathTemp & "Help\启动器\备份设置.xaml"), LogLevel.Debug) End If End Sub - ''' - ''' 对帮助文件约定的替换标记进行处理，如果遇到需要转义的字符会进行转义。 - ''' - Public Function HelpArgumentReplace(Xaml As String) As String - Dim Result = Xaml.Replace("{path}", EscapeXML(Path)) - Result = Result.RegexReplaceEach("\{hint\}", Function() EscapeXML(PageOtherTest.GetRandomHint())) - Result = Result.RegexReplaceEach("\{cave\}", Function() EscapeXML(PageOtherTest.GetRandomCave())) - Return Result - End Function #End Region @@ -842,6 +810,79 @@ NextFile: End Using End Sub + ''' + ''' 对替换标记进行处理。会对替换内容使用 EscapeHandler 进行转义。 + ''' + Public Function ArgumentReplace(Text As String, Optional EscapeHandler As Func(Of String, String) = Nothing, Optional ReplaceTime As Boolean = True) As String + '预处理 + If Text Is Nothing Then Return Nothing + Dim Replacer = + Function(s As String) As String + If s Is Nothing Then Return "" + If EscapeHandler Is Nothing Then Return s + If s.Contains(":\") Then s = ShortenPath(s) + Return EscapeHandler(s) + End Function + '基础 + Text = Text.Replace("{pcl_version}", Replacer(VersionBaseName)) + Text = Text.Replace("{pcl_version_code}", Replacer(VersionCode)) + Text = Text.Replace("{pcl_version_branch}", Replacer(VersionBranchName)) + Text = Text.Replace("{pcl_branch}", Replacer(VersionBranchMain)) + Text = Text.Replace("{identify}", Replacer(Identify)) + Text = Text.Replace("{path}", Replacer(Path)) + Text = Text.Replace("{path_with_name}", Replacer(PathWithName)) + Text = Text.Replace("{path_temp}", Replacer(PathTemp)) + '时间 + If ReplaceTime Then '在窗口标题中，时间会被后续动态替换，所以此时不应该替换 + Text = Text.Replace("{date}", Replacer(Date.Now.ToString("yyyy/M/d"))) + Text = Text.Replace("{time}", Replacer(Date.Now.ToString("HH:mm:ss"))) + End If + 'Minecraft + Text = Text.Replace("{java}", Replacer(McLaunchJavaSelected?.PathFolder)) + Text = Text.Replace("{minecraft}", Replacer(PathMcFolder)) + If McVersionCurrent IsNot Nothing Then + Text = Text.Replace("{version_path}", Replacer(McVersionCurrent.Path)) : Text = Text.Replace("{verpath}", Replacer(McVersionCurrent.Path)) + Text = Text.Replace("{version_indie}", Replacer(McVersionCurrent.PathIndie)) : Text = Text.Replace("{verindie}", Replacer(McVersionCurrent.PathIndie)) + Text = Text.Replace("{name}", Replacer(McVersionCurrent.Name)) + If {"unknown", "old", "pending"}.Contains(McVersionCurrent.Version.McName.ToLower) Then + Text = Text.Replace("{version}", Replacer(McVersionCurrent.Name)) + Else + Text = Text.Replace("{version}", Replacer(McVersionCurrent.Version.McName)) + End If + Else + Text = Text.Replace("{version_path}", Replacer(Nothing)) : Text = Text.Replace("{verpath}", Replacer(Nothing)) + Text = Text.Replace("{version_indie}", Replacer(Nothing)) : Text = Text.Replace("{verindie}", Replacer(Nothing)) + Text = Text.Replace("{name}", Replacer(Nothing)) + Text = Text.Replace("{version}", Replacer(Nothing)) + End If + '登录信息 + If McLoginLoader.State = LoadState.Finished Then + Text = Text.Replace("{user}", Replacer(McLoginLoader.Output.Name)) + Text = Text.Replace("{uuid}", Replacer(McLoginLoader.Output.Uuid?.ToLower)) + Select Case McLoginLoader.Input.Type + Case McLoginType.Legacy + Text = Text.Replace("{login}", Replacer("离线")) + Case McLoginType.Ms + Text = Text.Replace("{login}", Replacer("正版")) + Case McLoginType.Nide + Text = Text.Replace("{login}", Replacer("统一通行证")) + Case McLoginType.Auth + Text = Text.Replace("{login}", Replacer("Authlib-Injector")) + End Select + Else + Text = Text.Replace("{user}", Replacer(Nothing)) + Text = Text.Replace("{uuid}", Replacer(Nothing)) + Text = Text.Replace("{login}", Replacer(Nothing)) + End If + '高级 + Text = Text.RegexReplaceEach("\{hint\}", Function() Replacer(PageOtherTest.GetRandomHint())) + Text = Text.RegexReplaceEach("\{cave\}", Function() Replacer(PageOtherTest.GetRandomCave())) + Text = Text.RegexReplaceEach("\{setup:([a-zA-Z0-9]+)\}", Function(m) Replacer(Setup.GetSafe(m.Groups(1).Value, McVersionCurrent))) + Text = Text.RegexReplaceEach("\{varible:([^:\}]+)(?::([^\}]+))?\}", Function(m) Replacer(ReadReg("CustomEvent" & m.Groups(1).Value, m.Groups(2).Value))) + Text = Text.RegexReplaceEach("\{variable:([^:\}]+)(?::([^\}]+))?\}", Function(m) Replacer(ReadReg("CustomEvent" & m.Groups(1).Value, m.Groups(2).Value))) + Return Text + End Function + #End Region #Region "任务缓存" diff --git a/Plain Craft Launcher 2/Modules/ModMusic.vb b/Plain Craft Launcher 2/Modules/ModMusic.vb index dc129ec..b0c36fc 100644 --- a/Plain Craft Launcher 2/Modules/ModMusic.vb +++ b/Plain Craft Launcher 2/Modules/ModMusic.vb @@ -30,7 +30,7 @@ Next End If '打乱顺序播放 - MusicWaitingList = If(Setup.Get("UiMusicRandom"), Shuffle(New List(Of String)(MusicAllList)), New List(Of String)(MusicAllList)) + MusicWaitingList = If(Setup.Get("UiMusicRandom"), New List(Of String)(MusicAllList).Shuffle().ToList, New List(Of String)(MusicAllList)) If PreventFirst IsNot Nothing AndAlso MusicWaitingList.FirstOrDefault = PreventFirst Then '若需要避免成为第一项的为第一项，则将它放在最后 MusicWaitingList.RemoveAt(0) @@ -79,7 +79,7 @@ If MusicState = MusicStates.Pause Then FrmMain.BtnExtraMusic.Logo = Logo.IconPlay FrmMain.BtnExtraMusic.LogoScale = 0.8 - ToolTipText = "已暂停：" & GetFileNameWithoutExtentionFromPath(MusicCurrent) + ToolTipText = "已暂停：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent) If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键恢复播放，右键播放下一曲。" Else @@ -88,7 +88,7 @@ Else FrmMain.BtnExtraMusic.Logo = Logo.IconMusic FrmMain.BtnExtraMusic.LogoScale = 1 - ToolTipText = "正在播放：" & GetFileNameWithoutExtentionFromPath(MusicCurrent) + ToolTipText = "正在播放：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent) If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键暂停，右键播放下一曲。" Else @@ -111,7 +111,7 @@ ''' Public Sub MusicControlPause() If MusicNAudio Is Nothing Then - Hint("音乐播放尚未开始！", HintType.Critical) + Hint("音乐播放尚未开始！", HintType.Red) Else Select Case MusicState Case MusicStates.Pause @@ -131,14 +131,14 @@ Public Sub MusicControlNext() If MusicAllList.Count = 1 Then MusicStartPlay(MusicCurrent) - Hint("重新播放：" & GetFileNameFromPath(MusicCurrent), HintType.Finish) + Hint("重新播放：" & GetFileNameFromPath(MusicCurrent), HintType.Green) Else Dim Address As String = DequeueNextMusicAddress() If Address Is Nothing Then - Hint("没有可以播放的音乐！", HintType.Critical) + Hint("没有可以播放的音乐！", HintType.Red) Else MusicStartPlay(Address) - Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Finish) + Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Green) End If End If MusicRefreshUI() @@ -182,19 +182,19 @@ MusicListInit(True) If Not MusicAllList.Any() Then If MusicNAudio Is Nothing Then - If ShowHint Then Hint("未检测到可用的背景音乐！", HintType.Critical) + If ShowHint Then Hint("未检测到可用的背景音乐！", HintType.Red) Else MusicNAudio = Nothing - If ShowHint Then Hint("背景音乐已清除！", HintType.Finish) + If ShowHint Then Hint("背景音乐已清除！", HintType.Green) End If Else Dim Address As String = DequeueNextMusicAddress() If Address Is Nothing Then - If ShowHint Then Hint("没有可以播放的音乐！", HintType.Critical) + If ShowHint Then Hint("没有可以播放的音乐！", HintType.Red) Else Try MusicStartPlay(Address, IsFirstLoad) - If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Finish, False) + If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Green, False) Catch End Try End If @@ -303,18 +303,18 @@ Catch ex As Exception Log(ex, "播放音乐出现内部错误（" & MusicCurrent & "）", LogLevel.Developer) If TypeOf ex Is NAudio.MmException AndAlso ex.Message.Contains("AlreadyAllocated") Then - Hint("你的音频设备正被其他程序占用。请在关闭占用的程序后重启 PCL，才能恢复音乐播放功能！", HintType.Critical) + Hint("你的音频设备正被其他程序占用。请在关闭占用的程序后重启 PCL，才能恢复音乐播放功能！", HintType.Red) Thread.Sleep(1000000000) End If If TypeOf ex Is NAudio.MmException AndAlso (ex.Message.Contains("NoDriver") OrElse ex.Message.Contains("BadDeviceId")) Then - Hint("由于音频设备变更，音乐播放功能在重启 PCL 后才能恢复！", HintType.Critical) + Hint("由于音频设备变更，音乐播放功能在重启 PCL 后才能恢复！", HintType.Red) 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) + Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 不支持播放音频属性在中途发生变化的音乐", HintType.Red) ElseIf Not (MusicCurrent.EndsWithF(".wav", True) OrElse MusicCurrent.EndsWithF(".mp3", True) OrElse MusicCurrent.EndsWithF(".flac", True)) OrElse ex.Message.Contains("0xC00D36C4") Then '#5096：不支持给定的 URL 的字节流类型。 (异常来自 HRESULT:0xC00D36C4) - Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Critical) + Hint("播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）：PCL 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Red) Else Log(ex, "播放音乐失败（" & GetFileNameFromPath(MusicCurrent) & "）", LogLevel.Hint) End If diff --git a/Plain Craft Launcher 2/Modules/ModSecret.vb b/Plain Craft Launcher 2/Modules/ModSecret.vb index 00635bb..62d425c 100644 --- a/Plain Craft Launcher 2/Modules/ModSecret.vb +++ b/Plain Craft Launcher 2/Modules/ModSecret.vb @@ -6,6 +6,8 @@ Friend Module ModSecret #Region "杂项" + '标注 PCL 的不同分支，仅用于替换标记 + Public Const VersionBranchMain As String = "OpenSource" '在开源版的注册表与常规版的注册表隔离，以防数据冲突 Public Const RegFolder As String = "PCLDebug" '用于微软登录的 ClientId @@ -56,13 +58,13 @@ Friend Module ModSecret ''' ''' 获取设备标识码。 ''' - Friend Function SecretGetUniqueAddress() As String + Friend Function SecretGetIdentify() As String Return "0000-0000-0000-0000" End Function Friend Sub SecretLaunchJvmArgs(ByRef DataList As List(Of String)) Dim DataJvmCustom As String = Setup.Get("VersionAdvanceJvm", Version:=McVersionCurrent) - DataList.Insert(0, If(DataJvmCustom = "", Setup.Get("LaunchAdvanceJvm"), DataJvmCustom)) '可变 JVM 参数 + DataList.Insert(0, ArgumentReplace(If(DataJvmCustom = "", Setup.Get("LaunchAdvanceJvm"), DataJvmCustom))) '可变 JVM 参数 McLaunchLog("当前剩余内存：" & Math.Round(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024 / 1024 * 10) / 10 & "G") DataList.Add("-Xmn" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent) * 1024 * 0.15) & "m") DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent) * 1024) & "m") @@ -80,15 +82,17 @@ Friend Module ModSecret ''' ''' 设置 Headers 的 UA、Referer。 ''' - Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional UseBrowserUserAgent As Boolean = False) - If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then - Req.Headers.Add("User-Agent", "LogStatistic") '#4951 - ElseIf UseBrowserUserAgent Then - Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36") - Else - Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}") + Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False) + If Not Req.Headers.UserAgent.Any Then + If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then + Req.Headers.Add("User-Agent", "LogStatistic") '#4951 + ElseIf SimulateBrowserHeaders Then + Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36") + Else + Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}") + End If End If - Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/") + If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/") If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey) End Sub @@ -277,9 +281,16 @@ Friend Module ModSecret #End Region -#Region "联网通知" +#Region "联网配置" - Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 服务", Sub() Log("[Server] 该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) + ''' + ''' 联网获取的配置信息。 + ''' 若获取失败或仍在获取中，可能为 Nothing。 + ''' + Public ServerConfig As JObject + + Public ServerLoader As New LoaderTask(Of Integer, Integer)("PCL 配置更新", Sub() Log("[Server] 该版本中不包含更新通知功能……"), Priority:=ThreadPriority.BelowNormal) With + {.ReloadTimeout = 1000 * 60 * 60} '超时 1 小时 #End Region diff --git a/Plain Craft Launcher 2/My Project/AssemblyInfo.vb b/Plain Craft Launcher 2/My Project/AssemblyInfo.vb index c257a02..8beb5b3 100644 --- a/Plain Craft Launcher 2/My Project/AssemblyInfo.vb +++ b/Plain Craft Launcher 2/My Project/AssemblyInfo.vb @@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices ' 可以指定所有值，也可以使用以下所示的 "*" 预置版本号和修订号 ' 方法是按如下所示使用“*” - - + + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml index 944bca6..719bbc6 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageComp.xaml @@ -34,7 +34,7 @@ - + @@ -71,7 +71,7 @@ - + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml index 3a52922..eb4a37c 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadCompDetail" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb index 1337e49..fda60b1 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadCompDetail.xaml.vb @@ -290,9 +290,9 @@ Sub(MyLoader) Select Case MyLoader.State Case LoadState.Failed - Hint(MyLoader.Name & "失败：" & GetExceptionSummary(MyLoader.Error), HintType.Critical) + Hint(MyLoader.Name & "失败：" & MyLoader.Error.GetBrief(), HintType.Red) Case LoadState.Aborted - Hint(MyLoader.Name & "已取消！", HintType.Info) + Hint(MyLoader.Name & "已取消！", HintType.Blue) Case LoadState.Loading Return '不重新加载版本列表 End Select @@ -326,7 +326,7 @@ Dim DefaultFolder As String = Nothing If File.Type <> CompType.ModPack Then Dim SubFolder As String = Nothing - Select Case Project.Type + Select Case File.Type Case CompType.Mod : SubFolder = "mods\" Case CompType.ResourcePack : SubFolder = "resourcepacks\" Case CompType.Shader : SubFolder = "shaderpacks\" @@ -346,7 +346,7 @@ Function(Version) If Not Version.IsLoaded Then Version.Load() '只对 Mod 和数据包进行版本检测 - If Project.Type = CompType.Mod OrElse Project.Type = CompType.DataPack Then + If File.Type = CompType.Mod OrElse File.Type = CompType.DataPack Then If File.GameVersions.Any(Function(v) v.Contains(".")) AndAlso Not File.GameVersions.Any(Function(v) v.Contains(".") AndAlso v = Version.Version.McName) Then Return False End If @@ -359,8 +359,8 @@ Return False End Function '获取常规资源默认下载位置 - If CachedFolder.ContainsKey(Project.Type) Then - DefaultFolder = CachedFolder(Project.Type) + If CachedFolder.ContainsKey(File.Type) Then + DefaultFolder = CachedFolder(File.Type) Log($"[Comp] 使用上次下载时的文件夹作为默认下载位置：{DefaultFolder}") ElseIf McVersionCurrent IsNot Nothing AndAlso IsVersionSuitable(McVersionCurrent) Then DefaultFolder = $"{McVersionCurrent.PathIndie}{SubFolder}" @@ -424,8 +424,8 @@ If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder) If Not Target.Contains("\") Then Return '构造步骤加载器 - Dim LoaderName As String = Desc & "下载：" & GetFileNameWithoutExtentionFromPath(Target) & " " - If Target <> DefaultFolder Then CachedFolder(Project.Type) = GetPathFromFullPath(Target) + Dim LoaderName As String = Desc & "下载：" & IO.Path.GetFileNameWithoutExtension(Target) & " " + If Target <> DefaultFolder Then CachedFolder(File.Type) = GetPathFromFullPath(Target) Dim Loaders As New List(Of LoaderBase) Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True}) '启动 diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml index f7c01e9..c07469c 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadDataPack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadDataPack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml index c7914d9..d000fd8 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadMod.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadMod" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml index 51f04d6..0954583 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadPack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadPack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> @@ -17,7 +17,7 @@ - + diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml index 91932d5..ec7ead0 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadResourcePack.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadResourcePack" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml index 123ce1b..9d0ca3b 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/Comp/PageDownloadShader.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadShader" - PanScroll="{Binding ElementName=Content}"> + PanScroll="Content"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb b/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb index 02c92e2..7d2dae1 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/ModDownloadLib.vb @@ -1,5 +1,4 @@ Imports System.IO.Compression -Imports System.Net.Http Public Module ModDownloadLib @@ -32,7 +31,7 @@ Public Module ModDownloadLib For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For If Behaviour = NetPreDownloadBehaviour.ExitWhileExistsOrDownloading Then Return OngoingLoader - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return OngoingLoader Next @@ -100,7 +99,8 @@ Public Module ModDownloadLib Sub(Task As LoaderTask(Of String, List(Of NetFile))) Try Dim Version As New McVersion(VersionFolder) - Task.Output = New List(Of NetFile) From {DlClientAssetIndexGet(Version)} + Dim AssetIndex = DlClientAssetIndexGet(Version) + Task.Output = If(AssetIndex Is Nothing, New List(Of NetFile), New List(Of NetFile) From {AssetIndex}) Catch ex As Exception Throw New Exception("分析资源文件索引地址失败", ex) End Try @@ -223,7 +223,7 @@ Public Module ModDownloadLib '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Minecraft {Id} 服务端下载" Then Continue For - Hint("该服务端正在下载中！", HintType.Critical) + Hint("该服务端正在下载中！", HintType.Red) Return Next @@ -241,7 +241,7 @@ Public Module ModDownloadLib File.Delete(VersionFolder & Id & ".json") If Not New DirectoryInfo(VersionFolder).GetFileSystemInfos.Any() Then Directory.Delete(VersionFolder) Task.Output = New List(Of NetFile) - Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载，没法下，撤退！", HintType.Critical) + Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载，没法下，撤退！", HintType.Red) Thread.Sleep(2000) '等玩家把上一个提示看完 Task.Abort() Return @@ -300,7 +300,7 @@ pause" '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -401,7 +401,7 @@ pause" '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"OptiFine {DownloadInfo.NameDisplay} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -449,7 +449,7 @@ pause" '开始启动 SyncLock InstallSyncLock Dim Info = New ProcessStartInfo With { - .FileName = Java.PathJavaw, + .FileName = Java.PathJava, .Arguments = Arguments, .UseShellExecute = False, .CreateNoWindow = True, @@ -571,7 +571,7 @@ pause" Dim PageData As String Try PageData = NetRequestByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, - Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", UseBrowserUserAgent:=True) + Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", SimulateBrowserHeaders:=True) Task.Progress = 0.8 Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址：" & Sources.Last) @@ -735,7 +735,7 @@ Retry: Dim PageData As String Try PageData = NetRequestByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, - Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", UseBrowserUserAgent:=True) + Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", SimulateBrowserHeaders:=True) Task.Progress = 0.8 Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址：" & Sources.Last) @@ -832,7 +832,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -866,7 +866,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -1048,7 +1048,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"{DisplayName} 下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -1120,7 +1120,7 @@ Retry: '开始启动 SyncLock InstallSyncLock Dim Info = New ProcessStartInfo With { - .FileName = Java.PathJavaw, + .FileName = Java.PathJava, .Arguments = Arguments, .UseShellExecute = False, .CreateNoWindow = True, @@ -1345,7 +1345,7 @@ Retry: Dim RawJson As JObject = GetJson(NetRequestByLoader(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True)) '[net.minecraft:client:1.17.1-20210706.113038:mappings@txt] 或 @tsrg] Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).BeforeFirst("@") - Dim Address = McLibGet(OriginalName).Replace(".jar", "-mappings." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1)) + Dim Address = McLibGet(OriginalName).Replace(".jar", "." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1)) Dim ClientMappings As JToken = RawJson("downloads")("client_mappings") Libs.Add(New McLibToken With { .IsNatives = False, .LocalPath = Address, .OriginalName = OriginalName, @@ -1647,7 +1647,7 @@ Retry: Sub() Try Log("[Download] 刷新 Forge 推荐版本缓存开始") - Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/promos") + Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/promos", RequireJson:=True) If Result.Length < 1000 Then Throw New Exception("获取的结果过短（" & Result & "）") Dim ResultJson As JContainer = GetJson(Result) '获取所有推荐版本列表 @@ -1803,7 +1803,7 @@ Retry: '重复任务检查 For Each OngoingLoader In LoaderTaskbar.ToList() If OngoingLoader.Name <> $"Fabric {Version} 安装器下载" Then Continue For - Hint("该版本正在下载中！", HintType.Critical) + Hint("该版本正在下载中！", HintType.Red) Return Next @@ -1986,28 +1986,28 @@ Retry: ''' 在加载器状态改变后显示一条提示。 ''' 不会进行任何其他操作。 ''' - Public Sub LoaderStateChangedHintOnly(Loader) + Public Sub LoaderStateChangedHintOnly(Loader As LoaderBase) Select Case Loader.State Case LoadState.Finished - Hint(Loader.Name & "成功！", HintType.Finish) + Hint(Loader.Name & "成功！", HintType.Green) Case LoadState.Failed - Hint(Loader.Name & "失败：" & GetExceptionSummary(Loader.Error), HintType.Critical) + Hint(Loader.Name & "失败：" & Loader.Error.GetBrief(), HintType.Red) Case LoadState.Aborted - Hint(Loader.Name & "已取消！", HintType.Info) + Hint(Loader.Name & "已取消！", HintType.Blue) End Select End Sub ''' ''' 安装加载器状态改变后进行提示和重载文件夹列表的方法。 ''' - Public Sub McInstallState(Loader) + Public Sub McInstallState(Loader As LoaderBase) Select Case Loader.State Case LoadState.Finished WriteIni(PathMcFolder & "PCL.ini", "VersionCache", "") '清空缓存（合并安装会先生成文件夹，这会在刷新时误判为可以使用缓存） - Hint(Loader.Name & "成功！", HintType.Finish) + Hint(Loader.Name & "成功！", HintType.Green) Case LoadState.Failed - Hint(Loader.Name & "失败：" & GetExceptionSummary(Loader.Error), HintType.Critical) + Hint(Loader.Name & "失败：" & Loader.Error.GetBrief(), HintType.Red) Case LoadState.Aborted - Hint(Loader.Name & "已取消！", HintType.Info) + Hint(Loader.Name & "已取消！", HintType.Blue) Case LoadState.Loading Return '不重新加载版本列表 End Select @@ -2108,7 +2108,7 @@ Retry: '重复版本检查 If File.Exists($"{VersionFolder}{Request.TargetVersionName}.json") Then - Hint("版本 " & Request.TargetVersionName & " 已经存在！", HintType.Critical) + Hint("版本 " & Request.TargetVersionName & " 已经存在！", HintType.Red) Throw New CancelledException End If diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml deleted file mode 100644 index e45317e..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml +++ /dev/null @@ -1,31 +0,0 @@ - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb deleted file mode 100644 index 78c963c..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadClient.xaml.vb +++ /dev/null @@ -1,111 +0,0 @@ -Public Class PageDownloadClient - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanBack, Nothing, DlClientListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of JObject)) From { - {"正式版", New List(Of JObject)}, {"预览版", New List(Of JObject)}, {"远古版", New List(Of JObject)}, {"愚人节版", New List(Of JObject)} - } - Dim Versions As JArray = DlClientListLoader.Output.Value("versions") - For Each Version As JObject In Versions - '确定分类 - Dim Type As String = Version("type") - Select Case Type - Case "release" - Type = "正式版" - Case "snapshot" - Type = "预览版" - 'Mojang 误分类 - If Version("id").ToString.StartsWith("1.") AndAlso - Not Version("id").ToString.ToLower.Contains("combat") AndAlso - Not Version("id").ToString.ToLower.Contains("rc") AndAlso - Not Version("id").ToString.ToLower.Contains("experimental") AndAlso - Not Version("id").ToString.ToLower.Contains("pre") Then - Type = "正式版" - Version("type") = "release" - End If - '愚人节版本 - Select Case Version("id").ToString.ToLower - Case "20w14infinite", "20w14∞" - Type = "愚人节版" - 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", "24w14potato", "25w14craftmine" - Type = "愚人节版" - Version("type") = "special" - Version.Add("lore", GetMcFoolName(Version("id"))) - Case Else '4/1 自动视作愚人节版 - Dim ReleaseDate = Version("releaseTime").Value(Of Date).ToUniversalTime().AddHours(2) - If ReleaseDate.Month = 4 AndAlso ReleaseDate.Day = 1 Then - Type = "愚人节版" - Version("type") = "special" - End If - End Select - Case "special" - '已被处理的愚人节版 - Type = "愚人节版" - Case Else - Type = "远古版" - End Select - '加入辞典 - Dict(Type).Add(Version) - Next - '排序 - For i = 0 To Dict.Keys.Count - 1 - Dict(Dict.Keys(i)) = Dict.Values(i).OrderByDescending(Function(v) v("releaseTime").Value(Of Date)).ToList - Next - '清空当前 - PanMain.Children.Clear() - '添加最新版本 - Dim CardInfo As New MyCard With {.Title = "最新版本", .Margin = New Thickness(0, 0, 0, 15), .SwapType = 2} - Dim TopestVersions As New List(Of JObject) - Dim Release As JObject = Dict("正式版")(0).DeepClone() - Release("lore") = "最新正式版，发布于 " & Release("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Release) - If Dict("正式版")(0)("releaseTime").Value(Of Date) < Dict("预览版")(0)("releaseTime").Value(Of Date) Then - Dim Snapshot As JObject = Dict("预览版")(0).DeepClone() - Snapshot("lore") = "最新预览版，发布于 " & Snapshot("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Snapshot) - End If - Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = TopestVersions} - MyCard.StackInstall(PanInfo, 2) - CardInfo.Children.Add(PanInfo) - PanMain.Children.Add(CardInfo) - '添加其他版本 - For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict - 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} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwapped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 MC 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Public Sub DownloadStart(sender As MyListItem, e As Object) - McDownloadClient(NetPreDownloadBehaviour.HintWhileExists, sender.Title, sender.Tag("url").ToString) - End Sub - - ''介绍栏 - 'Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - ' OpenWebsite("https://www.minecraft.net/zh-hans") - 'End Sub - 'Private Sub BtnInstall_Click(sender As Object, e As EventArgs) Handles BtnInstall.Click - ' FrmMain.PageChange(FormMain.PageType.Download, FormMain.PageSubType.DownloadInstall) - 'End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml deleted file mode 100644 index 0c19a78..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml +++ /dev/null @@ -1,28 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb deleted file mode 100644 index fa65b79..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadFabric.xaml.vb +++ /dev/null @@ -1,32 +0,0 @@ -Public Class PageDownloadFabric - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, CardVersions, CardTip, DlFabricListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - Dim Versions As JArray = DlFabricListLoader.Output.Value("installer") - PanVersions.Children.Clear() - For Each Version In Versions - PanVersions.Children.Add(FabricDownloadListItem(Version, AddressOf Fabric_Selected)) - Next - CardVersions.Title = "版本列表 (" & Versions.Count & ")" - Catch ex As Exception - Log(ex, "可视化 Fabric 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Private Sub Fabric_Selected(sender As MyListItem, e As EventArgs) - McDownloadFabricLoaderSave(sender.Tag) - End Sub - - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.fabricmc.net") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml deleted file mode 100644 index a4379c4..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb deleted file mode 100644 index b7f42f0..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadForge.xaml.vb +++ /dev/null @@ -1,61 +0,0 @@ -Public Class PageDownloadForge - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlForgeListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Version As String In DlForgeListLoader.Output.Value.Sort(AddressOf VersionSortBoolean) - '增加卡片 - Dim NewCard As New MyCard With {.Title = Version.Replace("_p", " P"), .Margin = New Thickness(0, 0, 0, 15), .SwapType = 5} - Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Version} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwapped = True - PanMain.Children.Add(NewCard) - Next - ''非官方源警示 - 'If Setup.Get("ToolDownloadOutOfDate") AndAlso Not DlForgeListLoader.Output.IsOfficial Then - ' Dim CardWarn As New MyCard With {.Title = "过期提示", .Margin = New Thickness(0, 0, 0, 15)} - ' CardWarn.Children.Add(New TextBlock With { - ' .Margin = New Thickness(25, MyCard.SwapedHeight, 15, 15), .VerticalAlignment = VerticalAlignment.Top, .HorizontalAlignment = HorizontalAlignment.Left, .TextTrimming = TextTrimming.None, .TextWrapping = TextWrapping.Wrap, - ' .Text = "获取官方源失败，正在使用 " & DlForgeListLoader.Output.SourceName & " 镜像源，版本列表可能并非最新。" & vbCrLf & "官方源错误原因：" & If(DlForgeListLoader.Output.OfficialError, New Exception("连接服务器超时")).Message}) - ' PanMain.Children.Insert(0, CardWarn) - 'End If - Catch ex As Exception - Log(ex, "可视化 Forge 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - 'Forge 版本列表加载 - Public Sub Forge_Click(sender As MyLoading, e As MouseButtonEventArgs) - If sender.State.LoadingState = MyLoading.MyLoadingState.Error Then - CType(sender.State, LoaderTask(Of String, List(Of DlForgeVersionEntry))).Start(IsForceRestart:=True) - End If - End Sub - Public Sub Forge_StateChanged(sender As MyLoading, newState As MyLoading.MyLoadingState, oldState As MyLoading.MyLoadingState) - If newState <> MyLoading.MyLoadingState.Stop Then Return - - Dim Card As MyCard = CType(sender.Parent, FrameworkElement).Parent - Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = sender.State - '载入列表 - Card.SwapControl.Children.Clear() - Card.SwapControl.Tag = Loader.Output - Card.SwapType = 6 - Card.StackInstall() - End Sub - - '介绍栏 - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://files.minecraftforge.net") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml index 79fa3ce..74a753d 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageDownloadInstall" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb index d10c5d5..f4c0737 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadInstall.xaml.vb @@ -609,16 +609,16 @@ PanMinecraft.Children.Clear() '添加最新版本 Dim CardInfo As New MyCard With {.Title = "最新版本", .Margin = New Thickness(0, 15, 0, 15), .SwapType = 2} - Dim TopestVersions As New List(Of JObject) + Dim PinnedVersions As New List(Of JObject) Dim Release As JObject = Dict("正式版")(0).DeepClone() Release("lore") = "最新正式版，发布于 " & Release("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Release) + PinnedVersions.Add(Release) If Dict("正式版")(0)("releaseTime").Value(Of Date) < Dict("预览版")(0)("releaseTime").Value(Of Date) Then Dim Snapshot As JObject = Dict("预览版")(0).DeepClone() Snapshot("lore") = "最新预览版，发布于 " & Snapshot("releaseTime").Value(Of Date).ToString("yyyy'/'MM'/'dd HH':'mm") - TopestVersions.Add(Snapshot) + PinnedVersions.Add(Snapshot) End If - Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = TopestVersions} + Dim PanInfo As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = PinnedVersions} MyCard.StackInstall(PanInfo, 7) CardInfo.Children.Add(PanInfo) PanMinecraft.Children.Insert(0, CardInfo) @@ -626,7 +626,7 @@ For Each Pair As KeyValuePair(Of String, List(Of JObject)) In Dict 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 NewCard As New MyCard With {.Title = Pair.Key, .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} NewCard.Children.Add(NewStack) NewCard.SwapControl = NewStack diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml index ae788bc..6d85387 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml @@ -1,114 +1,59 @@  + xmlns:local="clr-namespace:PCL" AnimatedControl="PanItem"> - - + - + - - - - + + + + + + + + + + + + + + + + - - + - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb index b63590b..3ddece3 100644 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLeft.xaml.vb @@ -11,7 +11,7 @@ ''' ''' 勾选事件改变页面。 ''' - Private Sub PageCheck(sender As MyListItem, e As RouteEventArgs) Handles ItemInstall.Check, ItemClient.Check, ItemOptiFine.Check, ItemForge.Check, ItemNeoForge.Check, ItemLiteLoader.Check, ItemMod.Check, ItemFabric.Check, ItemPack.Check, ItemResourcePack.Check, ItemShader.Check, ItemDataPack.Check + Private Sub PageCheck(sender As MyListItem, e As RouteEventArgs) Handles ItemInstall.Check, ItemMod.Check, ItemPack.Check, ItemResourcePack.Check, ItemShader.Check, ItemDataPack.Check '尚未初始化控件属性时，sender.Tag 为 Nothing，会导致切换到页面 0 '若使用 IsLoaded，则会导致模拟点击不被执行（模拟点击切换页面时，控件的 IsLoaded 为 False） If sender.Tag IsNot Nothing Then PageChange(Val(sender.Tag)) @@ -23,24 +23,6 @@ Case FormMain.PageSubType.DownloadInstall If FrmDownloadInstall Is Nothing Then FrmDownloadInstall = New PageDownloadInstall Return FrmDownloadInstall - Case FormMain.PageSubType.DownloadClient - If FrmDownloadClient Is Nothing Then FrmDownloadClient = New PageDownloadClient - Return FrmDownloadClient - Case FormMain.PageSubType.DownloadOptiFine - If FrmDownloadOptiFine Is Nothing Then FrmDownloadOptiFine = New PageDownloadOptiFine - Return FrmDownloadOptiFine - Case FormMain.PageSubType.DownloadForge - If FrmDownloadForge Is Nothing Then FrmDownloadForge = New PageDownloadForge - Return FrmDownloadForge - Case FormMain.PageSubType.DownloadNeoForge - If FrmDownloadNeoForge Is Nothing Then FrmDownloadNeoForge = New PageDownloadNeoForge - Return FrmDownloadNeoForge - Case FormMain.PageSubType.DownloadLiteLoader - If FrmDownloadLiteLoader Is Nothing Then FrmDownloadLiteLoader = New PageDownloadLiteLoader - Return FrmDownloadLiteLoader - Case FormMain.PageSubType.DownloadFabric - If FrmDownloadFabric Is Nothing Then FrmDownloadFabric = New PageDownloadFabric - Return FrmDownloadFabric Case FormMain.PageSubType.DownloadMod If FrmDownloadMod Is Nothing Then FrmDownloadMod = New PageDownloadMod Return FrmDownloadMod @@ -163,24 +145,6 @@ FrmDownloadDataPack.PageLoaderRestart() End If ItemDataPack.Checked = True - Case FormMain.PageSubType.DownloadClient - DlClientListLoader.Start(IsForceRestart:=True) - ItemClient.Checked = True - Case FormMain.PageSubType.DownloadOptiFine - DlOptiFineListLoader.Start(IsForceRestart:=True) - ItemOptiFine.Checked = True - Case FormMain.PageSubType.DownloadForge - DlForgeListLoader.Start(IsForceRestart:=True) - ItemForge.Checked = True - Case FormMain.PageSubType.DownloadNeoForge - DlNeoForgeListLoader.Start(IsForceRestart:=True) - ItemNeoForge.Checked = True - Case FormMain.PageSubType.DownloadLiteLoader - DlLiteLoaderListLoader.Start(IsForceRestart:=True) - ItemLiteLoader.Checked = True - Case FormMain.PageSubType.DownloadFabric - DlFabricListLoader.Start(IsForceRestart:=True) - ItemFabric.Checked = True End Select Hint("正在刷新……", Log:=False) End Sub @@ -191,55 +155,4 @@ FrmDownloadInstall.ExitSelectPage() End Sub - '展开手动安装 - Private Sub ItemHand_Click(sender As Object, e As RouteEventArgs) Handles ItemHand.Changed - If ItemHand.Checked = False Then Return - e.Handled = True - AniControlEnabled += 1 - If Not Setup.Get("HintHandInstall") Then - Setup.Set("HintHandInstall", True) - If MyMsgBox("手动安装包功能提供了 OptiFine、Forge 等组件的 .jar 安装文件下载，但无法自动安装。" & vbCrLf & - "在自动安装页面先选择 MC 版本，然后就可以选择 OptiFine、Forge 等组件，让 PCL 自动进行安装了。", "自动安装提示", "返回自动安装", "继续下载手动安装包") = 1 Then - FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.Download}, FormMain.PageSubType.DownloadInstall) - AniControlEnabled -= 1 - Return - End If - End If - ItemHand.Visibility = Visibility.Collapsed - LabGame.Visibility = Visibility.Collapsed - LabHand.Visibility = Visibility.Visible - ItemClient.Visibility = Visibility.Visible - ItemOptiFine.Visibility = Visibility.Visible - ItemFabric.Visibility = Visibility.Visible - ItemForge.Visibility = Visibility.Visible - ItemNeoForge.Visibility = Visibility.Visible - ItemLiteLoader.Visibility = Visibility.Visible - RunInThread( - Sub() - Thread.Sleep(20) - RunInUiWait(Sub() ItemClient.SetChecked(True, True, True)) - AniControlEnabled -= 1 - End Sub) - End Sub - '折叠手动安装 - Private Sub LabHand_Click(sender As Object, e As MouseButtonEventArgs) Handles LabHand.MouseLeftButtonUp - e.Handled = True - AniControlEnabled += 1 - ItemHand.Visibility = Visibility.Visible - LabGame.Visibility = Visibility.Visible - LabHand.Visibility = Visibility.Collapsed - ItemClient.Visibility = Visibility.Collapsed - ItemOptiFine.Visibility = Visibility.Collapsed - ItemNeoForge.Visibility = Visibility.Collapsed - ItemFabric.Visibility = Visibility.Collapsed - ItemForge.Visibility = Visibility.Collapsed - ItemLiteLoader.Visibility = Visibility.Collapsed - RunInThread( - Sub() - Thread.Sleep(20) - RunInUiWait(Sub() ItemInstall.SetChecked(True, True, True)) - AniControlEnabled -= 1 - End Sub) - End Sub - End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml deleted file mode 100644 index 69c4db0..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb deleted file mode 100644 index 7eff1c8..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadLiteLoader.xaml.vb +++ /dev/null @@ -1,52 +0,0 @@ -Public Class PageDownloadLiteLoader - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlLiteLoaderListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of DlLiteLoaderListEntry)) - For VersionCode As Integer = 30 To 0 Step -1 - Dict.Add("1." & VersionCode, New List(Of DlLiteLoaderListEntry)) - Next - Dict.Add("未知版本", New List(Of DlLiteLoaderListEntry)) - For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value - Dim MainVersion As String = "1." & Version.Inherit.Split(".")(1) - If Dict.ContainsKey(MainVersion) Then - Dict(MainVersion).Add(Version) - Else - Dict("未知版本").Add(Version) - End If - Next - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlLiteLoaderListEntry)) In Dict - 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} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwapped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 LiteLoader 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Public Sub DownloadStart(sender As MyListItem, e As Object) - McDownloadLiteLoader(sender.Tag) - End Sub - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.liteloader.com") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml deleted file mode 100644 index 886c343..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml +++ /dev/null @@ -1,27 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb deleted file mode 100644 index 37cdcda..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadNeoForge.xaml.vb +++ /dev/null @@ -1,34 +0,0 @@ -Public Class PageDownloadNeoForge - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlNeoForgeListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict = DlNeoForgeListLoader.Output.Value.GroupBy(Function(d) d.Inherit).OrderByDescending(Function(g) g.Key). - ToDictionary(Function(g) g.Key, Function(g) g.ToList()) - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlNeoForgeListEntry)) In Dict - 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 = 13} - 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} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwapped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 NeoForge 版本列表出错", LogLevel.Feedback) - End Try - End Sub - -End Class \ No newline at end of file diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml deleted file mode 100644 index 1a08b51..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb b/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb deleted file mode 100644 index 7eebac8..0000000 --- a/Plain Craft Launcher 2/Pages/PageDownload/PageDownloadOptiFine.xaml.vb +++ /dev/null @@ -1,53 +0,0 @@ -Public Class PageDownloadOptiFine - - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanMain, CardTip, DlOptiFineListLoader, AddressOf Load_OnFinish) - End Sub - Private Sub Init() Handles Me.Loaded - PanBack.ScrollToHome() - End Sub - - Private Sub Load_OnFinish() - '结果数据化 - Try - '归类 - Dim Dict As New Dictionary(Of String, List(Of DlOptiFineListEntry)) - Dict.Add("快照版本", New List(Of DlOptiFineListEntry)) - For VersionCode As Integer = 50 To 0 Step -1 - Dict.Add("1." & VersionCode, New List(Of DlOptiFineListEntry)) - Next - For Each Version As DlOptiFineListEntry In DlOptiFineListLoader.Output.Value - If Version.Inherit.StartsWith("1.") Then - Dim MainVersion As String = "1." & Version.NameDisplay.Split(".")(1).Split(" ")(0) - If Dict.ContainsKey(MainVersion) Then - Dict(MainVersion).Add(Version) - Else - Dict("快照版本").Add(Version) - End If - Else - Dict("快照版本").Add(Version) - End If - Next - '清空当前 - PanMain.Children.Clear() - '转化为 UI - For Each Pair As KeyValuePair(Of String, List(Of DlOptiFineListEntry)) In Dict - 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} - NewCard.Children.Add(NewStack) - NewCard.SwapControl = NewStack - NewCard.IsSwapped = True - PanMain.Children.Add(NewCard) - Next - Catch ex As Exception - Log(ex, "可视化 OptiFine 版本列表出错", LogLevel.Feedback) - End Try - End Sub - - Private Sub BtnWeb_Click(sender As Object, e As EventArgs) Handles BtnWeb.Click - OpenWebsite("https://www.optifine.net/") - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml b/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml index 1144f09..83f5368 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml +++ b/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml @@ -1,8 +1,8 @@  + xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation" + xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" + xmlns:local="clr-namespace:PCL" + RenderTransformOrigin="0,0.5" UseLayoutRounding="True" SnapsToDevicePixels="True" MinWidth="400" HorizontalAlignment="Center" VerticalAlignment="Center" Margin="25"> @@ -23,17 +23,17 @@ - - + - - - + + + diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml.vb index 2ef95d9..576c6dc 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/MyMsgLogin.xaml.vb @@ -87,16 +87,16 @@ LabTitle.Text = "登录 Minecraft" LabCaption.Text = $"登录网页将自动开启，请在网页中输入 {UserCode}（已自动复制）。" & vbCrLf & vbCrLf & - $"如果网络环境不佳，网页可能一直加载不出来，届时请使用加速器或 VPN 以改善网络环境。" & vbCrLf & + $"如果网络环境不佳，网页可能一直加载不出来，届时请使用加速器或 VPN 改善网络环境。" & vbCrLf & $"你也可以用其他设备打开 {Website} 并输入上述代码。" - Btn1.EventData = Website - Btn2.EventData = UserCode + CustomEventService.SetEventData(Btn1, Website) + CustomEventService.SetEventData(Btn2, UserCode) '启动工作线程 RunInNewThread(AddressOf WorkThread, "MyMsgLogin") End Sub Private Sub WorkThread() - Thread.Sleep(3000) + Thread.Sleep(2000) If MyConverter.IsExited Then Return OpenWebsite(Website) ClipboardSet(UserCode) @@ -114,14 +114,15 @@ "scope=XboxLive.signin%20offline_access", ContentType:="application/x-www-form-urlencoded", Timeout:=5000 + UnknownFailureCount * 5000, - MakeLog:=False) + MakeLog:=False, RequireJson:=True) '获取结果 Dim ResultJson As JObject = GetJson(Result) McLaunchLog($"令牌过期时间：{ResultJson("expires_in")} 秒") - Hint("网页登录成功！", HintType.Finish) + Hint("网页登录成功！", HintType.Green) Finished({ResultJson("access_token").ToString, ResultJson("refresh_token").ToString}) Return Catch ex As Exception + '修改错误列表时，同时修改 ModLaunch.MsLoginStep1Refresh 中的对应代码 If TypeOf ex Is ResponsedWebException Then Dim Response = CType(ex, ResponsedWebException).Response If Response.Contains("authorization_declined") Then diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/MySkin.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/MySkin.xaml.vb index 352c69b..40daeca 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/MySkin.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/MySkin.xaml.vb @@ -47,7 +47,7 @@ Public Shared Sub Save(Loader As LoaderTask(Of EqualableList(Of String), String)) Dim Address = Loader.Output If Not Loader.State = LoadState.Finished Then - Hint("皮肤正在获取中，请稍候！", HintType.Critical) + Hint("皮肤正在获取中，请稍候！", HintType.Red) If Not Loader.State = LoadState.Loading Then Loader.Start() Return End If @@ -61,7 +61,7 @@ Else CopyFile(Address, FileAddress) End If - Hint("皮肤保存成功！", HintType.Finish) + Hint("皮肤保存成功！", HintType.Green) End If Catch ex As Exception Log(ex, "保存皮肤失败", LogLevel.Hint) @@ -143,7 +143,7 @@ Next If FrmLaunchLeft IsNot Nothing AndAlso HasLoaderRunning Then '由于 Abort 不是实时的，暂时不会释放文件，会导致删除报错，故只能取消执行 - Hint("有正在获取中的皮肤，请稍后再试！", HintType.Info) + Hint("有正在获取中的皮肤，请稍后再试！", HintType.Blue) Else RunInThread( Sub() @@ -161,7 +161,7 @@ For Each SkinLoader In If(sender IsNot Nothing, {sender}, {PageLaunchLeft.SkinLegacy, PageLaunchLeft.SkinMs}) SkinLoader.WaitForExit(IsForceRestart:=True) Next - Hint("已刷新头像！", HintType.Finish) + Hint("已刷新头像！", HintType.Green) Catch ex As Exception Log(ex, "刷新皮肤缓存失败", LogLevel.Msgbox) End Try @@ -184,7 +184,7 @@ SkinLoader.WaitForExit(IsForceRestart:=True) Next '完成提示 - Hint("更改皮肤成功！", HintType.Finish) + Hint("更改皮肤成功！", HintType.Green) Catch ex As Exception Log(ex, "更改正版皮肤后刷新皮肤失败", LogLevel.Feedback) End Try @@ -212,7 +212,7 @@ Return End If If McLoginMsLoader.State = LoadState.Failed Then - Hint("登录失败，无法更改披风！", HintType.Critical) + Hint("登录失败，无法更改披风！", HintType.Red) Return End If Hint("正在获取披风列表，请稍候……") @@ -225,7 +225,7 @@ Retry: '获取登录信息 If McLoginMsLoader.State <> LoadState.Finished Then McLoginMsLoader.WaitForExit(PageLoginMsSkin.GetLoginData()) If McLoginMsLoader.State <> LoadState.Finished Then - Hint("登录失败，无法更改披风！", HintType.Critical) + Hint("登录失败，无法更改披风！", HintType.Red) Return End If Dim AccessToken As String = McLoginMsLoader.Output.AccessToken @@ -244,7 +244,7 @@ Retry: {"Cherry Blossom", "樱花披风"}, {"15th Anniversary", "15 周年纪念披风"}, {"Purple Heart", "紫色心形披风"}, {"Follower's", "追随者披风"}, {"MCC 15th Year", "MCC 15 周年披风"}, {"Minecraft Experience", "村民救援披风"}, {"Mojang Office", "Mojang 办公室披风"}, {"Home", "家园披风"}, {"Menace", "入侵披风"}, {"Yearn", "渴望披风"}, - {"Common", "普通披风"}, {"Pan", "薄煎饼披风"}, {"Founder's", "创始人披风"} + {"Common", "普通披风"}, {"Pan", "薄煎饼披风"}, {"Founder's", "创始人披风"}, {"Copper", "铜披风"} } Dim SelectionControl As New List(Of IMyRadio) From {New MyRadioBox With {.Text = "无披风"}} For Each Cape In SkinData("capes") @@ -265,10 +265,10 @@ Retry: ContentType:="application/json", Headers:={{"Authorization", "Bearer " & AccessToken}}) If Result.Contains("""errorMessage""") Then - Hint("更改披风失败：" & GetJson(Result)("errorMessage").ToString, HintType.Critical) + Hint("更改披风失败：" & GetJson(Result)("errorMessage").ToString, HintType.Red) Return Else - Hint("更改披风成功！", HintType.Finish) + Hint("更改披风成功！", HintType.Green) End If Catch ex As Exception Log(ex, "更改披风失败", LogLevel.Hint) diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchLeft.xaml.vb index f22dcc2..a1d5b7e 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchLeft.xaml.vb @@ -110,11 +110,7 @@ '修改登陆方式 Select Case Setup.Get("LoginType") Case McLoginType.Legacy - If PageLinkHiper.HiperState = LoadState.Finished Then - LabLaunchingMethod.Text = "联机离线登录" - Else - LabLaunchingMethod.Text = "离线登录" - End If + LabLaunchingMethod.Text = "离线登录" Case McLoginType.Ms LabLaunchingMethod.Text = "正版登录" Case McLoginType.Nide @@ -392,14 +388,14 @@ UnknownType: Result = McSkinDownload(Result) If Data.IsAborted Then Throw New ThreadInterruptedException("当前任务已取消：" & UserName) Data.Output = Result + Catch ex As ThreadInterruptedException + Data.Output = "" + Return Catch ex As Exception - If ex.GetType.Name = "ThreadInterruptedException" Then - Data.Output = "" - Return - ElseIf GetExceptionSummary(ex).Contains("429") Then + If ex.GetBrief.Contains("(429)") Then Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(UserName)) & ".png" Log("[Minecraft] 获取正版皮肤失败（" & UserName & "）：获取皮肤太过频繁，请 5 分钟后再试！", LogLevel.Hint) - ElseIf GetExceptionSummary(ex).Contains("未设置自定义皮肤") Then + ElseIf ex.GetBrief.Contains("未设置自定义皮肤") Then Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(UserName)) & ".png" Log("[Minecraft] 用户未设置自定义皮肤，跳过皮肤加载") Else @@ -462,11 +458,11 @@ UseDefault: If Data.IsAborted Then Throw New ThreadInterruptedException("当前任务已取消：" & ID) Data.Output = Result End If + Catch ex As ThreadInterruptedException + Data.Output = "" + Return Catch ex As Exception - If ex.GetType.Name = "ThreadInterruptedException" Then - Data.Output = "" - Return - ElseIf GetExceptionSummary(ex).Contains("429") Then + If ex.GetBrief.Contains("(429)") Then Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(ID)) & ".png" Log("获取离线登录使用的正版皮肤失败（" & ID & "）：获取皮肤太过频繁，请 5 分钟后再试！") Else @@ -514,14 +510,14 @@ UseDefault: Result = McSkinDownload(Result) If Data.IsAborted Then Throw New ThreadInterruptedException("当前任务已取消：" & UserName) Data.Output = Result + Catch ex As ThreadInterruptedException + Data.Output = "" + Return Catch ex As Exception - If ex.GetType.Name = "ThreadInterruptedException" Then - Data.Output = "" - Return - ElseIf GetExceptionSummary(ex).Contains("429") Then + If ex.GetBrief.Contains("(429)") Then Data.Output = PathImage & "Skins/Steve.png" Log("[Minecraft] 获取统一通行证皮肤失败（" & UserName & "）：获取皮肤太过频繁，请 5 分钟后再试！", LogLevel.Hint) - ElseIf GetExceptionSummary(ex).Contains("未设置自定义皮肤") Then + ElseIf ex.GetBrief.Contains("未设置自定义皮肤") Then Data.Output = PathImage & "Skins/Steve.png" Log("[Minecraft] 用户未设置自定义皮肤，跳过皮肤加载") Else @@ -550,26 +546,26 @@ Finish: RunInUi(Sub() If FrmLoginAuthSkin IsNot Nothing AndAlso FrmLoginAuthSkin.Skin IsNot Nothing Then FrmLoginAuthSkin.Skin.Clear()) '获取 Url Dim UserName As String = Data.Input(0) - Dim Uuid As String = Data.Input(1) + Dim UUID As String = Data.Input(1) If UserName = "" Then Data.Output = PathImage & "Skins/Steve.png" Log("[Minecraft] 获取 Authlib-Injector 皮肤失败，ID 为空") GoTo Finish End If Try - Dim Result As String = McSkinGetAddress(Uuid, "Auth") + Dim Result As String = McSkinGetAddress(UUID, "Auth") If Data.IsAborted Then Throw New ThreadInterruptedException("当前任务已取消：" & UserName) Result = McSkinDownload(Result) If Data.IsAborted Then Throw New ThreadInterruptedException("当前任务已取消：" & UserName) Data.Output = Result + Catch ex As ThreadInterruptedException + Data.Output = "" + Return Catch ex As Exception - If ex.GetType.Name = "ThreadInterruptedException" Then - Data.Output = "" - Return - ElseIf GetExceptionSummary(ex).Contains("429") Then + If ex.GetBrief.Contains("(429)") Then Data.Output = PathImage & "Skins/Steve.png" Log("[Minecraft] 获取 Authlib-Injector 皮肤失败（" & UserName & "）：获取皮肤太过频繁，请 5 分钟后再试！", LogLevel.Hint) - ElseIf GetExceptionSummary(ex).Contains("未设置自定义皮肤") Then + ElseIf ex.GetBrief.Contains("未设置自定义皮肤") Then Data.Output = PathImage & "Skins/Steve.png" Log("[Minecraft] 用户未设置自定义皮肤，跳过皮肤加载") Else diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml index 1cc6a70..db61276 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" - xmlns:local="clr-namespace:PCL"> + xmlns:local="clr-namespace:PCL" PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml.vb index b3323fe..84efb45 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLaunchRight.xaml.vb @@ -1,9 +1,10 @@ -Public Class PageLaunchRight - Implements IRefreshable +Imports System.Windows.Threading + +Public Class PageLaunchRight + Implements IRefreshable, IDispatcherUnhandledException Private Sub Init() Handles Me.Loaded PanBack.ScrollToHome() - PanScroll = PanBack '不知道为啥不能在 XAML 设置 PanLog.Visibility = If(ModeDebug, Visibility.Visible, Visibility.Collapsed) '快照版提示 #If BETA Then @@ -28,7 +29,7 @@ ''' 刷新主页。 ''' Private Sub Refresh() Handles Me.Loaded - RunInNewThread( + RunInThread( Sub() Try SyncLock RefreshLock @@ -37,37 +38,20 @@ Catch ex As Exception Log(ex, "加载 PCL 主页自定义信息失败", If(ModeDebug, LogLevel.Msgbox, LogLevel.Hint)) End Try - End Sub, $"刷新主页 #{GetUuid()}") + End Sub) End Sub Private Sub RefreshReal() - Dim Content As String = "" - Dim Url As String + Dim Content As String = Nothing, Url As String = Nothing Select Case Setup.Get("UiCustomType") Case 1 '加载本地文件 Log("[Page] 主页自定义数据来源：本地文件") Content = ReadFile(Path & "PCL\Custom.xaml") 'ReadFile 会进行存在检测 Case 2 + '联网下载 Url = Setup.Get("UiCustomNet") -Download: - '加载联网文件 - If String.IsNullOrWhiteSpace(Url) Then Exit Select - If Url = Setup.Get("CacheSavedPageUrl") AndAlso File.Exists(PathTemp & "Cache\Custom.xaml") Then - '缓存可用 - Log("[Page] 主页自定义数据来源：联网缓存文件") - Content = ReadFile(PathTemp & "Cache\Custom.xaml") - '后台更新缓存 - OnlineLoader.Start(Url) - Else - '缓存不可用 - Log("[Page] 主页自定义数据来源：联网全新下载") - Hint("正在加载主页……") - RunInUiWait(Sub() LoadContent("")) '在加载结束前清空页面 - Setup.Set("CacheSavedPageVersion", "") - OnlineLoader.Start(Url) '下载完成后将会再次触发更新 - Return - End If Case 3 + '预设 Select Case Setup.Get("UiCustomPreset") Case 0 Log("[Page] 主页预设：你知道吗") @@ -89,59 +73,73 @@ Download: " Case 2 Log("[Page] 主页预设：Minecraft 新闻") - Url = "https://pcl.mcnews.thestack.top" - GoTo Download + Url = "https://mcnews.meloong.com" Case 3 Log("[Page] 主页预设：简单主页") Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/MFn233/Custom.xaml" - GoTo Download Case 4 Log("[Page] 主页预设：每日整合包推荐") Url = "https://pclsub.sodamc.com/" - GoTo Download Case 5 Log("[Page] 主页预设：Minecraft 皮肤推荐") Url = "https://forgepixel.com/pcl_sub_file" - GoTo Download Case 6 Log("[Page] 主页预设：OpenBMCLAPI 仪表盘 Lite") Url = "https://pcl-bmcl.milu.ink/" - GoTo Download Case 7 Log("[Page] 主页预设：主页市场") Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/JingHai-Lingyun/Custom.xaml" - GoTo Download Case 8 Log("[Page] 主页预设：更新日志") Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/Joker2184/UpdateHomepage.xaml" - GoTo Download Case 9 Log("[Page] 主页预设：PCL 新功能说明书") Url = "https://raw.gitcode.com/WForst-Breeze/WhatsNewPCL/raw/main/Custom.xaml" - GoTo Download Case 10 Log("[Page] 主页预设：OpenMCIM Dashboard") Url = "https://files.mcimirror.top/PCL" - GoTo Download Case 11 Log("[Page] 主页预设：杂志主页") Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/Ext1nguisher/Custom.xaml" - GoTo Download Case 12 Log("[Page] 主页预设：PCL GitHub 仪表盘") Url = "https://ddf.pcl-community.org/Custom.xaml" - GoTo Download + Case 13 + Log("[Page] 主页预设：PCL 更新摘要") + Url = "https://raw.gitcode.com/ENC_Euphony/PCL-AI-Summary-HomePage/raw/master/Custom.xaml" End Select End Select + '联网下载 + If Not String.IsNullOrWhiteSpace(Url) Then + If Url = Setup.Get("CacheSavedPageUrl") AndAlso File.Exists(PathTemp & "Cache\Custom.xaml") Then + '缓存可用 + Log("[Page] 主页自定义数据来源：联网缓存文件") + Content = ReadFile(PathTemp & "Cache\Custom.xaml") + '后台更新缓存 + OnlineLoader.Start(New Tuple(Of String, Boolean)(Url, False)) + Else + '缓存不可用 + Log("[Page] 主页自定义数据来源：联网全新下载") + Hint("正在加载主页……") + RunInUiWait(Sub() LoadContent(Nothing)) '在加载结束前清空页面 + Setup.Set("CacheSavedPageVersion", "") + OnlineLoader.Start(New Tuple(Of String, Boolean)(Url, True)) '下载完成后将会再次触发更新 + Return + End If + End If + '同步到 UI RunInUi(Sub() LoadContent(Content)) End Sub Private RefreshLock As New Object '联网获取主页文件 - Private OnlineLoader As New LoaderTask(Of String, Integer)("下载主页", AddressOf OnlineLoaderSub) With {.ReloadTimeout = 10 * 60 * 1000} - Private Sub OnlineLoaderSub(Task As LoaderTask(Of String, Integer)) - Dim Address As String = Task.Input '#3721 中连续触发两次导致内容变化 + Private OnlineLoader As New LoaderTask(Of Tuple(Of String, Boolean), Integer)("下载主页", AddressOf OnlineLoaderSub) With {.ReloadTimeout = 10 * 60 * 1000} + Private Sub OnlineLoaderSub(Task As LoaderTask(Of Tuple(Of String, Boolean), Integer)) + Dim Address As String = Task.Input.Item1 '#3721 中连续触发两次导致内容变化 + Dim ShouldRefresh As Boolean = Task.Input.Item2 Try + '替换自定义变量与设置 + Address = ArgumentReplace(Address, AddressOf WebUtility.HtmlEncode) '获取版本校验地址 Dim VersionAddress As String If Address.Contains(".xaml") Then @@ -154,31 +152,27 @@ Download: End If '校验版本 Dim Version As String = "" - Dim NeedDownload As Boolean = True Try Version = NetRequestByClientRetry(VersionAddress) If Version.Length > 1000 Then Throw New Exception($"获取的主页版本过长（{Version.Length} 字符）") Dim CurrentVersion As String = Setup.Get("CacheSavedPageVersion") If Version <> "" AndAlso CurrentVersion <> "" AndAlso Version = CurrentVersion Then Log($"[Page] 当前缓存的主页已为最新，当前版本：{Version}，检查源：{VersionAddress}") - NeedDownload = False - Else - Log($"[Page] 需要下载联网主页，当前版本：{Version}，检查源：{VersionAddress}") + Return End If + Log($"[Page] 需要下载联网主页，当前版本：{Version}，检查源：{VersionAddress}") Catch exx As Exception Log(exx, $"联网获取主页版本失败", LogLevel.Developer) Log($"[Page] 无法检查联网主页版本，将直接下载，检查源：{VersionAddress}") End Try '实际下载 - If NeedDownload Then - Dim FileContent As String = NetRequestByClientRetry(Address) - Log($"[Page] 已联网下载主页，内容长度：{FileContent.Length}，来源：{Address}") - Setup.Set("CacheSavedPageUrl", Address) - Setup.Set("CacheSavedPageVersion", Version) - WriteFile(PathTemp & "Cache\Custom.xaml", FileContent) - End If - '要求刷新 - RunInUi(AddressOf Refresh) '不直接调用 Refresh，以防止死循环（#6245） + Dim FileContent As String = NetRequestByClientRetry(Address) + Log($"[Page] 已联网下载主页，内容长度：{FileContent.Length}，来源：{Address}") + Setup.Set("CacheSavedPageUrl", Address) + Setup.Set("CacheSavedPageVersion", Version) + WriteFile(PathTemp & "Cache\Custom.xaml", FileContent) + '若内容变更则要求刷新 + If LoadedContentHash <> FileContent.GetHashCode() AndAlso ShouldRefresh Then Refresh() Catch ex As Exception Log(ex, $"下载主页失败（{Address}）", If(ModeDebug, LogLevel.Msgbox, LogLevel.Hint)) End Try @@ -205,7 +199,7 @@ Download: ''' Private Sub ClearCache() LoadedContentHash = -1 - OnlineLoader.Input = "" + OnlineLoader.Input = New Tuple(Of String, Boolean)("", True) Setup.Set("CacheSavedPageUrl", "") Setup.Set("CacheSavedPageVersion", "") Log("[Page] 已清空主页缓存") @@ -216,47 +210,59 @@ Download: ''' 必须在 UI 线程调用。 ''' Private Sub LoadContent(Content As String) - SyncLock LoadContentLock - '如果加载目标内容一致则不加载 - Dim Hash = Content.GetHashCode() - If Hash = LoadedContentHash Then Return - LoadedContentHash = Hash - '实际加载内容 - PanCustom.Children.Clear() - If String.IsNullOrWhiteSpace(Content) Then - Log($"[Page] 实例化：清空主页 UI，来源为空") - Return - End If - Dim LoadStartTime As Date = Date.Now - Try + Try + SyncLock LoadContentLock + '如果加载目标内容一致则不加载 + Dim Hash = If(Content, "").GetHashCode() + If Hash = LoadedContentHash Then Return + LoadedContentHash = Hash + '实际加载内容 + PanCustom.Children.Clear() + If String.IsNullOrWhiteSpace(Content) Then + Log($"[Page] 实例化：清空主页 UI，来源为空") + Return + End If + Dim LoadStartTime As Date = Date.Now '修改时应同时修改 PageOtherHelpDetail.Init - Content = HelpArgumentReplace(Content) + Content = ArgumentReplace(Content, AddressOf EscapeXML) Do While Content.Contains("xmlns") Content = Content.RegexReplace("xmlns[^""']*(""|')[^""']*(""|')", "").Replace("xmlns", "") '禁止声明命名空间 Loop Content = "" & Content & "" Log($"[Page] 实例化：加载主页 UI 开始，最终内容长度：{Content.Count}") PanCustom.Children.Add(GetObjectFromXML(Content)) - Catch ex As Exception - If ModeDebug Then - Log(ex, "加载失败的主页内容：" & vbCrLf & Content) - If MyMsgBox(If(TypeOf ex Is UnauthorizedAccessException, ex.Message, $"主页内容编写有误，请根据下列错误信息进行检查：{vbCrLf}{GetExceptionSummary(ex)}"), - "加载主页界面失败", "重试", "取消") = 1 Then - GoTo Refresh '防止 SyncLock 死锁 - End If - Else - Log(ex, "加载主页界面失败", LogLevel.Hint) - End If - Return - End Try - Dim LoadCostTime = (Date.Now - LoadStartTime).Milliseconds - Log($"[Page] 实例化：加载主页 UI 完成，耗时 {LoadCostTime}ms") - If LoadCostTime > 3000 Then Hint($"主页加载过于缓慢（花费了 {Math.Round(LoadCostTime / 1000, 1)} 秒），请向主页作者反馈此问题，或暂时停止使用该主页") - End SyncLock - Return -Refresh: - ForceRefresh() + '加载计时 + Dim LoadCostTime = (Date.Now - LoadStartTime).Milliseconds + Log($"[Page] 实例化：加载主页 UI 完成，耗时 {LoadCostTime}ms") + If LoadCostTime > 3000 Then Hint($"主页加载过于缓慢（花费了 {Math.Round(LoadCostTime / 1000, 1)} 秒），请向主页作者反馈此问题，或暂时停止使用该主页") + End SyncLock + Catch ex As Exception + Log(ex, "加载失败的主页内容：" & vbCrLf & Content) + OnLoadContentFailed(ex) + End Try End Sub + ''' + ''' 加载主页失败时调用。 + ''' + Private Sub OnLoadContentFailed(ex As Exception) + If ModeDebug OrElse Setup.Get("UiCustomType") = 1 Then + Log(ex, "加载主页失败") + If MyMsgBox(If(TypeOf ex Is UnauthorizedAccessException, ex.Message, $"主页内容编写有误，请根据下列错误信息进行检查：{vbCrLf}{ex.GetBrief}"), + "加载主页失败", "重试", "取消") = 1 Then ForceRefresh() + Else + Log(ex, "加载主页失败", LogLevel.Hint) + End If + End Sub + ''' + ''' 捕获主页在 Measure 和 Arrange 阶段抛出的异常。 + ''' + Private Sub DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Implements IDispatcherUnhandledException.DispatcherUnhandledException + If TypeOf e.Exception IsNot Markup.XamlParseException Then Return + e.Handled = True + LoadContent(Nothing) + OnLoadContentFailed(e.Exception) + End Sub + Private LoadedContentHash As Integer = -1 Private LoadContentLock As New Object diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginAuthSkin.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginAuthSkin.xaml.vb index 56970a4..a339893 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginAuthSkin.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginAuthSkin.xaml.vb @@ -50,7 +50,7 @@ If CType(McLoginLoader.Input, McLoginServer).ForceReselectProfile Then Hint("正在尝试更换，请稍候！") Else - Hint("正在登录中，请稍后再更换角色！", HintType.Critical) + Hint("正在登录中，请稍后再更换角色！", HintType.Red) End If Return End If diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginLegacy.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginLegacy.xaml.vb index 33cafbb..780d8d6 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginLegacy.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginLegacy.xaml.vb @@ -68,7 +68,7 @@ Public Class PageLoginLegacy End Sub Private Sub Skin_Click() Handles Skin.Click If (Setup.Get("UiHiddenPageSetup") OrElse Setup.Get("UiHiddenSetupLaunch")) AndAlso Not PageSetupUI.HiddenForceShow Then - Hint("启动设置已被禁用！", HintType.Critical) + Hint("启动设置已被禁用！", HintType.Red) Else FrmMain.PageChange(FormMain.PageType.Setup, FormMain.PageSubType.SetupLaunch) '切换到皮肤设置页面 End If diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml index cf470d4..8364edd 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml @@ -27,9 +27,9 @@ - - diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml.vb index ae823a7..0d5ed36 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMs.xaml.vb @@ -90,7 +90,7 @@ Catch ex As Exception If ex.Message = "$$" Then ElseIf ex.Message.StartsWith("$") Then - Hint(ex.Message.TrimStart("$"), HintType.Critical) + Hint(ex.Message.TrimStart("$"), HintType.Red) ElseIf TypeOf ex Is Security.Authentication.AuthenticationException AndAlso ex.Message.ContainsF("SSL/TLS") Then Log(ex, "正版登录验证失败，请考虑在 [设置 → 其他] 中关闭 [在正版登录时验证 SSL 证书]，然后再试。" & vbCrLf & vbCrLf & "原始错误信息：", LogLevel.Msgbox) Else diff --git a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMsSkin.xaml.vb b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMsSkin.xaml.vb index 325a077..874d53a 100644 --- a/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMsSkin.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageLaunch/PageLoginMsSkin.xaml.vb @@ -77,7 +77,7 @@ Return End If If McLoginLoader.State = LoadState.Failed Then - Hint("登录失败，无法更改皮肤！", HintType.Critical) + Hint("登录失败，无法更改皮肤！", HintType.Red) Return End If Dim SkinInfo As McSkinInfo = McSkinSelect() @@ -86,28 +86,27 @@ IsChanging = True '开始实际获取 RunInNewThread( - Async Sub() + Sub() Try Retry: - If McLoginMsLoader.State = LoadState.Loading Then McLoginMsLoader.WaitForExit() '等待登录结束 + Do While McLoginMsLoader.State = LoadState.Loading '等待登录结束 + Thread.Sleep(10) + Loop + If McLoginMsLoader.State = LoadState.Failed Then Throw New Exception("登录失败", McLoginMsLoader.Error) Dim AccessToken As String = Setup.Get("CacheMsV2Access") Dim Uuid As String = Setup.Get("CacheMsV2Uuid") - - 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(ReadFileBytes(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 + Dim Result As String = NetRequestByClientRetry("https://api.minecraftservices.com/minecraft/profile/skins", HttpMethod.Post, + Content:=New Net.Http.MultipartFormDataContent From { + {New Net.Http.StringContent(If(SkinInfo.IsSlim, "slim", "classic")), "variant"}, + {New Net.Http.ByteArrayContent(ReadFileBytes(SkinInfo.LocalFile)), "file", GetFileNameFromPath(SkinInfo.LocalFile)} + }, + Headers:={{"Authorization", "Bearer " & AccessToken}, {"Accept", "*/*"}, {"User-Agent", "MojangSharp/0.1"}}) 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").ToString, HintType.Critical) + Hint("更改皮肤失败：" & GetJson(Result)("error").ToString, HintType.Red) Return End If '获取新皮肤地址 @@ -122,8 +121,8 @@ Retry: Next Throw New Exception("未知错误（" & Result & "）") Catch ex As Exception - If ex.GetType.Equals(GetType(Tasks.TaskCanceledException)) Then - Hint("更改皮肤失败：与 Mojang 皮肤服务器的连接超时，请检查你的网络是否通畅！", HintType.Critical) + If TypeOf ex Is OperationCanceledException OrElse TypeOf ex Is TimeoutException Then + Hint("更改皮肤失败：连接皮肤服务器超时，请稍后再试，或使用 VPN 改善网络环境", HintType.Red) Else Log(ex, "更改皮肤失败", LogLevel.Hint) End If diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml b/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml deleted file mode 100644 index 7ac9b47..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml +++ /dev/null @@ -1,38 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml.vb deleted file mode 100644 index 304bb68..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkFeedback.xaml.vb +++ /dev/null @@ -1,2 +0,0 @@ -Public Class PageLinkFeedback -End Class diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml b/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml deleted file mode 100644 index 9cf794e..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml +++ /dev/null @@ -1,235 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb deleted file mode 100644 index b4f7a3b..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb +++ /dev/null @@ -1,395 +0,0 @@ -Public Class PageLinkHiper - Public Const RequestVersion As Char = "2" - - '记录的启动情况 - Public Shared IsServerSide As Boolean - Private Shared HostIp As String - Private Shared HostPort As Integer - -#Region "初始化" - - '加载器初始化 - Private Sub LoaderInit() Handles Me.Initialized - PageLoaderInit(Load, PanLoad, PanContent, PanAlways, InitLoader, AutoRun:=False) - '注册自定义的 OnStateChanged - AddHandler InitLoader.OnStateChangedUi, AddressOf OnLoadStateChanged - End Sub - - Private IsLoad As Boolean = False - Private Sub OnLoaded() Handles Me.Loaded - FormMain.EndProgramForce(ProcessReturnValues.Aborted) - If IsLoad Then Return - IsLoad = True - '启动监视线程 - If Not IsWatcherStarted Then RunInNewThread(AddressOf WatcherThread, "Hiper Watcher") - '读取索引码 - Try - Dim Time As String = Setup.Get("LinkHiperCertTime") - If Time = "" Then - Log("[HiPer] 没有缓存凭证") - ElseIf Date.Parse(Time) > Date.Now Then - TextCert.Text = Setup.Get("LinkHiperCertLast") - Log("[HiPer] 缓存凭证尚未过期：" & Time) - CurrentSubpage = Subpages.PanSelect - Else - Log("[HiPer] 缓存凭证已过期：" & Time) - LabCertTitle.Text = "输入索引码" - LabCertDesc.Text = "你的 HiPer 索引码已经过期，请输入新的索引码。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。" - End If - Catch ex As Exception - Log(ex, "读取缓存凭证失败") - Setup.Set("LinkHiperCertTime", "") - End Try - End Sub - -#End Region - -#Region "加载步骤" - - Public Shared PathHiper As String = PathAppdata & "联机模块\" - Public Shared WithEvents InitLoader As New LoaderCombo(Of Integer)("HiPer 初始化", { - New LoaderTask(Of Integer, Integer)("网络环境：连通检测", AddressOf InitPingCheck) With {.Block = False, .ProgressWeight = 0.5}, - New LoaderTask(Of Integer, Integer)("网络环境：IP 检测", AddressOf InitIpCheck) With {.Block = False, .ProgressWeight = 1}, - New LoaderTask(Of Integer, Integer)("检查网络环境", AddressOf InitCheck) With {.ProgressWeight = 0.5}, - New LoaderTask(Of Integer, List(Of NetFile))("获取所需文件", AddressOf InitGetFile) With {.ProgressWeight = 4}, - New LoaderDownload("下载所需文件", New List(Of NetFile)) With {.ProgressWeight = 4}, - New LoaderTask(Of Integer, Integer)("启动联机模块", AddressOf InitLaunch) With {.ProgressWeight = 7} - }) - - '检查网络状态 - Private Shared Sub InitPingCheck(Task As LoaderTask(Of Integer, Integer)) - End Sub - Private Shared Sub InitIpCheck() - 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)) - End Sub - - '获取所需文件 - Private Shared Sub InitGetFile(Task As LoaderTask(Of Integer, List(Of NetFile))) - End Sub - Public Class CertOutdatedException - Inherits Exception - End Class - '启动联机模块 - Private Shared Sub InitLaunch(Task As LoaderTask(Of Integer, Integer)) - End Sub - Private Shared PingNodes As Integer, AllNodes As List(Of String) - -#End Region - -#Region "进程管理" - - Private Shared _HiperState As LoadState = LoadState.Waiting - Public Shared Property HiperState As LoadState - Get - Return _HiperState - End Get - Set(value As LoadState) - _HiperState = value - RunInUi(Sub() If FrmLinkLeft IsNot Nothing Then CType(FrmLinkLeft.ItemHiper.Buttons(0), MyIconButton).Visibility = If(HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading, Visibility.Visible, Visibility.Collapsed)) - End Set - End Property - Public Shared Sub ModuleStopManually() '关闭联机模块按钮 - HiperExit(False) - End Sub - - Private Shared HiperIp As String = Nothing - Private Shared HiperProcessId As Integer = -1, McbProcessId As Integer = -1 - Private Shared HiperCertTime As Date = Date.Now - - ''' - ''' 若程序正在运行，则结束程序进程，同时初始化状态数据。返回是否关闭了相关进程。 - ''' - Public Shared Function HiperStop(SleepWhenKilled As Boolean) As Boolean - Return False - End Function - ''' - ''' 启动程序，并等待初始化完成后退出运行，同时更新 HiperIp。 - ''' 若启动失败，则会直接抛出异常。 - ''' 若程序正在运行，则会先停止其运行。 - ''' - Public Shared Sub HiperStart(Task As LoaderTask(Of Integer, Integer)) - End Sub - - 'Hiper 日志 - Private Shared Sub HiperLogLine(Content As String, Task As LoaderTask(Of Integer, Integer)) - End Sub - Private Shared PossibleFailReason As String = Nothing - -#End Region - -#Region "监视线程" - - '主 Timer 线程 - Private IsWatcherStarted As Boolean = False - Private Sub WatcherThread() - Dim Sec15 As Integer = 0 - Do While True - Try - For i = 1 To 5 - Thread.Sleep(200) - If InitLoader.State = LoadState.Loading Then - RunInUi(AddressOf UpdateProgress) - End If - Next - Thread.Sleep(1000) - Sec15 += 1 - WatcherTimer1() - If Sec15 = 15 Then - Sec15 = 0 - WatcherTimer15() - End If - Catch ex As Exception - Log(ex, "联机模块主时钟出错", LogLevel.Feedback) - Thread.Sleep(20000) - End Try - Loop - End Sub - - '每 1 秒执行的 Timer - Private Sub WatcherTimer1() - If HiperState <> LoadState.Finished Then Return - RunInUi(Sub() - '索引码剩余时间 - Dim Span As TimeSpan = HiperCertTime - Date.Now - If Span.TotalDays >= 30 Then - LabFinishTime.Text = "> 30 天" - ElseIf Span.TotalDays >= 4 Then - LabFinishTime.Text = Span.Days & " 天" - ElseIf Span.TotalDays >= 1 Then - LabFinishTime.Text = Span.Days & " 天" & If(Span.Hours > 0, " " & Span.Hours & " 小时", "") - ElseIf Span.TotalMinutes >= 10 Then - LabFinishTime.Text = Span.Hours & ":" & Span.Minutes.ToString.PadLeft(2, "0") & "'" - Else - LabFinishTime.Text = Span.Minutes & "'" & Span.Seconds.ToString.PadLeft(2, "0") & """" - End If - '提示索引码即将到期 - If Span.TotalSeconds <= 5 * 60 AndAlso Span.TotalSeconds > 5 * 60 - 1 AndAlso Setup.Get("LinkHiperCertWarn") Then - MyMsgBox("你的索引码还有不到 5 分钟就要过期了！" & vbCrLf & "你可以在设置中关闭这个提示……", "索引码即将过期", "我知道了……") - ShowWindowToTop(Handle) - Beep() - End If - '检查索引码到期 - If Span.TotalSeconds < 2 Then - LabCertTitle.Text = "索引码已过期" - LabCertDesc.Text = "你的 HiPer 索引码已经过期，请输入新的索引码。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。" - TextCert.Text = "" - HiperExit(True) - ShowWindowToTop(Handle) - Beep() - Return - End If - '网络质量 - Dim QualityScore As Integer = If(IpIsInChina, 0, -2) - QualityScore -= Math.Ceiling((Math.Min(PingTime, 600) + Math.Min(PingNodes, 600)) / 80) - Select Case QualityScore - Case Is >= -1 - LabFinishQuality.Text = "优秀" - Case Is >= -2 - LabFinishQuality.Text = "优良" - Case Is >= -3 - LabFinishQuality.Text = "良好" - Case Is >= -5 - LabFinishQuality.Text = "一般" - Case Is >= -7 - LabFinishQuality.Text = "较差" - Case Else - LabFinishQuality.Text = "很差" - End Select - 'Ping - If HostPing <> -1 Then - If FrmLinkHiper IsNot Nothing AndAlso FrmLinkHiper.LabFinishPing.IsLoaded Then - FrmLinkHiper.LabFinishPing.Text = HostPing & "ms" - End If - End If - End Sub) - End Sub - '每 15 秒执行的 Timer - Private Shared HostPing As Integer = -1 - Private Sub WatcherTimer15() - End Sub - -#End Region - -#Region "PanCert | 索引码输入页面" - - '检测输入 - Private Sub TextCert_ValidateChanged(sender As Object, e As EventArgs) Handles TextCert.ValidateChanged - BtnCertDone.IsEnabled = TextCert.ValidateResult = "" - End Sub - Private Sub TextCert_KeyDown(sender As Object, e As KeyEventArgs) Handles TextCert.KeyDown - If e.Key = Key.Enter AndAlso BtnCertDone.IsEnabled Then BtnCertDone_Click() '允许回车确认 - End Sub - - '确认 - Private Sub BtnCertDone_Click() Handles BtnCertDone.Click - CurrentSubpage = Subpages.PanSelect - End Sub - -#End Region - -#Region "PanSelect | 种类选择页面" - - '返回 - Private Sub BtnSelectReturn_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectReturn.MouseLeftButtonUp - LabCertTitle.Text = "输入索引码" - LabCertDesc.Text = "你需要获取索引码才能使用 HiPer。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。" - CurrentSubpage = Subpages.PanCert - End Sub - - '创建房间 - Private Sub BtnSelectCreate_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectCreate.MouseLeftButtonUp - End Sub - Private Sub RoomCreate(Port As Integer) - '记录信息 - HostIp = Nothing : HostPort = Port - IsServerSide = True - '启动 - InitLoader.Start(IsForceRestart:=True) - End Sub - - '加入房间 - Private Sub BtnSelectJoin_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectJoin.MouseLeftButtonUp - End Sub - Private Sub RoomJoin(Ip As String, Port As Integer) - '记录信息 - HostIp = Ip : HostPort = Port - IsServerSide = False - '启动 - InitLoader.Start(IsForceRestart:=True) - End Sub - -#End Region - -#Region "PanLoad | 加载中页面" - - '承接状态切换的 UI 改变 - Private Sub OnLoadStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState) - End Sub - Private Shared LoadStep As String = "准备初始化" - Private Shared Sub SetLoadDesc(Intro As String, [Step] As String) - Log("[Hiper] 连接步骤：" & Intro) - LoadStep = [Step] - RunInUiWait(Sub() - If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.LabLoadDesc.IsLoaded Then Return - FrmLinkHiper.LabLoadDesc.Text = Intro - FrmLinkHiper.UpdateProgress() - End Sub) - End Sub - - '承接重试 - Private Sub CardLoad_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles CardLoad.MouseLeftButtonUp - If Not InitLoader.State = LoadState.Failed Then Return - InitLoader.Start(IsForceRestart:=True) - End Sub - - '取消加载 - Private Sub CancelLoad() Handles BtnLoadCancel.Click - If InitLoader.State = LoadState.Loading Then - CurrentSubpage = Subpages.PanSelect - InitLoader.Abort() - Else - InitLoader.State = LoadState.Waiting - End If - HiperStop(False) - End Sub - - '进度改变 - Private Sub UpdateProgress(Optional Value As Double = -1) - If Value = -1 Then Value = InitLoader.Progress - Dim DisplayingProgress As Double = ColumnProgressA.Width.Value - If Math.Round(Value - DisplayingProgress, 3) = 0 Then Return - If DisplayingProgress > Value Then - ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star) - ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star) - AniStop("Hiper Progress") - Else - Dim NewProgress As Double = If(Value = 1, 1, (Value - DisplayingProgress) * 0.2 + DisplayingProgress) - AniStart({ - AaGridLengthWidth(ColumnProgressA, NewProgress - ColumnProgressA.Width.Value, 300, Ease:=New AniEaseOutFluent), - AaGridLengthWidth(ColumnProgressB, (1 - NewProgress) - ColumnProgressB.Width.Value, 300, Ease:=New AniEaseOutFluent) - }, "Hiper Progress") - End If - End Sub - Private Sub CardResized() Handles CardLoad.SizeChanged - RectProgressClip.Rect = New Rect(0, 0, CardLoad.ActualWidth, 12) - End Sub - -#End Region - -#Region "PanFinish | 加载完成页面" - - '复制 IP - Private Sub BtnFinishIp_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishIp.MouseLeftButtonUp - ClipboardSet(LabFinishIp.Text) - End Sub - - '退出 - Private Sub BtnFinishExit_Click(sender As Object, e As EventArgs) Handles BtnFinishExit.Click - If IsServerSide AndAlso MyMsgBox("你确定要关闭联机房间吗？", "确认退出", "确定", "取消", IsWarn:=True) = 2 Then Return - HiperExit(False) - End Sub - - '复制联机码 - Private Sub BtnFinishCopy_Click(sender As Object, e As EventArgs) Handles BtnFinishCopy.Click - End Sub - - 'Ping 房主 - Private Sub BtnFinishPing_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishPing.MouseLeftButtonUp - LabFinishPing.Text = "检测中" - If TaskPingHost.State = LoadState.Loading Then Return - TaskPingHost.Start(True, IsForceRestart:=True) - End Sub - Private Shared TaskPingHost As New LoaderTask(Of Boolean, Integer)("HiPer Ping Host", - Sub(Task As LoaderTask(Of Boolean, Integer)) - HostPing = -1 - HostPing = Ping(HostIp, 5000, Task.Input) - End Sub) - -#End Region - -#Region "子页面管理" - - Public Enum Subpages - PanCert - PanSelect - PanFinish - End Enum - Private _CurrentSubpage As Subpages = Subpages.PanCert - Public Property CurrentSubpage As Subpages - Get - Return _CurrentSubpage - End Get - Set(value As Subpages) - If _CurrentSubpage = value Then Return - _CurrentSubpage = value - Log("[Hiper] 子页面更改为 " & GetStringFromEnum(value)) - PageOnContentExit() - If value = Subpages.PanSelect Then - LabSelectCode.Text = "(" & TextCert.Text.Substring(0, Math.Min(TextCert.Text.Length, 3)) & "…)" - End If - End Set - End Property - - Private Sub PageLinkHiper_OnPageEnter() Handles Me.PageEnter - FrmLinkHiper.PanCert.Visibility = If(CurrentSubpage = Subpages.PanCert, Visibility.Visible, Visibility.Collapsed) - FrmLinkHiper.PanSelect.Visibility = If(CurrentSubpage = Subpages.PanSelect, Visibility.Visible, Visibility.Collapsed) - FrmLinkHiper.PanFinish.Visibility = If(CurrentSubpage = Subpages.PanFinish, Visibility.Visible, Visibility.Collapsed) - End Sub - - Private Shared Sub HiperExit(ExitToCertPage As Boolean) - Log("[Hiper] 要求退出 Hiper（当前加载器状态为 " & GetStringFromEnum(InitLoader.State) & "）") - HiperStop(False) - If InitLoader.State = LoadState.Loading Then InitLoader.Abort() - If InitLoader.State = LoadState.Failed Then InitLoader.State = LoadState.Waiting - RunInUi(Sub() - If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.IsLoaded Then Return - FrmLinkHiper.CurrentSubpage = If(ExitToCertPage, Subpages.PanCert, Subpages.PanSelect) - FrmLinkHiper.PageOnContentExit() - End Sub) - End Sub - -#End Region - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml b/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml deleted file mode 100644 index 9b334f6..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml +++ /dev/null @@ -1,50 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb deleted file mode 100644 index f1e6312..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb +++ /dev/null @@ -1,430 +0,0 @@ -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 Shared IoiId As String, IoiPassword As String - Private Shared IoiProcess As Process = Nothing - Private Shared IoiState As LoadState = LoadState.Waiting - - ''' - ''' 若 Ioi 正在运行，则结束 Ioi 进程，同时初始化状态数据。返回是否关闭了对应进程。 - ''' - Public Shared Function IoiStop(SleepWhenKilled As Boolean) As Boolean - Return False - End Function - ''' - ''' 启动 Ioi，并等待初始化完成后退出运行，同时更新 IoiId 与 IoiPassword。 - ''' 正常初始化返回 True，需要更新返回 False，其余情况抛出异常。 - ''' 若 Ioi 正在运行，则会先停止其运行。 - ''' - Public Shared Function IoiStart() As Boolean - Return False - End Function - - 'Ioi 日志 - Private Shared Sub IoiLogLine(Content As String) - End Sub - Private Shared LogLinesCount As Integer = 0 - Private Shared LastPortsId As String = "" '上一个收到 portssub 的 ID，用于记录端口 - -#End Region - -#Region "时钟" - - 'UI 线程刷新 - Private Shared UserListIdentifyCache As String = "" - Private Shared RoomListIdentifyCache As String = "" - Public Sub RefreshUi() - End Sub - - '工作线程刷新 - Public Sub RefreshWorker() - End Sub - -#End Region - -#Region "发送请求" - - ''' - ''' 发送 Portsub 请求并等待获取控制台端口。进度将从 0 变化至 80%。 - ''' - Private Shared Sub SendPortsubRequest(User As LinkUserIoi) - End Sub - - ''' - ''' 向控制台发送 Connect 请求。 - ''' - Private Shared Sub SendConnectRequest(User As LinkUserIoi) - Dim RawJson As New JObject() - RawJson("version") = RequestVersion - RawJson("name") = GetPlayerName() - RawJson("id") = IoiId - RawJson("type") = "connect" - User.Send(RawJson) - End Sub - - ''' - ''' 向控制台发送 Update 请求。 - ''' - Private Shared Sub SendUpdateRequest(User As LinkUserIoi, Stage As Integer, Optional Unique As Long = -1) - If Unique = -1 Then Unique = GetTimeTick() - Dim RawJson As New JObject - RawJson("name") = GetPlayerName() - RawJson("id") = IoiId - RawJson("type") = "update" - RawJson("stage") = Stage - RawJson("unique") = Unique - If Stage < 3 Then - Dim Rooms As New JArray - For Each Room In RoomListForMe - Dim RoomObject As New JObject - RoomObject("name") = Room.DisplayName - RoomObject("port") = Room.Port - Rooms.Add(RoomObject) - Next - RawJson("rooms") = Rooms - User.PingPending(Unique) = Date.Now - End If - User.Send(RawJson) - End Sub - - ''' - ''' 尝试发送断开请求，并将其从用户列表中移除。 - ''' - Private Shared Sub SendDisconnectRequest(User As LinkUserIoi, Optional Message As String = Nothing, Optional IsError As Boolean = False) - End Sub - -#End Region - -#Region "左边栏操作" - - '刷新连接 - Private Shared Sub BtnListRefresh_Click(sender As MyIconButton, e As EventArgs) - End Sub - '断开连接 - Private Shared Sub BtnListDisconnect_Click(sender As MyIconButton, e As EventArgs) - End Sub - '复制联机码 - Public Shared Sub BtnLeftCopy_Click() Handles BtnLeftCopy.Click - End Sub - -#End Region - -#Region "玩家名" - - ''' - ''' 获取当前的玩家名。 - ''' - Public Shared Function GetPlayerName() As String - '自动生成玩家名 - If AutogenPlayerName Is Nothing Then - If IsPlayerNameValid(McLoginName) Then - AutogenPlayerName = McLoginName() - Else - AutogenPlayerName = "玩家 " & CType(GetHash(If(UniqueAddress, "")) Mod 1048576, Integer).ToString("x5").ToUpper - End If - End If - '获取玩家自定义的名称 - Dim CustomName As String = Setup.Get("LinkName").ToString.Trim() - If CustomName <> "" Then - If IsPlayerNameValid(CustomName) Then - Return CustomName.Trim - Else - Hint("你所设置的玩家名存在异常，已被重置！", HintType.Critical) - Setup.Set("LinkName", "") - End If - End If - '使用自动生成的玩家名 - Return AutogenPlayerName - End Function - Private Shared AutogenPlayerName As String = Nothing '并非由玩家自定义，而是自动生成的玩家名 - ''' - ''' 检查某个玩家名是否合法。 - ''' - Private Shared Function IsPlayerNameValid(Name As String) As Boolean - Return True - End Function - -#End Region - -#Region "请求核心" - - ''' - ''' 启动 Socket 监听核心。 - ''' - Public Shared Sub StartSocketListener() - End Sub - -#End Region - -#Region "用户核心" - - '用户基类 - Public MustInherit Class LinkUserBase - Implements IDisposable - - '基础数据 - Public Uuid As Integer = GetUuid() - Public Id As String - Public DisplayName As String - - '请求管理 - Public Socket As Socket = Nothing - Public Sub Send(Request As JObject) - End Sub - Public ListenerThread As Thread = Nothing - Public Sub StartListener() - End Sub - Public Sub BindSocket(Socket As Socket) - If Me.Socket IsNot Nothing Then Throw New Exception("该用户已经绑定了 Socket") - Me.Socket = Socket - StartListener() - End Sub - - 'Ping - '0：与 Ping 计算无关，不回应 - '1：A to B，2：B to A，3：A to B - Public PingPending As New Dictionary(Of Long, Date) - Public PingRecord As New Queue(Of Integer) - - '心跳包 - Public LastSend As Date = Date.Now - Public LastReceive As Date = Date.Now - - '类型转换 - Public Sub New(Id As String, DisplayName As String) - Me.Id = Id - Me.DisplayName = DisplayName - Log("[IOI] 无通信包的新用户对象：" & ToString()) - End Sub - Public Sub New(Id As String, DisplayName As String, Socket As Socket) - Me.Id = Id - Me.DisplayName = DisplayName - Me.Socket = Socket - Log("[IOI] 新用户对象：" & ToString()) - StartListener() - End Sub - Public Overrides Function ToString() As String - Return DisplayName & " @ " & Id & " #" & Uuid - End Function - Public Shared Widening Operator CType(User As LinkUserBase) As String - Return User.ToString - End Operator - - '释放资源 - Public IsDisposed As Boolean = False - Protected Overridable Sub Dispose(IsDisposing As Boolean) - If Socket IsNot Nothing Then Socket.Dispose() - If ListenerThread IsNot Nothing AndAlso ListenerThread.IsAlive Then ListenerThread.Interrupt() - End Sub - Public Sub Dispose() Implements IDisposable.Dispose - If Not IsDisposed Then - IsDisposed = True - Dispose(True) - End If - GC.SuppressFinalize(Me) - End Sub - End Class - - '用户对象 - Public Shared UserList As New Dictionary(Of String, LinkUserIoi) - Public Class LinkUserIoi - Inherits LinkUserBase - Public Sub New(Id As String, DisplayName As String, Socket As Socket) - MyBase.New(Id, DisplayName, Socket) - End Sub - Public Sub New(Id As String, DisplayName As String) - MyBase.New(Id, DisplayName) - End Sub - - '基础数据 - Public Ports As New Dictionary(Of Integer, String) - Public Rooms As New List(Of RoomEntry) - - '进度与 UI - Public Progress As Double = 0 - Public RelativeThread As Thread = Nothing - - Public Function GetDescription() As String - Return If(Progress < 1, - "正在连接，" & Math.Round(Progress * 100) & "%", - "已连接，" & If(Not PingRecord.Any(), "检查延迟中", Math.Round(PingRecord.Average) & "ms")) - End Function - Public Function ToListItem() As MyListItem - Dim Item As New MyListItem With { - .Title = DisplayName, .Height = 42, .Tag = Me, .Type = MyListItem.CheckType.None, - .Logo = "pack://application:,,,/images/Blocks/Grass.png"} - '绑定图标按钮 - Dim BtnRefresh As New MyIconButton With {.Logo = Logo.IconButtonRefresh, .LogoScale = 0.85, .ToolTip = "刷新", .Tag = Me} - AddHandler BtnRefresh.Click, AddressOf BtnListRefresh_Click - ToolTipService.SetPlacement(BtnRefresh, Primitives.PlacementMode.Bottom) - ToolTipService.SetHorizontalOffset(BtnRefresh, -10) - ToolTipService.SetVerticalOffset(BtnRefresh, 5) - ToolTipService.SetInitialShowDelay(BtnRefresh, 200) - Dim BtnClose As New MyIconButton With {.Logo = Logo.IconButtonCross, .LogoScale = 0.85, .ToolTip = "断开", .Tag = Me} - AddHandler BtnClose.Click, AddressOf BtnListDisconnect_Click - ToolTipService.SetPlacement(BtnClose, Primitives.PlacementMode.Bottom) - ToolTipService.SetHorizontalOffset(BtnClose, -10) - ToolTipService.SetVerticalOffset(BtnClose, 5) - ToolTipService.SetInitialShowDelay(BtnClose, 200) - Item.Buttons = {BtnRefresh, BtnClose} - '刷新并返回 - RefreshUi(Item) - Return Item - End Function - Public Sub RefreshUi(RelatedListItem As MyListItem) - RelatedListItem.Title = DisplayName - RelatedListItem.Info = GetDescription() - RelatedListItem.Buttons(0).Visibility = If(Progress = 1, Visibility.Visible, Visibility.Collapsed) - End Sub - - '释放 - Protected Overrides Sub Dispose(IsDisposing As Boolean) - Log("[IOI] 用户资源释放（IOI, " & DisplayName & "）") - If RelativeThread IsNot Nothing AndAlso RelativeThread.IsAlive Then RelativeThread.Interrupt() - UserList.Remove(Id) - MyBase.Dispose(IsDisposing) - End Sub - End Class - - '房间对象 - Private Shared RoomListForMe As New List(Of RoomEntry) - - Private Function GetRoomList() As List(Of RoomEntry) - Dim RoomList As New List(Of RoomEntry)(RoomListForMe) - For i = 0 To UserList.Count - 1 - If i > UserList.Count - 1 Then Exit For - RoomList.AddRange(UserList.Values(i).Rooms) - Next - Return RoomList - End Function - Public Class RoomEntry - - '基础数据 - Public Port As Integer - Public DisplayName As String - Public User As LinkUserIoi = Nothing '若 IsOwner = True，则此项为 Nothing - Public IsOwner As Boolean - Public ReadOnly Property Ip As String - Get - If IsOwner Then - Return "localhost:" & Port - Else - Return User.Ports(Port) & ":" & Port - End If - End Get - End Property - - '类型转换 - Public Sub New(Port As Integer, DisplayName As String, Optional User As LinkUserIoi = Nothing) - Me.IsOwner = User Is Nothing - Me.User = User - Me.DisplayName = DisplayName - Me.Port = Port - End Sub - Public Overrides Function ToString() As String - Return DisplayName & " - " & Port & " - " & IsOwner - End Function - Public Shared Widening Operator CType(Room As RoomEntry) As String - Return Room.ToString - End Operator - Public Shared Function SelectPort(Room As RoomEntry) As Integer - Return Room.Port - End Function - - 'UI - Public Function GetDescription() As String - If IsOwner Then - Return "由我创建，端口 " & Port - Else - Return "由 " & User.DisplayName & " 创建，端口 " & Port - End If - End Function - Public Function ToListItem() As MyListItem - Dim Item As New MyListItem With { - .Title = DisplayName, .Height = 42, .Info = GetDescription(), .Tag = Me, - .Type = If(IsOwner, MyListItem.CheckType.None, MyListItem.CheckType.Clickable), - .Logo = "pack://application:,,,/images/Blocks/" & If(IsOwner, "GrassPath", "Grass") & ".png"} - If IsOwner Then - '绑定图标按钮 - Dim BtnEdit As New MyIconButton With {.Logo = Logo.IconButtonEdit, .LogoScale = 1, .ToolTip = "修改名称", .Tag = Me} - AddHandler BtnEdit.Click, AddressOf BtnRoomEdit_Click - ToolTipService.SetPlacement(BtnEdit, Primitives.PlacementMode.Bottom) - ToolTipService.SetHorizontalOffset(BtnEdit, -22) - ToolTipService.SetVerticalOffset(BtnEdit, 5) - ToolTipService.SetInitialShowDelay(BtnEdit, 200) - Dim BtnClose As New MyIconButton With {.Logo = Logo.IconButtonCross, .LogoScale = 0.85, .ToolTip = "关闭", .Tag = Me} - AddHandler BtnClose.Click, AddressOf BtnRoomClose_Click - ToolTipService.SetPlacement(BtnClose, Primitives.PlacementMode.Bottom) - ToolTipService.SetHorizontalOffset(BtnClose, -10) - ToolTipService.SetVerticalOffset(BtnClose, 5) - ToolTipService.SetInitialShowDelay(BtnClose, 200) - Item.Buttons = {BtnEdit, BtnClose} - Else - '绑定点击事件 - AddHandler Item.Click, AddressOf BtnRoom_Click - End If - Return Item - End Function - Public Sub RefreshUi(RelatedListItem As MyListItem) - RelatedListItem.Title = DisplayName - RelatedListItem.Info = GetDescription() - End Sub - - End Class - -#End Region - - '正向与反向连接 - Public Shared Sub BtnLeftCreate_Click() Handles BtnLeftCreate.Click - End Sub - Private Shared Sub SendPortsubBack(User As LinkUserIoi, TargetVersion As Integer) - End Sub - - '创建房间 - Private Sub LinkCreate() Handles BtnCreate.Click - End Sub - Private Shared Sub SendUpdateRequestToAllUsers() - For i = 0 To UserList.Count - 1 - If i > UserList.Count - 1 Then Exit For - Dim User = UserList.Values(i) - If User.Progress < 1 Then Continue For - Try - SendUpdateRequest(User, 1) '不需要使用多线程，发送实际会瞬间完成 - Catch ex As Exception - Log(ex, "发送全局刷新请求失败（" & User.DisplayName & "）") - End Try - Next - End Sub - '修改房间名称 - Private Shared Sub BtnRoomEdit_Click(sender As MyIconButton, e As EventArgs) - End Sub - '加入房间 - Private Shared Sub BtnRoom_Click(sender As MyListItem, e As EventArgs) - Dim Room As RoomEntry = sender.Tag - If MyMsgBox("请在多人游戏页面点击直接连接，输入 " & Room.Ip & " 以进入服务器！", "加入房间", "复制地址", "确定") = 1 Then - ClipboardSet(Room.Ip) - End If - End Sub - '关闭房间 - Private Shared Sub BtnRoomClose_Click(sender As MyIconButton, e As EventArgs) - End Sub - - '获取数据包 - Public Shared Sub ReceiveJson(JsonData As JObject, Optional NewSocket As Socket = Nothing) - End Sub - ''' - ''' 从用户列表中移除一位用户。提示信息视作该用户主动离开。 - ''' - Public Shared Sub UserRemove(User As LinkUserIoi, ShowLeaveMessage As Boolean) - End Sub - - Public Shared Sub ModuleStopManually() - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml b/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml deleted file mode 100644 index bf07b19..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml +++ /dev/null @@ -1,44 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml.vb deleted file mode 100644 index 6ff4fa5..0000000 --- a/Plain Craft Launcher 2/Pages/PageLink/PageLinkLeft.xaml.vb +++ /dev/null @@ -1,112 +0,0 @@ -Public Class PageLinkLeft - - Private IsLoad As Boolean = False - Private IsPageSwitched As Boolean = False '如果在 Loaded 前切换到其他页面，会导致触发 Loaded 时再次切换一次 - Private Sub PageLinkLeft_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded - If IsLoad Then Return - IsLoad = True - '切换默认页面 - If IsPageSwitched Then Return - ItemHiper.SetChecked(True, False, False) - End Sub - Private Sub PageOtherLeft_Unloaded(sender As Object, e As RoutedEventArgs) Handles Me.Unloaded - IsPageSwitched = False - End Sub - -#Region "页面切换" - - ''' - ''' 当前页面的编号。 - ''' - Public PageID As FormMain.PageSubType = FormMain.PageSubType.LinkHiper - - ''' - ''' 勾选事件改变页面。 - ''' - Private Sub PageCheck(sender As MyListItem, e As RouteEventArgs) Handles ItemHiper.Check, ItemIoi.Check, ItemSetup.Check, ItemHelp.Check, ItemFeedback.Check - '尚未初始化控件属性时，sender.Tag 为 Nothing，会导致切换到页面 0 - '若使用 IsLoaded，则会导致模拟点击不被执行（模拟点击切换页面时，控件的 IsLoaded 为 False） - If sender.Tag IsNot Nothing Then PageChange(Val(sender.Tag)) - End Sub - - Public Function PageGet(Optional ID As FormMain.PageSubType = -1) - If ID = -1 Then ID = PageID - Select Case ID - Case 0, FormMain.PageSubType.LinkHiper - If FrmLinkHiper Is Nothing Then FrmLinkHiper = New PageLinkHiper - Return FrmLinkHiper - Case FormMain.PageSubType.LinkIoi - If FrmLinkIoi Is Nothing Then FrmLinkIoi = New PageLinkIoi - Return FrmLinkIoi - Case FormMain.PageSubType.LinkSetup - If FrmSetupLink Is Nothing Then FrmSetupLink = New PageSetupLink - Return FrmSetupLink - Case FormMain.PageSubType.LinkHelp - If FrmLinkHelp Is Nothing Then FrmLinkHelp = PageOtherHelp.GetHelpPage(PathTemp & "Help\启动器\联机.json") - Return FrmLinkHelp - Case FormMain.PageSubType.LinkFeedback - If FrmLinkFeedback Is Nothing Then FrmLinkFeedback = New PageLinkFeedback - Return FrmLinkFeedback - Case Else - Throw New Exception("未知的更多子页面种类：" & ID) - End Select - End Function - - ''' - ''' 切换现有页面。 - ''' - Public Sub PageChange(ID As FormMain.PageSubType) - If PageID = ID Then Return - AniControlEnabled += 1 - IsPageSwitched = True - Try - PageChangeRun(PageGet(ID)) - PageID = ID - Catch ex As Exception - Log(ex, "切换分页面失败（ID " & ID & "）", LogLevel.Feedback) - Finally - AniControlEnabled -= 1 - End Try - End Sub - Private Shared Sub PageChangeRun(Target As MyPageRight) - AniStop("FrmMain PageChangeRight") '停止主页面的右页面切换动画，防止它与本动画一起触发多次 PageOnEnter - If Target.Parent IsNot Nothing Then Target.SetValue(ContentPresenter.ContentProperty, Nothing) - FrmMain.PageRight = Target - CType(FrmMain.PanMainRight.Child, MyPageRight).PageOnExit() - AniStart({ - AaCode(Sub() - CType(FrmMain.PanMainRight.Child, MyPageRight).PageOnForceExit() - FrmMain.PanMainRight.Child = FrmMain.PageRight - FrmMain.PageRight.Opacity = 0 - End Sub, 130), - AaCode(Sub() - '延迟触发页面通用动画，以使得在 Loaded 事件中加载的控件得以处理 - FrmMain.PageRight.Opacity = 1 - FrmMain.PageRight.PageOnEnter() - End Sub, 30, True) - }, "PageLeft PageChange") - End Sub - -#End Region - - Public Sub Reset(sender As Object, e As EventArgs) - If MyMsgBox("是否要初始化联机页的所有设置？该操作不可撤销。", "初始化确认",, "取消", IsWarn:=True) = 1 Then - If IsNothing(FrmSetupLink) Then FrmSetupLink = New PageSetupLink - FrmSetupLink.Reset() - ItemSetup.Checked = True - End If - End Sub - - Private Sub BtnHiperStop_Loaded(sender As Object, e As RoutedEventArgs) - sender.Visibility = If(PageLinkHiper.HiperState = LoadState.Finished OrElse PageLinkHiper.HiperState = LoadState.Loading, Visibility.Visible, Visibility.Collapsed) - End Sub - Private Sub BtnHiperStop_Click(sender As Object, e As EventArgs) - PageLinkHiper.ModuleStopManually() - End Sub - Private Sub BtnIoiStop_Loaded(sender As Object, e As RoutedEventArgs) - End Sub - Private Sub BtnIoiStop_Click(sender As Object, e As EventArgs) - PageLinkIoi.ModuleStopManually() - End Sub - -End Class diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml b/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml new file mode 100644 index 0000000..6e5496f --- /dev/null +++ b/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml @@ -0,0 +1,207 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml.vb new file mode 100644 index 0000000..643d06b --- /dev/null +++ b/Plain Craft Launcher 2/Pages/PageLink/PageLinkMain.xaml.vb @@ -0,0 +1,1120 @@ +Imports System.Globalization +Imports System.Net.Sockets + +Public Class PageLinkMain + Private Const INVITE_CODE_VERSION As Integer = 2 + + '=============================== + ' 状态机与前端页面 + '=============================== + +#Region "状态管理" + + Public Enum LinkStates + Waiting + Loading + Failed + Finished + End Enum + Public Shared LinkState As LinkStates = LinkStates.Waiting + + ''' + ''' 切换到指定的状态。 + ''' + Private Sub ChangeState(NewState As LinkStates) + If LinkState = NewState Then Return + Dim OldState = LinkState + LinkState = NewState + Log($"[Link] 主状态由 {GetStringFromEnum(OldState)} 变更为 {GetStringFromEnum(NewState)}") + '触发状态切换 + RunInUi( + Sub() + Select Case NewState + Case LinkStates.Waiting + SwitchToWaiting(OldState) + Case LinkStates.Loading + SwitchToLoading(OldState) + Case LinkStates.Failed + SwitchToFailed(OldState) + Case LinkStates.Finished + SwitchToFinished(OldState) + End Select + End Sub) + End Sub + + '让加载器的 成功/失败 事件触发状态切换 + Private Sub LoaderInit() Handles Me.Initialized + PageLoaderInit(Load, PanLoad, PanContent, PanAlways, LinkLoader, AutoRun:=False) + AddHandler LinkLoader.OnStateChangedUi, + Sub(Loader As LoaderBase, NewState As LoadState, OldState As LoadState) + Select Case NewState + Case LoadState.Finished + ChangeState(LinkStates.Finished) + Case LoadState.Failed + Telemetry("联机失败", "Exception", FilterUserName(Loader.Error.GetDetail, "*")) + ChangeState(LinkStates.Failed) + End Select + End Sub + End Sub + + '页面动画兼容 + Private Sub UpdatePanelVisibility() Handles Me.PageEnter + FrmLinkMain.PanSelect.Visibility = If(LinkState = LinkStates.Waiting, Visibility.Visible, Visibility.Collapsed) + FrmLinkMain.PanFinish.Visibility = If(LinkState = LinkStates.Finished, Visibility.Visible, Visibility.Collapsed) + End Sub + +#End Region + +#Region "初始页面 (Waiting)" + + '由任意状态切换到 Waiting + Private Sub SwitchToWaiting(OldState As LinkStates) + '加载器与进程状态 + LinkLoader.Abort() + SyncLock LinkLoader.LockState + LinkLoader.State = LoadState.Waiting + End SyncLock + ProcessStop() + '页面切换 + If OldState <> LinkStates.Finished Then + '从完成页面退出时，PageOnContentExit 结束会触发 PageEnter 事件，这会调用 UpdatePanelVisibility + '如果在现在提前调用了，会丢失完成页面的退出动画 + UpdatePanelVisibility() + End If + PageOnContentExit() + End Sub + + '=============================== + ' 页面 UI + '=============================== + + '创建 + Private Sub Create_MouseLeftButtonUp() Handles PanSelectCreate.MouseLeftButtonUp + '输入端口号 + Dim Port As String = MyMsgBoxInput("输入端口", $"在单人游戏的暂停菜单选择 {vbLQ}对局域网开放{vbRQ}，然后输入端口数字。{vbCrLf}甚至可以输入其他游戏的端口……嗯……", + ValidateRules:=New ObjectModel.Collection(Of Validate) From {New ValidateInteger(1024, 65535)}, + HintText:="端口号") + If Port Is Nothing Then Return + '基础信息 + IsServerSide = True + ServerPort = Port + Dim GenerateRandomCode = + Function() As String + Dim Result As String = "" + For i = 1 To 5 + Result &= RadixConvert(RandomInteger(0, 35), 10, 36) + Next + Return Result.Replace("O", "0").Replace("I", "1") + End Function + NetworkName = $"P{RadixConvert(ServerPort, 10, 16).PadLeft(4, "0"c)}-{GenerateRandomCode()}" + NetworkSecret = GenerateRandomCode() + DiscoverNodeID = -1 + Log($"[Link] 尝试创建房间，网络名 {NetworkName}，网络密码 {NetworkSecret}，端口 {ServerPort}") + '启动 + ChangeState(LinkStates.Loading) + End Sub + + '加入 + Private Shared LastCode As String = Nothing + ''' + ''' 输入邀请码，切换到联机页并立即加入房间。 + ''' + Public Shared Sub Join() Handles PanSelectJoin.MouseLeftButtonUp + Dim Code As String = MyMsgBoxInput("输入邀请码", "输入房主发给你的邀请码。", + HintText:=If(String.IsNullOrEmpty(LastCode), "", "使用上一次的邀请码")) + If Not String.IsNullOrEmpty(LastCode) AndAlso Code IsNot Nothing AndAlso Code = "" Then Code = LastCode + If Code Is Nothing Then Return + Join(Code) + End Sub + Public Sub JoinInternal(Code As String) + If Code Is Nothing Then Return + '基础格式校验 + Dim ValidateResult = ValidateCodeFormat(Code) + If ValidateResult IsNot Nothing Then + Hint(ValidateResult, HintType.Red) + Return + End If + Code = FixCodeFormat(Code) + Log($"[Link] 实际使用的邀请码：{Code}") + '基础信息 + IsServerSide = False + ServerPort = RadixConvert(Code.Substring(1, 4), 16, 10) + NetworkName = Code.Substring(0, 11) + NetworkSecret = Code.Substring(12, 5) + If Code.Substring(20, 3) = "000" Then + DiscoverNodeID = -2 + Else + DiscoverNodeID = RadixConvert(Code.Substring(20, 3), 16, 10) + End If + Log($"[Link] 尝试加入房间，网络名 {NetworkName}，网络密码 {NetworkSecret}，端口 {ServerPort}，发现节点 {DiscoverNodeID}") + '启动 + LastCode = Code + ChangeState(LinkStates.Loading) + End Sub + Public Shared Function ValidateCodeFormat(Code As String) As String + If Code Is Nothing Then Return "邀请码为空！" + Code = FixCodeFormat(Code) + '判断类型 + If Not (Code.Length >= 14 AndAlso Code(0) = "P"c AndAlso Code(5) = "-"c AndAlso Code(11) = "-"c) Then + If Code.StartsWithF("U/") Then 'HMCL + Return "请让房主使用 PCL 创建房间！" + ElseIf Code.Length = 10 Then 'PCL CE + Return "请让房主使用非社区版的 PCL 创建房间！" + Else + Return "邀请码有误，请让房主使用 PCL 创建房间！" + End If + End If + '校验版本 + If Code.Length >= 23 AndAlso Code(17) = "-"c AndAlso + Val(Code.Substring(18, 2)) > INVITE_CODE_VERSION Then Return "你的 PCL 版本太老了，请在更新 PCL 之后再联机！" + Return Nothing + End Function + Private Shared Function FixCodeFormat(Code As String) As String + Code = Code.Between("【", "】").Between("[", "]") '从完整消息中提取 + Code = Code.ToUpper.Replace("O", "0").Replace("I", "1") '输入修正 + '版本 1 兼容 + If Code.Length >= 17 AndAlso (Code.Length < 23 OrElse (Code.Length >= 18 AndAlso Code(17) <> "-"c)) Then + Code = Code.Substring(0, 17) & "-0105E" + End If + Return Code + End Function + + '自动加入 + + ''' + ''' 切换到联机页并立即加入指定房间。 + ''' + Public Shared Sub Join(Code As String) + If LinkState <> LinkStates.Waiting Then + Hint("你已经在联机房间中了！", HintType.Red) + ElseIf FrmMain.PageCurrent = FormMain.PageType.Link Then + FrmLinkMain.JoinInternal(Code) + Else + AutoJoinCode = Code + FrmMain.PageChange(FormMain.PageType.Link, FormMain.PageSubType.LinkMain) + End If + End Sub + '在进入页面时自动尝试加入房间 + Private Shared AutoJoinCode As String = Nothing + Private Sub PanSelectJoin_Loaded() Handles PanSelectJoin.Loaded + If AutoJoinCode Is Nothing Then Return + If LinkState = LinkStates.Waiting Then JoinInternal(AutoJoinCode) + AutoJoinCode = Nothing + End Sub + +#End Region + +#Region "加载页面 (Loading | Failed)" + + '由 Waiting 或 Failed 状态切换到 Loading + Private Sub SwitchToLoading(OldState As LinkStates) + '清理变量 + Peers = Nothing + FailCount = 0 + '加载器与进程状态 + LinkLoader.Start(IsForceRestart:=True) + '页面切换会由 Loader 调用 MyPageRight 来触发 + 'UI 更新 + UpdateProgressBar(0) + LabLoadTitle.Text = If(IsServerSide, "创建房间中", "加入房间中") + UpdateLoadingPage("正在初始化……", "准备初始化") + End Sub + + '由 Loading 状态切换到 Failed + Private Sub SwitchToFailed(OldState As LinkStates) + '加载器与进程状态 + LinkLoader.Abort() + ProcessStop() + 'UI 更新 + UpdateProgressBar(1) + '显示错误信息 + LabLoadTitle.Text = FailReason + Dim Brief As String = LinkLoader.Error.GetBrief + Dim InnerEx As Exception = LinkLoader.Error + If InnerEx.Message.StartsWithF("$") Then Brief = InnerEx.Message + Do Until InnerEx.InnerException Is Nothing + InnerEx = InnerEx.InnerException + If InnerEx.Message.StartsWithF("$") Then Brief = InnerEx.Message + Loop + LabLoadDesc.Text = If(Brief.StartsWithF("$"), Brief.TrimStart("$"), LinkLoader.Error.GetDetail) + Log(LinkLoader.Error, LabLoadTitle.Text) + End Sub + + '=============================== + ' 页面 UI + '=============================== + + Private Sub UpdateLoadingPage(Title As String, FailBrief As String) + If FailReason = FailBrief & "失败" Then Return + FailReason = FailBrief & "失败" + Log("[Link] 开始步骤：" & Title) + RunInUiWait( + Sub() + If FrmLinkMain Is Nothing OrElse Not FrmLinkMain.LabLoadDesc.IsLoaded Then Return + FrmLinkMain.LabLoadDesc.Text = Title + End Sub) + End Sub + Private FailReason As String = "准备初始化" + + '取消加载 + Private Sub BtnLoadCancel_Click() Handles BtnLoadCancel.Click + ChangeState(LinkStates.Waiting) + End Sub + + '点击重试 + Private Sub CardLoad_MouseLeftButtonUp() Handles CardLoad.MouseLeftButtonUp + ChangeState(LinkStates.Loading) + End Sub + + '进度条 + Private Sub UpdateProgressBar(Optional Value As Double = -1) + If Value = -1 Then Value = LinkLoader.Progress + Dim DisplayingProgress As Double = ColumnProgressA.Width.Value + If Math.Round(Value - DisplayingProgress, 3) = 0 Then Return + If DisplayingProgress <= Value Then + Dim NewProgress As Double = If(Value = 1, 1, DisplayingProgress + + (Value - DisplayingProgress) ^ 2 * 0.5) + AniStart({ + AaGridLengthWidth(ColumnProgressA, NewProgress - ColumnProgressA.Width.Value, 200), + AaGridLengthWidth(ColumnProgressB, (1 - NewProgress) - ColumnProgressB.Width.Value, 200) + }, "Link Progress") + Else + ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star) + ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star) + AniStop("Link Progress") + End If + End Sub + Private Sub CardLoad_SizeChanged() Handles CardLoad.SizeChanged + RectProgressClip.Rect = New Rect(0, 0, CardLoad.ActualWidth, 12) + End Sub + +#End Region + +#Region "完成页面 (Finished)" + + '由 Loading 状态切换到 Finished + Private Sub SwitchToFinished(OldState As LinkStates) + '由于只可能从加载器的完成事件触发，不需要管加载器 + UpdatePanelVisibility() '页面的实际切换会由 Loader 调用 MyPageRight 来触发 + + 'UI 更新 + If IsServerSide Then + LabFinishTitle.Text = "已创建房间" + LabFinishDesc.Text = $"把邀请码发给朋友，让大家加入房间吧！{vbCrLf}邀请码：{GetInviteCode()}" + BtnFinishExit.Text = "关闭" + BtnFinishPing.ToolTip = "网络延迟" + BtnFinishCopy.Visibility = Visibility.Visible + Copy() '立即复制邀请码 + '下边栏 + BtnFinishPort.Visibility = Visibility.Visible + LabFinishPort.Visibility = Visibility.Visible + BtnFinishIp.Visibility = Visibility.Collapsed + LabFinishIp.Visibility = Visibility.Collapsed + LabFinishPort.Text = ServerPort + Else + LabFinishTitle.Text = "已加入房间" + LabFinishDesc.Text = $"在多人游戏页面的最下方就能找到联机房间！{vbCrLf}注意：使用离线登录时不要手动输入 IP！" + BtnFinishExit.Text = "离开" + BtnFinishPing.ToolTip = "与房主的延迟" + BtnFinishCopy.Visibility = Visibility.Collapsed + '下边栏 + BtnFinishPort.Visibility = Visibility.Collapsed + LabFinishPort.Visibility = Visibility.Collapsed + LabFinishIp.Text = ClientAddress + BtnFinishIp.Visibility = Visibility.Visible + LabFinishIp.Visibility = Visibility.Visible + End If + Update() '立即刷新 + End Sub + + '=============================== + ' 页面 UI + '=============================== + + '退出 + Private Sub BtnFinishExit_Click() Handles BtnFinishExit.Click + TryExit(False, False) + End Sub + ''' + ''' 退出联机。 + ''' 返回是否弹出了警告窗口并且玩家选择了取消。 + ''' + Public Function TryExit(Slient As Boolean, Closing As Boolean) As Boolean + If LinkState = LinkStates.Waiting OrElse LinkState = LinkStates.Failed Then Return False + If Not Slient Then + If IsServerSide AndAlso PeopleCount > 1 Then + If MyMsgBox("你确定要关闭联机房间吗？" & vbCrLf & "所有玩家都需要重新输入邀请码才可加入游戏！", "退出联机", "确定", "取消", IsWarn:=True) = 2 Then Return True + ElseIf Closing Then + If MyMsgBox(If(IsServerSide, "你确定要关闭联机房间吗？", "你确定要离开联机房间吗？"), "退出联机", "确定", "取消") = 2 Then Return True + End If + End If + ChangeState(LinkStates.Waiting) + Return False + End Function + + '复制邀请码 + Private Sub Copy() Handles BtnFinishCopy.Click + Dim CodeText As String = $"在 PCL 启动器中输入邀请码【{GetInviteCode()}】，即可加入联机房间！" + ClipboardSet(CodeText, False) + Setup.Set("LinkLastAutoJoinInviteCode", CodeText) + Hint("已复制邀请码！", HintType.Green) + End Sub + Private Function GetInviteCode() As String + Return $"{NetworkName}-{NetworkSecret}-{INVITE_CODE_VERSION.ToString.PadLeft(2, "0"c)}{ _ + RadixConvert(If(DiscoverNodeID = -1, 0, DiscoverNodeID), 10, 16).PadLeft(3, "0"c)}" + End Function + + '复制 IP + Private Sub BtnFinishIp_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishIp.MouseLeftButtonUp + ClipboardSet(ClientAddress, False) + Hint("已复制服务器地址！", HintType.Green) + End Sub + +#End Region + + '=============================== + ' 后端 + '=============================== + + ''' + ''' EasyTier 所在的文件夹路径，以 \ 结尾。 + ''' + Private PathEasyTier As String = PathAppdata & "EasyTier\" + ''' + ''' 当前是服务端还是客户端。 + ''' + Private IsServerSide As Boolean + ''' + ''' 服务端映射前的端口号。 + ''' + Private ServerPort As Integer + ''' + ''' 客户端映射后的端口号。 + ''' + Private ClientPort As Integer + ''' + ''' RPC 端口号。 + ''' + Private RPCPort As Integer + ''' + ''' 在客户端映射后的地址。 + ''' 除非已作为客户端启动 EasyTier，否则一直为 Nothing。 + ''' + Private ClientAddress As String = Nothing + ''' + ''' 发现节点的 ID。 + ''' 若必须设定自定义节点则为 -2；若等待选择则为 -1；选择回退节点则为 0；否则为对应节点的 ID。 + ''' + Private DiscoverNodeID As Integer = -1 + ''' + ''' 网络信息。 + ''' + Private NetworkName As String, NetworkSecret As String + +#Region "加载" + + Private WithEvents LinkLoader As New LoaderCombo(Of Integer)("联机", { + New LoaderTask(Of Integer, Integer)("获取配置", AddressOf InitConfig) With {.ProgressWeight = 8}, + New LoaderTask(Of Integer, List(Of NetFile))("准备下载联机模块", AddressOf InitPrepareDownload) With {.ProgressWeight = 2}, + New LoaderDownload("下载联机模块", New List(Of NetFile)) With {.ProgressWeight = 40}, + New LoaderTask(Of Integer, Integer)("启动联机模块", AddressOf InitLaunch) With {.ProgressWeight = 50} + }) + + '1. 获取服务器配置 + Private Sub InitConfig(Task As LoaderTask(Of Integer, Integer)) + UpdateLoadingPage("正在联网获取配置……", "联网获取配置") + If VersionBranchMain <> "Official" Then + Throw New Exception($"$开源版无法联网获取配置。{vbCrLf}你可以在 PCL 官方版的缓存文件夹下查看 ServerConfig 的当前内容， 并在代码中进行相应修改。") + End If + ServerLoader.WaitForExit(LoaderToSyncProgress:=Task) + If ServerConfig Is Nothing Then Throw New Exception("无法从服务器获取配置") + '检查是否已禁用联机功能 + Dim DisableReason = ServerConfig("Link")?("DisableReason2")?.ToString + If Not String.IsNullOrEmpty(DisableReason) Then Throw New Exception("$" & DisableReason) + If CType(ServerConfig("Link"), JObject).ContainsKey("MinVersionCode") AndAlso + VersionCode < ServerConfig("Link")("MinVersionCode").ToObject(Of Integer) Then + Throw New Exception("$你的 PCL 版本太老了，请在更新 PCL 之后再联机！") + End If + End Sub + + '2. 获取需要下载的文件 + Private ServerVersion As Integer + Private Sub InitPrepareDownload(Task As LoaderTask(Of Integer, List(Of NetFile))) + '获取 CPU 架构 + UpdateLoadingPage("正在获取 CPU 架构……", "获取 CPU 架构") + Dim Architecture As String = GetType(String).Assembly.GetName().ProcessorArchitecture + Select Case Architecture + Case Reflection.ProcessorArchitecture.X86 + Architecture = "i686" + Case Reflection.ProcessorArchitecture.Amd64 + Architecture = "x86_64" + Case Reflection.ProcessorArchitecture.Arm + Architecture = "arm64" + Case Else + Log($"[Link] CPU 是不支持的 {Architecture} 架构，这可能会导致联机模块无法启动！", LogLevel.Debug) + Architecture = "arm64" + End Select + Log("[Link] CPU 架构：" & Architecture) + Telemetry("联机开始") + '检查 EasyTier 版本 + UpdateLoadingPage("正在检查联机模块版本……", "检查联机模块版本") + If Not (File.Exists(PathEasyTier & "联机模块 CLI.exe") AndAlso File.Exists(PathEasyTier & "联机模块.exe") AndAlso + File.Exists(PathEasyTier & "Packet.dll")) Then + Setup.Set("LinkEasyTierVersion", -1) + End If + Dim LocalVersion As Integer = Setup.Get("LinkEasyTierVersion") + ServerVersion = ServerConfig("Link")("EasyTierVersion") + Dim RequiredFiles As New List(Of NetFile) + Log($"[Link] EasyTier 本地版本：{LocalVersion}，需求版本：{ServerVersion}") + If LocalVersion < ServerVersion Then + RequiredFiles.Add(New NetFile( + ServerConfig("Link")("Downloads").Select(Function(UrlEntry) UrlEntry.ToString.Replace("{arch}", Architecture)), + PathEasyTier & "EasyTier.zip", + New FileChecker(MinSize:=1024 * 1024 * 2))) + End If + '开始下载 + UpdateLoadingPage("正在下载联机模块……", "下载联机模块") + Task.Output = RequiredFiles + End Sub + + '3. 启动联机模块 + Private Sub InitLaunch(Task As LoaderTask(Of Integer, Integer)) + '解压文件 + UpdateLoadingPage("正在解压联机模块……", "解压联机模块") + If File.Exists(PathEasyTier & "EasyTier.zip") Then + '解压 + Dim ExtractPath As String = RequestTaskTempFolder() + ExtractFile(PathEasyTier & "EasyTier.zip", ExtractPath, + ProgressIncrementHandler:=Sub(Progress) Task.Progress += Progress * 0.05) + Dim ExtractedPath As String = New DirectoryInfo(ExtractPath).EnumerateDirectories.FirstOrDefault?.FullName + Log("[Link] 联机模块解压时的临时路径：" & ExtractedPath) + CopyDirectory(ExtractedPath, PathEasyTier) + '重命名 + File.Delete(PathEasyTier & "联机模块.exe") + Rename(PathEasyTier & "easytier-core.exe", PathEasyTier & "联机模块.exe") + File.Delete(PathEasyTier & "联机模块 CLI.exe") + Rename(PathEasyTier & "easytier-cli.exe", PathEasyTier & "联机模块 CLI.exe") + '清理 + File.Delete(PathEasyTier & "EasyTier.zip") + Setup.Set("LinkEasyTierVersion", ServerVersion) + End If + Task.Progress = 0.07 + '获取节点列表 + UpdateLoadingPage("正在获取节点列表……", "获取节点列表") + Dim RawPeers As List(Of String) + Dim CustomPeers As String = Setup.Get("LinkCustomPeer") + If String.IsNullOrWhiteSpace(CustomPeers) Then + If DiscoverNodeID = -2 AndAlso Not IsServerSide Then + Panic("未填写自定义节点设置", $"$你必须在 {vbLQ}自定义节点{vbRQ} 设置中填写与房主相同的内容，{vbCrLf}才能进入该房间！") + Return + End If + RawPeers = GetTargetPeers() + Else + If DiscoverNodeID <> -2 AndAlso Not IsServerSide Then Hint("房主可能没有使用自定义节点设置，请确认你们的自定义节点设置是否一致！") + RawPeers = CustomPeers.Split("，,".ToCharArray).Select(Function(p) p.Trim).Where(Function(p) Not String.IsNullOrEmpty(p)).ToList() + Log("[Link] 使用自定义节点：" & CustomPeers) + End If + Task.Progress = 0.13 + '获取空闲端口 + UpdateLoadingPage("正在启动联机模块……", "启动联机模块") + Dim FreePorts = FindFreePorts(5, ServerPort) + ClientPort = FreePorts(0) + RPCPort = FreePorts(1) + Dim ListenersPort As Integer = FreePorts(2) '它会占用【当前、当前 +1、当前 +2】共三个端口 + '获取启动参数 + Dim Arguments As String = ServerConfig("Link")("Argument") + Arguments += $" --network-name={NetworkName} --network-secret={NetworkSecret} --listeners {ListenersPort} --rpc-portal {RPCPort}" + Dim HostName = If(IsServerSide, "Server-", "Client-") & RadixConvert(Math.Abs(Identify.GetHashCode), 10, 36) + If IsServerSide Then + Arguments += $" -i 10.114.114.114 --hostname={HostName} --tcp-whitelist={ServerPort} --udp-whitelist={ServerPort}" + Else + Arguments += $" -d --hostname={HostName} --tcp-whitelist=0 --udp-whitelist=0" + '端口转发 + ClientAddress = $"localhost:{ClientPort}" + Arguments += $" --port-forward tcp://[{IPAddress.IPv6Loopback}]:{ClientPort}/10.114.114.114:{ServerPort}" + Arguments += $" --port-forward udp://[{IPAddress.IPv6Loopback}]:{ClientPort}/10.114.114.114:{ServerPort}" + Arguments += $" --port-forward tcp://{IPAddress.Loopback}:{ClientPort}/10.114.114.114:{ServerPort}" + Arguments += $" --port-forward udp://{IPAddress.Loopback}:{ClientPort}/10.114.114.114:{ServerPort}" + End If + For Each Peer As String In RawPeers + Arguments += $" -p=""{Peer}""" + Next + Arguments += " --private-mode true" '老好人模式现在莫得用：If Not Setup.Get("LinkShareMode") Then + If Setup.Get("LinkLatencyMode") = 1 Then Arguments += " --latency-first" + '启动进程 + ProcessStart(Arguments) + Task.Progress = 0.15 + '等待连接 + Dim TimeoutCounter As Integer = 0 + Do + Thread.Sleep(500) '为避免还没启动好先跑 CLI 了，先等半秒 + '刷新信息 + CheckCrash() + RefreshPeerLoader.WaitForExit(IsForceRestart:=True) + '查找目标节点 + Dim Ping = GetPeerPing() + If Ping > 0 Then + Log($"[Link] 已与目标建立连接，当前 Ping 为 {Ping:0.0}ms") + Telemetry("联机成功", "Server", IsServerSide, "NAT", NATType) + Exit Do '退出循环 + End If + '更新进度 + Dim LastProgress = Task.Progress + Dim PeerCount As Integer = If(Peers Is Nothing, -1, Peers.Where(Function(p) p.Ping > 0).Count) + Select Case PeerCount + Case -1 'CLI 无返回 + Task.Progress = MathClamp(Task.Progress + 0.02, 0.15, 0.25) + Case 0 'CLI 有返回，但未连接到任何节点 + UpdateLoadingPage("正在连接到节点……", "连接节点") + Task.Progress = MathClamp(Task.Progress + 0.02, If(IsServerSide, 0.5, 0.3), If(IsServerSide, 0.95, 0.5)) + Case Else '已连接到节点，但未连接到房主 + UpdateLoadingPage("正在连接到房主……", "连接房主") + Task.Progress = MathClamp(Task.Progress + 0.02, Math.Min(0.45 + PeerCount * 0.05, 0.65), 0.95) + End Select + '超时判定 + If LastProgress <> Task.Progress Then + TimeoutCounter = 0 + ElseIf TimeoutCounter < 30 * 2 Then + TimeoutCounter += 1 + Else '进度停滞超过 30s + Select Case PeerCount + Case -1 'CLI 无返回 + Panic("无法启动联机模块", "近期日志：" & vbCrLf & LogHistory.Join(vbCrLf)) + Case 0 'CLI 有返回，但未连接到任何节点 + Panic("无法连接到节点", $"请检查你的网络环境是否良好。") + Case Else '已连接到节点，但未连接到房主 + Panic("无法连接到房主", $"可能的原因：{vbCrLf}- 你或者房主的网络环境不佳{vbCrLf}- 房主已关闭房间{vbCrLf}- 邀请码输错了") + End Select + End If + Loop Until Task.IsAborted + If Task.IsAborted Then Throw New ThreadInterruptedException + '等待连接稳定，最多 5s + If IsServerSide Then Return + UpdateLoadingPage("连接优化中……", "优化连接") + Task.Progress = 0.999 + For i = 1 To 50 + Dim Server = GetTargetPeer() + If Server IsNot Nothing AndAlso Not Server.Relay AndAlso Server.Ping < 100 Then Return '结束 + If Task.IsAborted Then Throw New ThreadInterruptedException + Thread.Sleep(100) + Next + End Sub + ''' + ''' 从在线配置和 API 获取需要连接的节点列表，并更新发现节点 ID。 + ''' 根据发现节点 ID，会有以下行为变化： + ''' -1：作为房主，根据负载均衡选择一个发现节点。 + ''' 0：作为加入者，但邀请码未提供发现节点 ID，使用回退发现节点。 + ''' >0：作为加入者，根据 ID 选择对应的发现节点；如果没有，使用回退发现节点。 + ''' + Private Function GetTargetPeers() As List(Of String) + Dim FinalPeers As New List(Of String), FinalDiscoverID As Integer = -1 + Dim FallbackDiscoverID = ServerConfig("Link")("DiscoverPeerId").ToObject(Of Integer) + Dim FallbackDiscoverAddress As String = ServerConfig("Link")("DiscoverPeer").ToString() + Try + '从 API 获取节点列表 + Dim RawNodes As JObject + Dim IsFallbackRawList As Boolean = False + Try + RawNodes = GetJson(NetRequestByClient("https://uptime.easytier.cn/api/nodes?page=1&per_page=1000", RequireJson:=True)) + Catch exx As Exception + Log(exx, "从源站获取节点列表失败，将使用 CDN 缓存") + RawNodes = GetJson(NetRequestByClientRetry("https://easytier.meloong.com/?page=1&per_page=1000", RequireJson:=True)) + IsFallbackRawList = True + End Try + '分析节点列表 + Dim Nodes As New List(Of JObject) '负载会添加在 load 字段上 + Dim BlackList As List(Of String) = ServerConfig("Link")("PeersBlackList").Select(Function(p) p.ToString).ToList() + For Each Node As JObject In RawNodes("data")("items") + '状态检查 + Dim ID = Node("id").ToObject(Of Integer) + If Not Node("is_active").ToObject(Of Boolean) OrElse Not Node("is_approved").ToObject(Of Boolean) Then Continue For + If ID = DiscoverNodeID Then GoTo ForcedPass '若为指定的发现节点，忽略后续检查 + If ID = FallbackDiscoverID Then Continue For '不主动选取回退发现节点 + If BlackList.Contains(Node("address").ToString) Then Continue For 'ServerConfig 黑名单 + If Node("usage_percentage").ToObject(Of Double) = 0 AndAlso RandomInteger(1, 100) <> 1 Then Continue For '或许节点有问题才导致是 0 负载，让它只有 1% 概率被选中 + '标签检查 + Dim Tags = Node("tags").Select(Function(t) t.ToString).ToList + If Not Tags.Contains("国内") OrElse Not Tags.Contains("MC中继") Then Continue For + '计算负载并加入列表 +ForcedPass: + Dim Load As Double = Node("usage_percentage").ToObject(Of Double) '负载 + Load *= 110 - Node("health_percentage_24h").ToObject(Of Double) '可用率 + Node("load") = Load + Nodes.Add(Node) + Next + '排序 + If Not IsFallbackRawList Then + Nodes = Nodes.OrderBy(Function(n) n("load").ToObject(Of Double)).ToList() '按负载从低到高排序 + Else + Nodes = Nodes.Shuffle().ToList() '回退到 CDN 缓存时，由于负载数据可能过期，直接随机选择 + End If + '选取发现节点 + Dim SelectedDiscoverNode As JObject = Nothing + If DiscoverNodeID = -1 Then '-1：作为房主，根据负载均衡选择一个发现节点 + SelectedDiscoverNode = Nodes.FirstOrDefault(Function(n) Not n("allow_relay").ToObject(Of Boolean)) + ElseIf DiscoverNodeID > 0 Then '>0：作为加入者，根据 ID 选择对应的发现节点；如果没有，使用回退发现节点 + SelectedDiscoverNode = Nodes.FirstOrDefault(Function(n) n("id").ToObject(Of Integer) = DiscoverNodeID) + If SelectedDiscoverNode Is Nothing Then + Log($"[Link] 未找到 ID {DiscoverNodeID} 的发现节点", LogLevel.Debug) + Panic("房间已过期", "请让房主重新创建房间！") + Throw New ThreadInterruptedException + End If + End If + If SelectedDiscoverNode Is Nothing Then '使用回退发现节点 + SelectedDiscoverNode = New JObject From {{"address", FallbackDiscoverAddress}, {"id", FallbackDiscoverID}} + Log("[Link] 将使用回退发现节点", LogLevel.Debug) + End If + FinalPeers.Add(SelectedDiscoverNode("address").ToString()) + FinalDiscoverID = SelectedDiscoverNode("id").ToObject(Of Integer) + Log($"[Link] 发现节点：{SelectedDiscoverNode("address")} (ID: {FinalDiscoverID})") + '选取中继节点 + If ModeDebug OrElse Not IsServerSide Then '房主只连接发现节点，不连接中继节点 + Dim RelayCount As Integer = ServerConfig("Link")("RandomPeer").ToObject(Of Integer) + Dim RelayNodes = Nodes.Where(Function(n) n("allow_relay").ToObject(Of Boolean)).ToList() + If RelayNodes.Count < RelayCount Then Throw New Exception($"可用的中继节点数量不足，需要 {RelayCount} 个，实际 {RelayNodes.Count} 个") + FinalPeers.AddRange(RelayNodes.Take(RelayCount).Select(Function(n) n("address").ToString())) + End If + Catch ex As ThreadInterruptedException + Throw + Catch ex As Exception + Log(ex, "获取节点列表失败，联机质量可能受到影响", LogLevel.Hint) + FinalPeers.AddRange(ServerConfig("Link")("Peers").Select(Function(p) p.ToString)) + If FinalDiscoverID <= 0 Then + FinalPeers.Add(FallbackDiscoverAddress) + FinalDiscoverID = FallbackDiscoverID + End If + End Try + '版本 1 兼容 + If CType(ServerConfig("Link"), JObject).ContainsKey("EnableForcedPeer") Then + FinalPeers.Add("tcp://mc1.easytier.cn:55558") + If FinalDiscoverID <= 0 Then FinalDiscoverID = 94 + End If + '强制添加的节点 + FinalPeers.AddRange(ServerConfig("Link")("MandatoryPeers").Select(Function(p) p.ToString)) + '结束 + DiscoverNodeID = FinalDiscoverID + Return FinalPeers.Distinct.ToList + End Function + +#End Region + +#Region "进程与日志" + + ''' + ''' EasyTier Core 进程。 + ''' + Private Shared ProcessCore As Process + Private Shared ProcessOutputHandle As AutoResetEvent, ProcessErrorHandle As AutoResetEvent + + ''' + ''' 若程序正在运行，则结束程序进程。 + ''' 即使失败也不会抛出异常。 + ''' + Public Shared Sub ProcessStop() + Try + '关闭未捕获的进程 + For Each ProcessObject In Process.GetProcesses + If ProcessObject.Id = ProcessCore?.Id Then Continue For + If ProcessObject.ProcessName <> "联机模块" AndAlso ProcessObject.ProcessName <> "联机模块 CLI" Then Continue For + Try + Log("[Link] 停止残留的联机模块，PID：" & ProcessObject.Id & "，进程名：" & ProcessObject.ProcessName) + ProcessObject.Kill() + ProcessObject.Close() + Catch exx As Exception + Log(exx, $"结束进程失败（{ProcessObject.ProcessName}，PID {ProcessObject.Id}）") + End Try + Next + '关闭由自身启动的进程 + If ProcessCore IsNot Nothing AndAlso Not ProcessCore.HasExited Then + Log("[Link] 停止所启动的联机模块，PID：" & ProcessCore.Id) + ProcessCore.Kill() + ProcessCore.Close() + ProcessCore = Nothing + End If + '释放资源 + ProcessOutputHandle?.Dispose() + ProcessErrorHandle?.Dispose() + Catch ex As Exception + Log(ex, "停止联机模块失败") + End Try + End Sub + ''' + ''' 出现意外错误，给出错误信息并结束联机。 + ''' + Private Sub Panic(Brief As String, Detail As String) + '常见原因分析 + If Detail.Contains("failed to listen on ") Then + Detail = $"监听端口失败。{vbCrLf}请点击重试，如果还是出现此错误，可以重启电脑解决。{vbCrLf}{vbCrLf}{Detail}" + End If + '显示信息 + If LinkState = LinkStates.Loading Then + FailReason = Brief + LinkLoader.Failed(New Exception(Detail)) + Else + MyMsgBox(Detail, "联机出错：" & Brief, IsWarn:=True) + ChangeState(LinkStates.Waiting) + Telemetry("联机失败", "Exception", FilterUserName(Brief & "：" & Detail, "*")) + End If + End Sub + + ''' + ''' 启动进程。 + ''' + Private Sub ProcessStart(Arguments As String) + Dim Info = New ProcessStartInfo With { + .FileName = PathEasyTier & "联机模块.exe", + .Arguments = Arguments, + .UseShellExecute = False, + .CreateNoWindow = True, + .RedirectStandardError = True, + .RedirectStandardOutput = True, + .StandardOutputEncoding = Encoding.UTF8, + .StandardErrorEncoding = Encoding.UTF8 + } + Log("[Link] 正在启动 EasyTier：" & Arguments) + ProcessCore = New Process With {.StartInfo = Info} + Dim LogLineHandler = + Function(sender As Object, e As DataReceivedEventArgs, Handle As AutoResetEvent) + Try + If e.Data Is Nothing Then + Handle.[Set]() + Return Nothing + End If + ProcessLogLine(e.Data) + Catch unused As ObjectDisposedException + Catch ex As Exception + Log(ex, "读取 EasyTier 信息失败") + End Try + Return Nothing + End Function + ProcessOutputHandle = New AutoResetEvent(False) + AddHandler ProcessCore.OutputDataReceived, Function(sender, e) LogLineHandler(sender, e, ProcessOutputHandle) + ProcessErrorHandle = New AutoResetEvent(False) + AddHandler ProcessCore.ErrorDataReceived, Function(sender, e) LogLineHandler(sender, e, ProcessErrorHandle) + ProcessCore.Start() + ProcessCore.BeginOutputReadLine() + ProcessCore.BeginErrorReadLine() + End Sub + Private Sub ProcessLogLine(Line As String) + '记录日志 + Log("[EasyTier] " & Line) + LogHistory.Enqueue(Line) + If LogHistory.Count >= 10 Then LogHistory.Dequeue() + '检查日志内容 + If Line.ContainsF("new peer connection added", True) Then + Log("[Link] 已建立连接：" & If(RegexSeek(Line, "(?<=remote_addr.+?"")[^""}]{3,}"), Line), LogLevel.Debug) + Update() + ElseIf Line.ContainsF("peer connection removed", True) Then + Log("[Link] 已断开连接：" & If(RegexSeek(Line, "(?<=remote_addr.+?"")[^""}]{3,}"), Line), LogLevel.Debug) + Update() + End If + End Sub + Private LogHistory As New Queue(Of String)(10) + +#End Region + +#Region "CLI 节点信息获取" + + Private Class Peer + ''' + ''' 该节点的类型。 + ''' + Public ReadOnly Type As Types + Public Enum Types + ''' + ''' 客户端。 + ''' + Client + ''' + ''' 服务器。 + ''' + Server + ''' + ''' 公共节点。 + ''' + Misc + ''' + ''' 自己，或者自己的重复（它可能返回多个自己）。 + ''' + Self + End Enum + ''' + ''' 与该节点的延迟 (ms)。 + ''' 若是自己则为 0。 + ''' + Public ReadOnly Ping As Double + ''' + ''' 名称。 + ''' + Public ReadOnly Name As String + ''' + ''' 是否通过中继连接。 + ''' + Public ReadOnly Relay As Boolean + ''' + ''' NAT 类型。 + ''' + Public ReadOnly NATType As NATTypes + + ''' + ''' 从 CLI 给出的信息分析对应的数据。 + ''' + Public Sub New(Info As JObject) + '类别 + Dim PeerName = Info("hostname").ToString + If Info("cost").ToString = "Local" Then + Type = Types.Self + ElseIf PeerName.StartsWithF("Client") Then + Type = Types.Client + ElseIf Info("ipv4") = "10.114.114.114" Then '只允许这个 IP 作为房主，避免网络被多个房主搞炸的情况 + Type = Types.Server + Else + Type = Types.Misc + End If + '基础信息 + Double.TryParse(Info("lat_ms"), NumberStyles.Any, CultureInfo.InvariantCulture, Ping) + Name = PeerName + Relay = Info("cost").ToString.ContainsF("relay", True) + NATType = Info("nat_type").ToString.ParseToEnum(Of NATTypes) + End Sub + Public Overrides Function ToString() As String + Return $"{Type} - {Name} - Ping {Ping:0.0}ms [中继? {Relay}] - NAT {NATType}" + End Function + End Class + Private Enum NATTypes + 'https://github.com/EasyTier/EasyTier/blob/6bb2fd9a15ab2499bdeabdcc3a925e9bd9aebf50/easytier/src/proto/common.proto#L129 + Unknown = 0 + OpenInternet = 1 + NoPAT = 2 + FullCone = 3 + Restricted = 4 + PortRestricted = 5 + Symmetric = 6 + SymUdpFirewall = 7 + SymmetricEasyInc = 8 + SymmetricEasyDec = 9 + ''' + ''' 尚未获取。 + ''' + Pending = 10 + End Enum + + ''' + ''' 当前的节点列表，使用 RefreshPeerLoader 来刷新。 + ''' 若尚未成功获取过则为 Nothing，但保证在加载完成后至少是一个列表。 + ''' + Private Peers As List(Of Peer) = Nothing + ''' + ''' 自己的 NAT 类型。 + ''' + Private NATType As NATTypes = NATTypes.Pending + + ''' + ''' 调用 EasyTier CLI 获取已连接节点信息。 + ''' 这会过滤掉尚未完成连接的其他节点以及自己。 + ''' 若在加载完成后连续获取失败 3 次，则会强制断开连接。 + ''' + Private RefreshPeerLoader As New LoaderTask(Of Integer, List(Of Peer))("EasyTier CLI", AddressOf RefreshPeer) + Private Sub RefreshPeer() + Try + Dim CliResult = StartProcessAndGetOutput(PathEasyTier & "联机模块 CLI.exe", $"-o json -p 127.0.0.1:{RPCPort} peer", 2000, Encoding:=Encoding.UTF8, PrintLog:=False) + '解析 + If Not CliResult.Contains("lat_ms") Then Throw New Exception("CLI 调用失败：" & vbCrLf & CliResult) + If GetUuid() Mod If(ModeDebug, 23, 103) = 0 Then Log("[EasyTier] CLI 输出抽样：" & vbCrLf & CliResult) + Dim NewPeers As New List(Of Peer) + For Each Line As JObject In CType(GetJson(CliResult), JArray) + Try + Dim Peer = New Peer(Line) + If Peer.Type = Peer.Types.Self Then + NATType = Peer.NATType '记录自己的 NAT + Else + NewPeers.Add(Peer) + End If + Catch exx As Exception + Log(exx, $"错误的信息（{Line}）") + End Try + Next + '完成 + Peers = NewPeers + FailCount = 0 + Catch ex As Exception + Log(ex, "获取节点信息失败") + If LinkState = LinkStates.Finished Then + FailCount += 1 + If FailCount >= 4 Then Panic("获取节点信息失败", ex.Message) + End If + End Try + End Sub + ''' + ''' CLI 调用连续失败的次数。 + ''' + Private FailCount As Integer = 0 + + ''' + ''' 根据当前的节点列表获取 Ping 值。 + ''' 服务端会返回所有节点中最低的 Ping，客户端会返回服务端的 Ping。 + ''' 0 代表尚不可用。 + ''' + Private Function GetPeerPing() As Double + Dim Peer = GetTargetPeer() + If Peer Is Nothing Then Return 0 + Return Peer.Ping + End Function + ''' + ''' 服务端会返回所有节点中 Ping 大于 0 最低的那一个，客户端会返回服务端。 + ''' 若没有则为 Nothing。 + ''' + Private Function GetTargetPeer() As Peer + If Peers Is Nothing Then Return Nothing + Dim Targets As IEnumerable(Of Peer) + If IsServerSide Then + Targets = Peers.Where(Function(p) p.Ping > 0) + Else + Targets = Peers.Where(Function(p) p.Type = Peer.Types.Server AndAlso p.Ping > 0) + End If + If Not Targets.Any Then Return Nothing + '返回 Ping 且最低的那个 + Dim MinPing = Targets.Min(Function(p) p.Ping) + Return Targets.First(Function(p) p.Ping = MinPing) + End Function + + ''' + ''' 获取当前房间中的人数，包括自己。 + ''' 0 代表不可用。 + ''' + Private ReadOnly Property PeopleCount As Integer + Get + If Peers Is Nothing Then Return 0 + Return Peers.Where(Function(p) p.Type <> Peer.Types.Misc).Count() + 1 '加上自己 + End Get + End Property + +#End Region + +#Region "定时任务" + + '启动 + Private Sub StartTimerThread() Handles Me.Loaded + Static IsTimerStarted As Boolean = False + If IsTimerStarted Then Return + RunInNewThread( + Sub() + Dim Counter As Integer = 0 + Do While True + Try + Thread.Sleep(200) + Counter += 200 + '每秒执行一次 + If Counter >= 1000 Then + Counter = 0 + Update() + End If + '每 200ms 更新进度条 + If LinkState = LinkStates.Loading Then RunInUi(AddressOf UpdateProgressBar) + Catch ex As Exception + Log(ex, "联机模块主时钟出错", LogLevel.Feedback) + Thread.Sleep(10000) + End Try + Loop + End Sub, "Link Timer") + End Sub + + '每秒或进入页面时触发 + Private Sub Update() Handles Me.Loaded + If LinkState <> LinkStates.Finished Then Return + '重新获取信息 + SyncLock RefreshPeerLoader.LockState + If RefreshPeerLoader.State <> LoadState.Loading Then RefreshPeerLoader.Start(IsForceRestart:=True) + End SyncLock + '更新 UI + If FrmMain.PageCurrent = FormMain.PageType.Link Then + RunInUi( + Sub() + 'Logo 旋转动画 + AniStart(AaRotateTransform(ImgFinishLogo, 500, 5000), "Link Logo Rotation") + 'Ping + Dim Ping As Double = GetPeerPing() + Dim Connecting As Boolean = Ping Mod 500 = 0 OrElse $"{Ping:0.0}" = "1.0" OrElse FailCount > 0 + If Connecting Then + LabFinishPing.Text = "连接优化中" + Else + LabFinishPing.Text = If(Ping >= 10, $"{Ping:0} ms", $"{Ping:0.0} ms") + End If + '人数显示 + LabFinishPlayer.Text = PeopleCount & "  人" + '------------------------ + ' 提示条 + '------------------------ + HintFinish.Visibility = Visibility.Collapsed + If IsServerSide Then Return '服务端没有需要显示的提示 + If Connecting Then Return '连接稳定过程中不显示提示 + '中继提示 + Dim Server As Peer = GetTargetPeer() + If Server Is Nothing Then Return + If Server.Relay Then + If NATType >= NATTypes.Symmetric AndAlso Server.NATType >= NATTypes.Symmetric Then + HintFinish.Text = "你和房主的网络环境都不太好，" + ElseIf NATType >= NATTypes.Symmetric Then + HintFinish.Text = "你的网络环境不太好，" + ElseIf Server.NATType >= NATTypes.Symmetric Then + HintFinish.Text = "房主的网络环境不太好，" + Else + HintFinish.Text = "你或者房主的网络环境不太好，" + End If + If String.IsNullOrWhiteSpace(Setup.Get("LinkCustomPeer")) Then + HintFinish.Text &= "正使用社区节点进行中继。" + Else + HintFinish.Text &= "正通过自定义节点进行中继。" + End If + HintFinish.Visibility = Visibility.Visible + HintFinish.Theme = MyHint.Themes.Yellow + Return + End If + '环境比房主更好的提示 + If NATType >= NATTypes.PortRestricted Then Return '自身的 NAT 为 2 或更好 + If Server.NATType < NATTypes.PortRestricted Then Return '房主的 NAT 为 3 或更差 + Dim OtherPlayers = Peers.Where(Function(p) p.Type = Peer.Types.Client).ToList() + If Not OtherPlayers.Any() Then Return '房间里还有其他玩家 + If OtherPlayers.Any(Function(p) p.Relay) Then Return '自己可以与所有玩家打洞 + If OtherPlayers.All(Function(p) p.NATType < NATTypes.PortRestricted) Then Return '任意其他玩家的 NAT 为 3 或更差 + HintFinish.Visibility = Visibility.Visible + HintFinish.Theme = MyHint.Themes.Blue + HintFinish.Text = "你的网络环境比房主更好！如果你来当房主，其他玩家或许能更加流畅！" + End Sub) + End If + '检查核心状态 + CheckCrash() + '检查节点状态 + If Not Peers.Any Then + Panic("网络连接已断开", "请检查你的网络环境是否正常。") + Return + End If + If Not IsServerSide AndAlso Not Peers.Any(Function(p) p.Type = Peer.Types.Server) Then + MyMsgBox("房主已离开房间！", "联机结束") + ChangeState(LinkStates.Waiting) + Return + End If + '广播联机房间端口 + If Not IsServerSide Then + Try + Static BroadcastSocket As New Socket(SocketType.Dgram, ProtocolType.Udp) + BroadcastSocket.SendTo( + Encoding.UTF8.GetBytes($"[MOTD]PCL 联机房间[/MOTD][AD]{ClientPort}[/AD]"), + SocketFlags.None, + New IPEndPoint(IPAddress.Loopback, 4445)) + Catch ex As Exception + Log(ex, "广播联机房间端口失败") + End Try + End If + End Sub + ''' + ''' 检查联机模块是否崩溃。 + ''' + Private Sub CheckCrash() + If ProcessCore IsNot Nothing AndAlso Not ProcessCore.HasExited Then Return + Panic("联机模块已崩溃", "近期日志：" & vbCrLf & LogHistory.Join(vbCrLf)) + End Sub + +#End Region + +End Class diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml b/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml index 784edbf..8b75d08 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageOtherAbout" - PanScroll="{Binding ElementName=PanBack}" RenderOptions.BitmapScalingMode="LowQuality"> + PanScroll="PanBack" RenderOptions.BitmapScalingMode="LowQuality"> @@ -29,8 +29,10 @@ - - + + @@ -44,6 +46,7 @@ + @@ -51,16 +54,18 @@ - + - + - - - - - - + + + + + + + + @@ -76,27 +81,32 @@ - + - + - + - + - + + + + + + @@ -105,245 +115,566 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -352,7 +683,7 @@ - + @@ -361,14 +692,14 @@ - + - + - - + + @@ -396,54 +727,62 @@ + + + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/00ll00/java_launch_wrapper" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/00ll00/java_launch_wrapper?tab=MIT-1-ov-file#readme" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://www.newtonsoft.com/json" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://opensource.org/licenses/MIT" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/naudio/NAudio" /> - + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/naudio/NAudio/blob/master/license.txt" /> + + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://www.ookii.org/Software/Dialogs/" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/caioproiete/ookii-dialogs-wpf/blob/master/LICENSE" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://iconmonstr.com/" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://iconmonstr.com/license/" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/imazen/libwebp-net" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://github.com/imazen/libwebp-net/blob/master/LICENSE.txt" /> + local:CustomEventService.EventType="打开网页" local:CustomEventService.EventData="https://www.iconfont.cn/" /> + + + + diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml.vb b/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml.vb index 13e7a3f..cbaec36 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherAbout.xaml.vb @@ -18,8 +18,8 @@ End Sub - Public Shared Sub CopyUniqueAddress() Handles BtnDonateCopy.Click - ClipboardSet(UniqueAddress) + Public Shared Sub CopyIdentify() Handles BtnDonateCopy.Click + ClipboardSet(Identify) End Sub Private Sub BtnDonateCodeInput_Click() Handles BtnDonateInput.Click DonateCodeInput() diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml index 81a1636..411d5bb 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageOtherHelp" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml.vb b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml.vb index a1a4c96..6fd927f 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelp.xaml.vb @@ -71,7 +71,7 @@ Public Shared Sub OnItemClick(Entry As HelpEntry) Try If Entry.IsEvent Then - ModEvent.TryStartEvent(Entry.EventType, Entry.EventData) + CustomEvent.Raise(Entry.EventType, Entry.EventData) Else EnterHelpPage(Entry) End If diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml index 397f398..8ad8d1b 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml @@ -4,7 +4,7 @@ xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:local="clr-namespace:PCL" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml.vb b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml.vb index dafcd2e..9d6b223 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherHelpDetail.xaml.vb @@ -18,8 +18,10 @@ If Content = "" Then Throw New Exception("帮助 xaml 文件为空") Try '修改时应同时修改 PageLaunchRight.LoadContent - Content = HelpArgumentReplace(Content) - If Content.Contains("xmlns") Then Content = Content.RegexReplace("xmlns[^""']*(""|')[^""']*(""|')", "").Replace("xmlns", "") '禁止声明命名空间 + Content = ArgumentReplace(Content, AddressOf EscapeXML) + Do While Content.Contains("xmlns") + Content = Content.RegexReplace("xmlns[^""']*(""|')[^""']*(""|')", "").Replace("xmlns", "") '禁止声明命名空间 + Loop Content = "" & Content & "" Me.Entry = Entry PanCustom.Children.Clear() diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml b/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml index 0c62e42..e423e76 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml @@ -1,7 +1,7 @@  + xmlns:local="clr-namespace:PCL" AnimatedControl="PanItem"> diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml.vb index 534af41..5ecaa33 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherLeft.xaml.vb @@ -132,7 +132,7 @@ End Sub Public Shared Sub TryFeedback() If Not CanFeedback(True) Then Return - Select Case MyMsgBox("在提交新反馈前，建议先搜索反馈列表，以避免重复提交。" & vbCrLf & "如果无法打开该网页，请使用 VPN 以改善网络环境。", + Select Case MyMsgBox("在提交新反馈前，建议先搜索反馈列表，以避免重复提交。" & vbCrLf & "如果无法打开该网页，请使用 VPN 改善网络环境。", "反馈", "提交新反馈", "查看反馈列表", "取消") Case 1 Feedback(True, False) @@ -146,7 +146,7 @@ e.Handled = True End Sub Public Shared Sub TryVote() - If MyMsgBox("是否要打开新功能投票网页？" & vbCrLf & "如果无法打开该网页，请使用 VPN 以改善网络环境。", + If MyMsgBox("是否要打开新功能投票网页？" & vbCrLf & "如果无法打开该网页，请使用 VPN 改善网络环境。", "新功能投票", "打开", "取消") = 2 Then Return OpenWebsite("https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8?discussions_q=category%3A%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8+sort%3Adate_created") End Sub diff --git a/Plain Craft Launcher 2/Pages/PageOther/PageOtherTest.xaml b/Plain Craft Launcher 2/Pages/PageOther/PageOtherTest.xaml index 9623808..a8ba073 100644 --- a/Plain Craft Launcher 2/Pages/PageOther/PageOtherTest.xaml +++ b/Plain Craft Launcher 2/Pages/PageOther/PageOtherTest.xaml @@ -5,7 +5,7 @@ xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:local="clr-namespace:PCL" xmlns:sys="clr-namespace:System;assembly=mscorlib" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml b/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml index 2dfe903..e7b6bc6 100644 --- a/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml +++ b/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml @@ -1,7 +1,7 @@  + AnimatedControl="PanList"> diff --git a/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml.vb index 7d8d927..4469cc2 100644 --- a/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSelectLeft.xaml.vb @@ -150,14 +150,14 @@ Dim NewFolder As String = "" '检查是否有下载任务 If HasDownloadingTask() Then - Hint("在下载任务进行时，无法添加游戏文件夹！", HintType.Critical) + Hint("在下载任务进行时，无法添加游戏文件夹！", HintType.Red) Return End If Try '获取输入 NewFolder = SelectFolder() If NewFolder = "" Then Return - If NewFolder.Contains("!") OrElse NewFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Return + If NewFolder.Contains("!") OrElse NewFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Red) : Return '要求输入显示名称 Dim SplitedNames As String() = NewFolder.TrimEnd("\").Split("\") Dim DefaultName As String = If(SplitedNames.Last = ".minecraft", If(SplitedNames.Count >= 3, SplitedNames(SplitedNames.Count - 2), ""), SplitedNames.Last) @@ -182,7 +182,7 @@ '检查文件夹权限 If Not CheckPermission(FolderPath) Then If ShowHint Then - Hint("添加文件夹失败：PCL 没有访问该文件夹的权限！", HintType.Critical) + Hint("添加文件夹失败：PCL 没有访问该文件夹的权限！", HintType.Red) Return Else Throw New Exception("PCL 没有访问文件夹的权限：" & FolderPath) @@ -207,12 +207,12 @@ If Folder.Split(">")(1) = FolderPath Then IsAdded = True If Folder.Split(">")(0) = DisplayName Then - If ShowHint Then Hint("此文件夹已在列表中！", HintType.Info) + If ShowHint Then Hint("此文件夹已在列表中！", HintType.Blue) Return Else Folders(i) = DisplayName & ">" & FolderPath IsReplace = True - If ShowHint Then Hint("文件夹名称已更新为 " & DisplayName & " ！", HintType.Finish) + If ShowHint Then Hint("文件夹名称已更新为 " & DisplayName & " ！", HintType.Green) End If Exit For End If @@ -226,7 +226,7 @@ McFolderListLoader.Start(IsForceRestart:=True) '提示 If IsReplace Then Return - If ShowHint Then Hint("文件夹 " & DisplayName & " 已添加！", HintType.Finish) + If ShowHint Then Hint("文件夹 " & DisplayName & " 已添加！", HintType.Green) '检查是否为根目录整合包，自动关闭版本隔离 '1. 根目录中存在数个 Mod Dim ModFolder As New DirectoryInfo(FolderPath & "mods\") @@ -257,7 +257,7 @@ Public Sub Create_Click() '检查是否有下载任务 If HasDownloadingTask() Then - Hint("在下载任务进行时，无法创建游戏文件夹！", HintType.Critical) + Hint("在下载任务进行时，无法创建游戏文件夹！", HintType.Red) Return End If If Not Directory.Exists(Path & ".minecraft\") Then @@ -265,7 +265,7 @@ Directory.CreateDirectory(Path & ".minecraft\versions\") Setup.Set("LaunchFolderSelect", "$.minecraft\") McFolderLauncherProfilesJsonCreate(Path & ".minecraft\") - Hint("新建 .minecraft 文件夹成功！", HintType.Finish) + Hint("新建 .minecraft 文件夹成功！", HintType.Green) End If McFolderListLoader.Start(IsForceRestart:=True) End Sub @@ -307,7 +307,7 @@ Next '保存 Setup.Set("LaunchFolders", If(Not Folders.Any(), "", Join(Folders.ToArray, "|"))) - Hint(If(Folder.Type = McFolderType.Custom, "文件夹 " & Name & " 已从列表中移除！", "文件夹名称已复原！"), HintType.Finish) + Hint(If(Folder.Type = McFolderType.Custom, "文件夹 " & Name & " 已从列表中移除！", "文件夹名称已复原！"), HintType.Green) McFolderListLoader.Start(IsForceRestart:=True) Catch ex As Exception @@ -336,10 +336,10 @@ Sub() '删除文件夹 Try - Hint("正在" & DeleteText & "文件夹 " & Folder.Name & "！", HintType.Info) + Hint("正在" & DeleteText & "文件夹 " & Folder.Name & "！", HintType.Blue) DeleteDirectory(Folder.Path) If DeleteText = "清空" Then Directory.CreateDirectory(Folder.Path) - Hint("已" & DeleteText & "文件夹 " & Folder.Name & "！", HintType.Finish) + Hint("已" & DeleteText & "文件夹 " & Folder.Name & "！", HintType.Green) Catch ex As Exception Log(ex, DeleteText & "文件夹 " & Folder.Name & " 失败", LogLevel.Hint) Finally @@ -389,7 +389,7 @@ Next '如果没有添加过，则添加进去（因为修改了默认项的名称） If Not IsAdded Then Folders.Add(NewName & ">" & Folder.Path) - Hint("文件夹名称已更新为 " & NewName & " ！", HintType.Finish) + Hint("文件夹名称已更新为 " & NewName & " ！", HintType.Green) '保存 Setup.Set("LaunchFolders", Join(Folders.ToArray, "|")) McFolderListLoader.Start(IsForceRestart:=True) @@ -403,7 +403,7 @@ If Not e.RaiseByMouse OrElse Not sender.Checked Then Return '检查是否有下载任务 If HasDownloadingTask(True) Then - Hint("在下载任务进行时，无法切换游戏文件夹！", HintType.Critical) + Hint("在下载任务进行时，无法切换游戏文件夹！", HintType.Red) e.Handled = True Return End If diff --git a/Plain Craft Launcher 2/Pages/PageSelectRight.xaml b/Plain Craft Launcher 2/Pages/PageSelectRight.xaml index 2ded4ab..bcc54aa 100644 --- a/Plain Craft Launcher 2/Pages/PageSelectRight.xaml +++ b/Plain Craft Launcher 2/Pages/PageSelectRight.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageSelectRight" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> diff --git a/Plain Craft Launcher 2/Pages/PageSelectRight.xaml.vb b/Plain Craft Launcher 2/Pages/PageSelectRight.xaml.vb index e6e7d27..16bd2f8 100644 --- a/Plain Craft Launcher 2/Pages/PageSelectRight.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSelectRight.xaml.vb @@ -114,22 +114,7 @@ Log(ex, "将版本列表转换显示时失败", LogLevel.Feedback) End Try End Sub - Public Shared Function McVersionListItem(Version As McVersion) As MyListItem - Dim NewItem As New MyListItem With {.Title = Version.Name, .Info = Version.Info, .Height = 42, .Tag = Version, .SnapsToDevicePixels = True, .Type = MyListItem.CheckType.Clickable} - Try - If Version.Logo.EndsWith("PCL\Logo.png") Then - NewItem.Logo = Version.Path & "PCL\Logo.png" '修复老版本中，存储的自定义 Logo 使用完整路径，导致移动后无法加载的 Bug - Else - NewItem.Logo = Version.Logo - End If - Catch ex As Exception - Log(ex, "加载版本图标失败", LogLevel.Hint) - NewItem.Logo = "pack://application:,,,/images/Blocks/RedstoneBlock.png" - End Try - NewItem.ContentHandler = AddressOf McVersionListContent - Return NewItem - End Function - Private Shared Sub McVersionListContent(sender As MyListItem, e As EventArgs) + Public Shared Sub McVersionListContent(sender As MyListItem, e As EventArgs) Dim Version As McVersion = sender.Tag '注册点击事件 AddHandler sender.Click, AddressOf Item_Click @@ -225,10 +210,10 @@ IniClearCache(Version.Path & "PCL\Setup.ini") If IsShiftPressed Then DeleteDirectory(Version.Path) - Hint("版本 " & Version.Name & " 已永久删除！", HintType.Finish) + Hint("版本 " & Version.Name & " 已永久删除！", HintType.Green) Else FileIO.FileSystem.DeleteDirectory(Version.Path, FileIO.UIOption.AllDialogs, FileIO.RecycleOption.SendToRecycleBin) - Hint("版本 " & Version.Name & " 已删除到回收站！", HintType.Finish) + Hint("版本 " & Version.Name & " 已删除！", HintType.Green) End If Case 2 Return diff --git a/Plain Craft Launcher 2/Pages/PageSetup/ModSetup.vb b/Plain Craft Launcher 2/Pages/PageSetup/ModSetup.vb index 7e28d54..a4f29ab 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/ModSetup.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/ModSetup.vb @@ -24,7 +24,8 @@ {"HintMoreAdvancedSetup", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintIndieSetup", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintExportConfig", New SetupEntry(False, Source:=SetupSource.Registry)}, - {"SystemEula", New SetupEntry(False, Source:=SetupSource.Registry)}, + {"SystemEula", New SetupEntry(False, Source:=SetupSource.Registry)}, '仅老版本兼容，现已换用 SystemEulaVersion + {"SystemEulaVersion", New SetupEntry(0, Source:=SetupSource.Registry)}, {"SystemCount", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)}, {"SystemLaunchCount", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)}, {"SystemLastVersionReg", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)}, @@ -42,6 +43,7 @@ {"SystemSystemUpdate", New SetupEntry(0)}, {"SystemSystemActivity", New SetupEntry(0)}, {"SystemSystemTelemetry", New SetupEntry(True, Source:=SetupSource.Registry)}, + {"CacheConfig", New SetupEntry(0, Source:=SetupSource.Registry)}, {"CacheExportConfig", New SetupEntry("", Source:=SetupSource.Registry)}, {"CacheSavedPageUrl", New SetupEntry("", Source:=SetupSource.Registry)}, {"CacheSavedPageVersion", New SetupEntry("", Source:=SetupSource.Registry)}, @@ -109,12 +111,11 @@ {"LaunchAdvanceGraphicCard", New SetupEntry(True, Source:=SetupSource.Registry)}, {"LaunchRamType", New SetupEntry(0)}, {"LaunchRamCustom", New SetupEntry(15)}, - {"LinkEula", New SetupEntry(False, Source:=SetupSource.Registry)}, - {"LinkName", New SetupEntry("", Source:=SetupSource.Registry)}, - {"LinkHiperCertLast", New SetupEntry("", Source:=SetupSource.Registry)}, - {"LinkHiperCertTime", New SetupEntry("", Source:=SetupSource.Registry)}, - {"LinkHiperCertWarn", New SetupEntry(True, Source:=SetupSource.Registry)}, - {"LinkIoiVersion", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)}, + {"LinkLastAutoJoinInviteCode", New SetupEntry("", Source:=SetupSource.Registry)}, + {"LinkShareMode", New SetupEntry(True, Source:=SetupSource.Registry)}, + {"LinkLatencyMode", New SetupEntry(0, Source:=SetupSource.Registry)}, + {"LinkCustomPeer", New SetupEntry("")}, + {"LinkEasyTierVersion", New SetupEntry(-1, Source:=SetupSource.Registry)}, {"ToolHelpChinese", New SetupEntry(True, Source:=SetupSource.Registry)}, {"ToolDownloadThread", New SetupEntry(63, Source:=SetupSource.Registry)}, {"ToolDownloadSpeed", New SetupEntry(42, Source:=SetupSource.Registry)}, @@ -181,6 +182,7 @@ {"VersionAdvanceRun", New SetupEntry("", Source:=SetupSource.Version)}, {"VersionAdvanceRunWait", New SetupEntry(True, Source:=SetupSource.Version)}, {"VersionAdvanceDisableJLW", New SetupEntry(False, Source:=SetupSource.Version)}, + {"VersionAdvanceDisableModUpdate", New SetupEntry(False, Source:=SetupSource.Version)}, {"VersionRamType", New SetupEntry(2, Source:=SetupSource.Version)}, {"VersionRamCustom", New SetupEntry(15, Source:=SetupSource.Version)}, {"VersionRamOptimize", New SetupEntry(0, Source:=SetupSource.Version)}, @@ -226,7 +228,7 @@ Me.Value = Value Me.Source = Source Me.Type = If(Value, New Object).GetType - Me.DefaultValueEncoded = If(Encoded, SecretEncrypt(Value, "PCL" & UniqueAddress), Value) + Me.DefaultValueEncoded = If(Encoded, SecretEncrypt(Value, "PCL" & Identify), Value) Catch ex As Exception Log(ex, "初始化 SetupEntry 失败", LogLevel.Feedback) '#5095 的 fallback End Try @@ -240,6 +242,14 @@ Public Sub [Set](Key As String, Value As Object, Optional ForceReload As Boolean = False, Optional Version As McVersion = Nothing) [Set](Key, Value, SetupDict(Key), ForceReload, Version) End Sub + ''' + ''' 写入某个未经加密的设置项。 + ''' 若该设置项经过了加密，则会抛出异常。 + ''' + Public Sub SetSafe(Key As String, Value As Object, Optional ForceReload As Boolean = False, Optional Version As McVersion = Nothing) + If SetupDict(Key).Encoded Then Throw New InvalidOperationException("禁止写入加密设置项：" & Key) + [Set](Key, Version, ForceReload, Version) + End Sub Private Sub [Set](Key As String, Value As Object, E As SetupEntry, ForceReload As Boolean, Version As McVersion) Try @@ -257,7 +267,7 @@ If E.Encoded Then Try If Value Is Nothing Then Value = "" - Value = SecretEncrypt(Value, "PCL" & UniqueAddress) + Value = SecretEncrypt(Value, "PCL" & Identify) Catch ex As Exception Log(ex, "加密设置失败：" & Key, LogLevel.Developer) End Try @@ -302,9 +312,17 @@ ''' 获取某个设置项的值。 ''' Public Function [Get](Key As String, Optional Version As McVersion = Nothing) - If Not SetupDict.ContainsKey(Key) Then Throw New KeyNotFoundException("未找到设置项：" & Key) With {.Source = Key} + If Not SetupDict.ContainsKey(Key) Then Throw New KeyNotFoundException("未找到设置项：" & Key) Return [Get](Key, SetupDict(Key), Version) End Function + ''' + ''' 获取某个未经加密的设置项的值。 + ''' 若该设置项经过了加密，则会抛出异常。 + ''' + Public Function GetSafe(Key As String, Optional Version As McVersion = Nothing) + If SetupDict(Key).Encoded Then Throw New InvalidOperationException("禁止读取加密设置项：" & Key) + Return [Get](Key, Version) + End Function Private Function [Get](Key As String, E As SetupEntry, Version As McVersion) '获取强制值 Dim Force As String = ForceValue(Key) @@ -382,7 +400,7 @@ SourceValue = E.DefaultValue Else Try - SourceValue = SecretDecrypt(SourceValue, "PCL" & UniqueAddress) + SourceValue = SecretDecrypt(SourceValue, "PCL" & Identify) Catch ex As Exception Log(ex, "解密设置失败：" & Key, LogLevel.Developer) SourceValue = E.DefaultValue @@ -402,8 +420,6 @@ #If BETA Then If Key = "UiLauncherTheme" Then Return "0" #End If - If Key = "UiHiddenPageLink" Then Return True - If Key = "UiHiddenSetupLink" Then Return True Return Nothing End Function @@ -600,8 +616,7 @@ FrmSetupUI.HintCustom.Visibility = Visibility.Visible FrmSetupUI.HintCustomWarn.Visibility = If(Setup.Get("HintCustomWarn"), Visibility.Collapsed, Visibility.Visible) FrmSetupUI.HintCustom.Text = $"从 PCL 文件夹下的 Custom.xaml 读取主页内容。{vbCrLf}你可以手动编辑该文件，向主页添加文本、图片、常用网站、快捷启动等功能。" - FrmSetupUI.HintCustom.EventType = "" - FrmSetupUI.HintCustom.EventData = "" + CustomEventService.SetEventType(FrmSetupUI.HintCustom, CustomEvent.EventType.None) Case 2 '联网 FrmSetupUI.PanCustomPreset.Visibility = Visibility.Collapsed FrmSetupUI.PanCustomLocal.Visibility = Visibility.Collapsed @@ -609,8 +624,8 @@ FrmSetupUI.HintCustom.Visibility = Visibility.Visible FrmSetupUI.HintCustomWarn.Visibility = If(Setup.Get("HintCustomWarn"), Visibility.Collapsed, Visibility.Visible) FrmSetupUI.HintCustom.Text = $"从指定网址联网获取主页内容。服主也可以用于动态更新服务器公告。{vbCrLf}如果你制作了稳定运行的联网主页，可以点击这条提示投稿，若合格即可加入预设！" - FrmSetupUI.HintCustom.EventType = "打开网页" - FrmSetupUI.HintCustom.EventData = "https://github.com/Meloong-Git/PCL/discussions/2528" + CustomEventService.SetEventType(FrmSetupUI.HintCustom, CustomEvent.EventType.打开网页) + CustomEventService.SetEventData(FrmSetupUI.HintCustom, "https://github.com/Meloong-Git/PCL/discussions/2528") Case 3 '预设 FrmSetupUI.PanCustomPreset.Visibility = Visibility.Visible FrmSetupUI.PanCustomLocal.Visibility = Visibility.Collapsed diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml index 82c7e31..9345f80 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml @@ -4,7 +4,7 @@ xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:System="clr-namespace:System;assembly=mscorlib" mc:Ignorable="d" x:Class="PageSetupLaunch" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> @@ -41,9 +41,9 @@ - + - + @@ -86,14 +86,14 @@ - + - + @@ -218,7 +218,7 @@ - + @@ -240,13 +240,13 @@ ToolTip="还原" ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="200" ToolTipService.VerticalOffset="-1" Logo="M530 0c287 0 521 229 521 511s-233 511-521 511c-233 0-436-151-500-368a63 63 0 0 1 44-79 65 65 0 0 1 80 43c48 162 200 276 375 276 215 0 390-171 390-383s-174-383-390-383c-103 0-199 39-270 106l21-5a63 63 0 0 1 33 123l-157 42a65 65 0 0 1-90-42l-49-183a65 65 0 1 1 126-33l6 26A524 524 0 0 1 530 0z" LogoScale="0.9" /> - - + + ToolTip="在 MC 启动前执行特定命令或程序，语法与 Windows 的命令提示符一致。 你可以用替换标记来动态改变其内容或实现相对路径，在 更多 → 帮助 中搜索 “替换标记” 以了解用法。例如： · "{verpath}test.exe" ：运行版本文件夹下的 test.exe 程序 · "{java}java.exe" -jar "{verpath}test.jar" ：用 Java 运行版本文件夹下的 test.jar · notepad "{verindie}options.txt" ：使用记事本打开该版本的设置文件 涉及路径的操作最好都打上双引号，以避免路径中的空格导致运行失败。 执行命令时，命令行所在的目录是当前的 .minecraft 文件夹。" /> @@ -255,7 +255,7 @@ - diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml.vb b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml.vb index cf7f598..cf5f028 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLaunch.xaml.vb @@ -71,7 +71,7 @@ Try Setup.Reset("LaunchArgumentTitle") Setup.Reset("LaunchArgumentInfo") - Setup.Reset("LaunchArgumentIndieV2") + Setup.Set("LaunchArgumentIndieV2", Setup.GetDefault("LaunchArgumentIndieV2")) Setup.Reset("LaunchArgumentVisible") Setup.Reset("LaunchArgumentWindowType") Setup.Reset("LaunchArgumentWindowWidth") @@ -93,7 +93,7 @@ JavaSearchLoader.Start(IsForceRestart:=True) Log("[Setup] 已初始化启动设置") - Hint("已初始化启动设置！", HintType.Finish, False) + Hint("已初始化启动设置！", HintType.Green, False) Catch ex As Exception Log(ex, "初始化启动设置失败", LogLevel.Msgbox) End Try @@ -170,7 +170,7 @@ Try File.Delete(PathAppdata & "CustomSkin.png") RadioSkinType0.SetChecked(True, True) - Hint("离线皮肤已清空！", HintType.Finish) + Hint("离线皮肤已清空！", HintType.Green) Catch ex As Exception Log(ex, "清空离线皮肤失败", LogLevel.Msgbox) End Try @@ -468,7 +468,7 @@ PreFin: '手动选择 Private Sub BtnArgumentJavaSelect_Click(sender As Object, e As EventArgs) Handles BtnArgumentJavaSelect.Click If JavaSearchLoader.State = LoadState.Loading Then - Hint("正在搜索 Java，请稍候！", HintType.Critical) + Hint("正在搜索 Java，请稍候！", HintType.Red) Return End If '选择 Java @@ -489,7 +489,7 @@ PreFin: Setup.Set("LaunchArgumentJavaAll", JavaNewList.ToString(Newtonsoft.Json.Formatting.None)) '重新加载列表 JavaSearchLoader.Start(IsForceRestart:=True) - Hint("已将该 Java 加入 Java 列表！", HintType.Finish) + Hint("已将该 Java 加入 Java 列表！", HintType.Green) Catch ex As Exception Log(ex, "该 Java 存在异常，无法使用", LogLevel.Msgbox, "异常的 Java") Return @@ -498,7 +498,7 @@ PreFin: '自动查找 Private Sub BtnArgumentJavaSearch_Click(sender As Object, e As EventArgs) Handles BtnArgumentJavaSearch.Click If JavaSearchLoader.State = LoadState.Loading Then - Hint("正在搜索 Java，请稍候！", HintType.Critical) + Hint("正在搜索 Java，请稍候！", HintType.Red) Return End If RunInThread( @@ -506,9 +506,9 @@ PreFin: Hint("正在搜索 Java！") JavaSearchLoader.WaitForExit(IsForceRestart:=True) If Not JavaList.Any() Then - Hint("未找到可用的 Java！", HintType.Critical) + Hint("未找到可用的 Java！", HintType.Red) Else - Hint("已找到 " & JavaList.Count & " 个 Java，请检查下拉框查看列表！", HintType.Finish) + Hint("已找到 " & JavaList.Count & " 个 Java，请检查下拉框查看列表！", HintType.Green) End If End Sub) End Sub @@ -585,4 +585,12 @@ PreFin: FrmMain.PageChange(FormMain.PageType.VersionSetup, FormMain.PageSubType.VersionSetup) End Sub + '去除参数中的回车 + Private Sub ReplaceEnter(sender As MyTextBox, e As TextChangedEventArgs) Handles TextAdvanceJvm.TextChanged, TextAdvanceGame.TextChanged + Dim NewText = sender.Text.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ") + If NewText = sender.Text Then Return + Dim CaretIndex = sender.CaretIndex + sender.Text = NewText + sender.CaretIndex = Math.Max(0, CaretIndex - 1) + End Sub End Class diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml index 22a9a63..7c81663 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml @@ -2,34 +2,34 @@ xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation" xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageSetupLeft" - d:DesignWidth="152" AnimatedControl="{Binding ElementName=PanItem, Mode=OneWay}"> + d:DesignWidth="152" AnimatedControl="PanItem"> + LogoScale="0.8" Logo="M52.1,164.5c-1.4,0-3.1-0.5-4.2-1.3c-2.6-1.7-4-4.2-4-7V43.8c0-2.9,1.6-5.8,4.1-7c1.2-0.8,2.7-1.2,4.1-1.2c1.5,0,2.9,0.4,4.2,1.2L153.1,93c0,0,0.1,0,0.1,0.1c2.6,1.7,4,4.2,4,7c0,3-1.7,5.8-4.2,7.1l-96.8,56.2C55.1,164,53.5,164.5,52.1,164.5z M60.4,142.1l72.1-42.1L60.4,58.2V142.1z"> - + - + - + diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml.vb index 5744a66..b8b8030 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLeft.xaml.vb @@ -126,17 +126,19 @@ FrmMain.PageRight = Target CType(FrmMain.PanMainRight.Child, MyPageRight).PageOnExit() AniStart({ - AaCode(Sub() - CType(FrmMain.PanMainRight.Child, MyPageRight).PageOnForceExit() - FrmMain.PanMainRight.Child = FrmMain.PageRight - FrmMain.PageRight.Opacity = 0 - End Sub, 130), - AaCode(Sub() - '延迟触发页面通用动画，以使得在 Loaded 事件中加载的控件得以处理 - FrmMain.PageRight.Opacity = 1 - FrmMain.PageRight.PageOnEnter() - End Sub, 30, True) - }, "PageLeft PageChange") + AaCode( + Sub() + CType(FrmMain.PanMainRight.Child, MyPageRight).PageOnForceExit() + FrmMain.PanMainRight.Child = FrmMain.PageRight + FrmMain.PageRight.Opacity = 0 + End Sub, 130), + AaCode( + Sub() + '延迟触发页面通用动画，以使得在 Loaded 事件中加载的控件得以处理 + FrmMain.PageRight.Opacity = 1 + FrmMain.PageRight.PageOnEnter() + End Sub, 30, True) + }, "PageLeft PageChange") End Sub #End Region diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml index 4780c9d..fdd2289 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml @@ -3,36 +3,55 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageSetupLink" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> - - - - - - - + + - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml.vb b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml.vb index 3069a96..abd8d53 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupLink.xaml.vb @@ -1,4 +1,4 @@ -Class PageSetupLink +Public Class PageSetupLink Private Shadows IsLoaded As Boolean = False @@ -17,18 +17,20 @@ End Sub Public Sub Reload() - TextLinkName.Text = Setup.Get("LinkName") - CheckHiperCertWarn.Checked = Setup.Get("LinkHiperCertWarn") + ComboLatencyMode.SelectedIndex = Setup.Get("LinkLatencyMode") + CheckShareMode.Checked = Setup.Get("LinkShareMode") + TextCustomPeer.Text = Setup.Get("LinkCustomPeer") End Sub '初始化 Public Sub Reset() Try - Setup.Reset("LinkName") - Setup.Reset("LinkHiperCertWarn") + Setup.Reset("LinkLatencyMode") + Setup.Reset("LinkShareMode") + Setup.Reset("LinkCustomPeer") Log("[Setup] 已初始化联机页设置") - Hint("已初始化联机页设置！", HintType.Finish, False) + Hint("已初始化联机页设置！", HintType.Green, False) Catch ex As Exception Log(ex, "初始化联机页设置失败", LogLevel.Msgbox) End Try @@ -37,14 +39,14 @@ End Sub '将控件改变路由到设置改变 - Private Shared Sub TextBoxChange(sender As MyTextBox, e As Object) Handles TextLinkName.ValidatedTextChanged + Private Shared Sub TextBoxChange(sender As MyTextBox, e As Object) Handles TextCustomPeer.ValidatedTextChanged If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.Text) End Sub - Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckHiperCertWarn.Change + Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckShareMode.Change If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.Checked) End Sub - - Private Sub BtnHiperLog_Click(sender As Object, e As EventArgs) Handles BtnHiperLog.Click + Private Shared Sub ComboChange(sender As MyComboBox, e As Object) Handles ComboLatencyMode.SelectionChanged + If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.SelectedIndex) End Sub End Class diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml index e449f1d..6cdea43 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml @@ -4,7 +4,7 @@ xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" xmlns:sys="clr-namespace:System;assembly=mscorlib" mc:Ignorable="d" x:Class="PageSetupSystem" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> @@ -150,7 +150,7 @@ + ToolTip="当下载失败、PCL 出错、游戏崩溃等事件时，PCL 会匿名上报情况，以通知龙猫 “哦吼，出错了”，让龙猫能更好地修 Bug…… 你可以关闭上报，不过龙猫就不知道你遇到了什么 Bug 了…… PCL 不会上传或收集任何个人信息，包括上报的东西里面也没有！ 详情：https://github.com/Meloong-Git/PCL/discussions/7036" /> diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml.vb b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml.vb index 7ead8ef..766413a 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupSystem.xaml.vb @@ -85,7 +85,7 @@ Setup.Reset("SystemSystemTelemetry") Log("[Setup] 已初始化启动器页设置") - Hint("已初始化启动器页设置！", HintType.Finish, False) + Hint("已初始化启动器页设置！", HintType.Green, False) Catch ex As Exception Log(ex, "初始化启动器页设置失败", LogLevel.Msgbox) End Try @@ -136,7 +136,7 @@ '识别码/解锁码替代入口 Private Sub BtnSystemIdentify_Click(sender As Object, e As MouseButtonEventArgs) Handles BtnSystemIdentify.Click - PageOtherAbout.CopyUniqueAddress() + PageOtherAbout.CopyIdentify() End Sub Private Sub BtnSystemUnlock_Click(sender As Object, e As MouseButtonEventArgs) Handles BtnSystemUnlock.Click DonateCodeInput() diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml index 95daf12..7767763 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageSetupUI" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack"> @@ -225,7 +225,8 @@ - + @@ -252,6 +253,7 @@ + @@ -279,14 +281,14 @@ - - - + + + - - - + + + diff --git a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml.vb b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml.vb index e39438e..3d42789 100644 --- a/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSetup/PageSetupUI.xaml.vb @@ -162,7 +162,7 @@ Setup.Reset("UiHiddenOtherTest") Log("[Setup] 已初始化个性化设置！") - Hint("已初始化个性化设置", HintType.Finish, False) + Hint("已初始化个性化设置", HintType.Green, False) Catch ex As Exception Log(ex, "初始化个性化设置失败", LogLevel.Msgbox) End Try @@ -215,7 +215,7 @@ If MyMsgBox("即将删除背景图片文件夹中的所有文件。" & vbCrLf & "此操作不可撤销，是否确定？", "警告",, "取消", IsWarn:=True) = 1 Then DeleteDirectory(Path & "PCL\Pictures") BackgroundRefresh(False, True) - Hint("背景图片已清空！", HintType.Finish) + Hint("背景图片已清空！", HintType.Green) End If End Sub ''' @@ -238,10 +238,10 @@ If Not Pic.Any() Then If Refresh Then If FrmMain.ImgBack.Visibility = Visibility.Collapsed Then - If IsHint Then Hint("未检测到可用背景图片！", HintType.Critical) + If IsHint Then Hint("未检测到可用背景图片！", HintType.Red) Else FrmMain.ImgBack.Visibility = Visibility.Collapsed - If IsHint Then Hint("背景图片已清除！", HintType.Finish) + If IsHint Then Hint("背景图片已清除！", HintType.Green) End If End If If Not IsNothing(FrmSetupUI) Then FrmSetupUI.BackgroundRefreshUI(False, 0) @@ -253,7 +253,7 @@ FrmMain.ImgBack.Background = New MyBitmap(Address) Setup.Load("UiBackgroundSuit", True) FrmMain.ImgBack.Visibility = Visibility.Visible - If IsHint Then Hint("背景图片已刷新：" & GetFileNameFromPath(Address), HintType.Finish, False) + If IsHint Then Hint("背景图片已刷新：" & GetFileNameFromPath(Address), HintType.Green, False) Catch ex As Exception If ex.Message.Contains("参数无效") Then Log("刷新背景图片失败，该图片文件可能并非标准格式。" & vbCrLf & @@ -338,7 +338,7 @@ Refresh: Try File.Delete(Path & "PCL\Logo.png") RadioLogoType1.SetChecked(True, True) - Hint("标题栏图片已清空！", HintType.Finish) + Hint("标题栏图片已清空！", HintType.Green) Catch ex As Exception Log(ex, "清空标题栏图片失败", LogLevel.Msgbox) End Try @@ -358,7 +358,7 @@ Refresh: PanMusicDetail.Visibility = Visibility.Visible BtnMusicClear.Visibility = Visibility.Visible CardMusic.Title = "背景音乐（" & - EnumerateFiles(Path & "PCL\Musics\").Count(Function(f) {".ini", ".jpg", ".txt", ".cfg", ".lrc", ".db", ".png"}.Contains(f.Extension.ToLower)) & + EnumerateFiles(Path & "PCL\Musics\").Count(Function(f) Not {".ini", ".jpg", ".txt", ".cfg", ".lrc", ".db", ".png"}.Contains(f.Extension.ToLower)) & " 首）" Else PanMusicVolume.Visibility = Visibility.Collapsed @@ -381,7 +381,7 @@ Refresh: '删除文件 Try DeleteDirectory(Path & "PCL\Musics") - Hint("背景音乐已删除！", HintType.Finish) + Hint("背景音乐已删除！", HintType.Green) Catch ex As Exception Log(ex, "删除背景音乐失败", LogLevel.Msgbox) End Try @@ -410,7 +410,7 @@ Refresh: If MyMsgBox("当前已存在布局文件，继续生成教学文件将会覆盖现有布局文件！", "覆盖确认", "继续", "取消", IsWarn:=True) = 2 Then Return End If WriteFile(Path & "PCL\Custom.xaml", GetResources("Custom")) - Hint("教学文件已生成！", HintType.Finish) + Hint("教学文件已生成！", HintType.Green) OpenExplorer(Path & "PCL\Custom.xaml") Catch ex As Exception Log(ex, "生成教学文件失败", LogLevel.Feedback) @@ -418,7 +418,7 @@ Refresh: End Sub Private Sub BtnCustomRefresh_Click() Handles BtnCustomRefresh.Click FrmLaunchRight.ForceRefresh() - Hint("已刷新主页！", HintType.Finish) + Hint("已刷新主页！", HintType.Green) End Sub Private Sub BtnCustomTutorial_Click(sender As Object, e As EventArgs) Handles BtnCustomTutorial.Click MyMsgBox("1. 点击 生成教学文件 按钮，这会在 PCL 文件夹下生成 Custom.xaml 布局文件。" & vbCrLf & @@ -523,7 +523,7 @@ Refresh: '顶部栏未被全部隐藏 FrmMain.PanTitleSelect.Visibility = Visibility.Visible FrmMain.BtnTitleSelect1.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenPageDownload"), Visibility.Collapsed, Visibility.Visible) - FrmMain.BtnTitleSelect2.Visibility = Visibility.Collapsed 'If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenPageLink"), Visibility.Collapsed, Visibility.Visible) + FrmMain.BtnTitleSelect2.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenPageLink"), Visibility.Collapsed, Visibility.Visible) FrmMain.BtnTitleSelect3.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenPageSetup"), Visibility.Collapsed, Visibility.Visible) FrmMain.BtnTitleSelect4.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenPageOther"), Visibility.Collapsed, Visibility.Visible) End If @@ -536,7 +536,7 @@ Refresh: If FrmSetupLeft IsNot Nothing Then FrmSetupLeft.ItemLaunch.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenSetupLaunch"), Visibility.Collapsed, Visibility.Visible) FrmSetupLeft.ItemUI.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenSetupUi"), Visibility.Collapsed, Visibility.Visible) - FrmSetupLeft.ItemLink.Visibility = Visibility.Collapsed 'If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenSetupLink"), Visibility.Collapsed, Visibility.Visible) + FrmSetupLeft.ItemLink.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenSetupLink"), Visibility.Collapsed, Visibility.Visible) FrmSetupLeft.ItemSystem.Visibility = If(Not HiddenForceShow AndAlso Setup.Get("UiHiddenSetupSystem"), Visibility.Collapsed, Visibility.Visible) '隐藏左边选择卡 Dim AvaliableCount As Integer = 0 diff --git a/Plain Craft Launcher 2/Pages/PageSpeedLeft.xaml.vb b/Plain Craft Launcher 2/Pages/PageSpeedLeft.xaml.vb index 0bcad59..d7df960 100644 --- a/Plain Craft Launcher 2/Pages/PageSpeedLeft.xaml.vb +++ b/Plain Craft Launcher 2/Pages/PageSpeedLeft.xaml.vb @@ -1,6 +1,4 @@ -Imports System.Threading.Tasks - -Public Class PageSpeedLeft +Public Class PageSpeedLeft Private Const WatcherInterval As Integer = 300 '初始化 @@ -92,11 +90,11 @@ Public Class PageSpeedLeft Card.Children.Clear() Card.Children.Add(GetObjectFromXML("")) Dim Tb As TextBlock = GetObjectFromXML("") - Tb.Text = GetExceptionDetail(Loader.Error) + Tb.Text = Loader.Error.GetDetail() AddHandler Tb.MouseLeftButtonDown, Sub(sender As TextBlock, e As EventArgs) ClipboardSet(sender.Text, False) - Hint("已复制错误详情！", HintType.Finish) + Hint("已复制错误详情！", HintType.Green) End Sub Card.Children.Add(Tb) #End Region diff --git a/Plain Craft Launcher 2/Pages/PageSpeedRight.xaml b/Plain Craft Launcher 2/Pages/PageSpeedRight.xaml index 9efbd9f..6253c46 100644 --- a/Plain Craft Launcher 2/Pages/PageSpeedRight.xaml +++ b/Plain Craft Launcher 2/Pages/PageSpeedRight.xaml @@ -3,7 +3,7 @@ xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:local="clr-namespace:PCL" xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="d" x:Class="PageSpeedRight" - PanScroll="{Binding ElementName=PanBack}"> + PanScroll="PanBack">