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

2.10.9

Browse Source
This commit is contained in:
龙腾猫跃
2025-10-07 04:57:14 +08:00
parent 86ed0e9ae0
commit a41579b1da
71 changed files with 1151 additions and 1340 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Base/ModBase.vb
+37 -17
View File
@@ -13,13 +13,13 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.10.8" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.8." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.10.9" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.9." & 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 = 369 'Release
#Else
Public Const VersionCode As Integer = 370 'Snapshot
Public Const VersionCode As Integer = 371 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -69,7 +69,7 @@ Public Module ModBase
''' <summary>
''' 识别码。
''' </summary>
Public UniqueAddress As String = SecretGetUniqueAddress()
Public Identify As String = SecretGetIdentify()
''' <summary>
''' 程序是否已结束。
''' </summary>
@@ -761,7 +761,6 @@ 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
''' <summary>
@@ -1400,12 +1399,13 @@ RetryDir:
''' <summary>
''' 若路径长度大于指定值，则将长路径转换为短路径。
''' 如果路径不存在，则返回原始路径。
''' </summary>
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)
GetShortPathName(LongPath.Replace("/", "\"), ShortPath, 260) '第一个参数也会在调用后被修改，使用 Replace 后不会影响原始字符串
ShortenPath = ShortPath.ToString
If String.IsNullOrEmpty(ShortenPath) Then Return LongPath
End Function
@@ -1511,6 +1511,19 @@ RetryDir:
Return [Enum].GetName(EnumData.GetType, EnumData)
End Function
''' <summary>
''' 将字符串转换为枚举类型，支持数字或原文两种格式，若为空字符串则返回 0。
''' 若转换失败会抛出异常。
''' </summary>
<Extension> 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
''' <summary>
''' 将文件大小转化为适合的文本形式，如“1.28 M”。
''' </summary>
''' <param name="FileSize">以字节为单位的大小表示。</param>
@@ -2579,7 +2592,7 @@ 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
@@ -2716,6 +2729,11 @@ Retry:
''' 将 XML 转换为对应 UI 对象。
''' </summary>
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)
@@ -2831,7 +2849,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
@@ -2884,6 +2902,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)
@@ -2903,16 +2922,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
@@ -2955,6 +2974,7 @@ Retry:
'输出日志
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)
@@ -2973,19 +2993,19 @@ Retry:
#If DEBUG Then
Case LogLevel.Developer
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
Hint("[开发者模式] " & ExLine, HintType.Info, False)
Hint("[开发者模式] " & ExLine, HintType.Blue, False)
Case LogLevel.Debug
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
Hint("[调试模式] " & ExLine, HintType.Info, False)
Hint("[调试模式] " & ExLine, HintType.Blue, False)
#Else
Case LogLevel.Developer
Case LogLevel.Debug
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False)
If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Blue, False)
#End If
Case LogLevel.Hint
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
Hint(ExLine, HintType.Critical, False)
Hint(ExLine, HintType.Red, False)
Case LogLevel.Msgbox
MyMsgBox(ExFull, Title, IsWarn:=True)
Case LogLevel.Feedback
Plain Craft Launcher 2/Modules/Base/ModNet.vb
+21 -19
View File
@@ -998,20 +998,18 @@ StartThread:
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 ContentLength < 0 Then
If FileSize > 1 Then
If Th.DownloadStart = 0 Then
Log($"[Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理")
Else
Log($"[Download] {LocalName}：ContentLength 返回了 -1，无法确定是否支持分段下载，视作不支持")
Log($"[Download] {LocalName}：ContentLength 返回了 {ContentLength}，无法确定是否支持分段下载，视作不支持")
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
@@ -1040,15 +1038,11 @@ StartThread:
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
If SourcesOnce.Contains(Th.Source) Then GoTo SourceBreak
End SyncLock
Throw New WebException($"该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize}")
Throw New RangeNotSupportedException($"该下载源不支持分段下载：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}")
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
@@ -1061,6 +1055,7 @@ NotSupportRange:
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
@@ -1165,9 +1160,10 @@ 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
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
'当一个下载源有多个线程在下载时，只选择其中一个线程进行后续处理
@@ -1180,9 +1176,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
@@ -1191,9 +1187,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 Hint($"{LocalName}：文件下载失败，正在自动重试……", If(ModeDebug, HintType.Red, HintType.Blue)) '在调试模式下给出红色提示
Retried = True
SyncLock LockSource
SourcesOnce.Clear()
@@ -1388,6 +1385,12 @@ Retry:
End Sub
End Class
Private Class RangeNotSupportedException
Inherits WebException
Public Sub New(Message As String)
MyBase.New(Message)
End Sub
End Class
''' <summary>
''' 下载一系列文件的加载器。
''' </summary>
@@ -1890,7 +1893,6 @@ Retry:
Catch ex As Exception
Log(ex, "清理下载缓存失败")
End Try
Directory.CreateDirectory(PathTemp & "Download")
End If
IsDownloadCacheCleared = True
End SyncLock
Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb
+2 -3
View File
@@ -908,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
@@ -917,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
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+32 -66
View File
@@ -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
@@ -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("$$")
@@ -755,10 +755,10 @@ LoginFinish:
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
@@ -1304,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
@@ -1395,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
@@ -1412,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
@@ -1427,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
'输出
@@ -1447,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() & """")
@@ -1571,7 +1574,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 +1595,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 +1700,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 +1710,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
@@ -1827,10 +1830,14 @@ NextVersion:
''' </summary>
Private Function GetNativesFolder() As String
Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives"
If IsGBKEncoding OrElse Result.IsASCII() Then Return ShortenPath(Result)
Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives"
If Result.IsASCII() Then Return ShortenPath(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
@@ -1981,7 +1988,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 +2132,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
@@ -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
''' <summary>
''' 在启动结束时，对 PCL 约定的替换标记进行处理。
''' </summary>
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
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+48 -14
View File
@@ -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)
@@ -261,6 +261,12 @@ Public Module ModMinecraft
''' 显示的描述文本。
''' </summary>
Public Info As String = "该版本未被加载，请向作者反馈此问题"
Public ReadOnly Property HasCustomInfo As Boolean
Get
Return ReadIni(Path & "PCL\Setup.ini", "CustomInfo") <> ""
End Get
End Property
''' <summary>
''' 该版本的列表检查原始结果，不受自定义影响。
''' </summary>
@@ -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)
'确定版本显示种类
@@ -817,11 +833,13 @@ ExitDataLoad:
End Try
Return Me
End Function
Public IsLoaded As Boolean = False
''' <summary>
''' 获取版本的默认描述。
''' 获取对该版本的简短描述。
''' 例如 “快照 16w01a”、“原版 1.12.2”、“愚人节版本 2.0”。
''' </summary>
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]
@@ -1567,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
Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb
+12 -12
View File
@@ -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
@@ -344,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
@@ -485,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
@@ -540,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
'启动
@@ -639,8 +639,8 @@ 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")
If Not Component.Contains("uid") Then Continue For
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 项")
@@ -667,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
@@ -725,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 {
@@ -746,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
@@ -766,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)("解压压缩包",
@@ -843,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)("解压压缩包",
Plain Craft Launcher 2/Modules/Minecraft/ModWatcher.vb
+1 -1
View File
@@ -349,7 +349,7 @@
State = MinecraftState.Crashed
'崩溃分析
WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析")
Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Critical)
Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Red)
FeedbackInfo()
RunInNewThread(
Sub()
Plain Craft Launcher 2/Modules/ModEvent.vb
+295 -207
View File
@@ -1,181 +1,291 @@
Imports System.Collections.ObjectModel

#Region "附加属性"
''' <summary>
''' 用于在 XAML 中初始化列表对象。
''' 附加属性无法在 XAML 中为每个对象初始化独立的列表对象，因此需要一个包装类，然后在 XAML 中显式初始化。
''' </summary>
<Markup.ContentProperty("Events")>
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
''' <summary>
''' 提供自定义事件的附加属性。
''' </summary>
Public Class CustomEventService
'Events
Public Shared ReadOnly EventsProperty As DependencyProperty =
DependencyProperty.RegisterAttached("Events", GetType(CustomEventCollection), GetType(CustomEventService), New PropertyMetadata(Nothing))
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
Public Shared Sub SetEvents(d As DependencyObject, value As CustomEventCollection)
d.SetValue(EventsProperty, value)
End Sub
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
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))
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
Public Shared Sub SetEventType(d As DependencyObject, value As CustomEvent.EventType)
d.SetValue(EventTypeProperty, value)
End Sub
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
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))
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
Public Shared Sub SetEventData(d As DependencyObject, value As String)
d.SetValue(EventDataProperty, value)
End Sub
<AttachedPropertyBrowsableForType(GetType(DependencyObject))>
Public Shared Function GetEventData(d As DependencyObject) As String
Return d.GetValue(EventDataProperty)
End Function
End Class
Partial Public Module ModMain
Public Module ModEvent
#Region "事件执行方法"
''' <summary>
''' 供外部调用的自定义事件执行接口，会在新建工作线程中运行逻辑。
''' 触发该控件上的自定义事件。
''' 事件会在新线程中执行。
''' </summary>
''' <param name="SingleEventType">xaml中的EventType</param>
''' <param name="SingleEventData">xaml中的EventData</param>
''' <param name="EventCollection">xaml中的CustomEvents</param>
Public Sub ProcessCustomEvents(SingleEventType As String, SingleEventData As String, EventCollection As CustomEventCollection)
<Runtime.CompilerServices.Extension>
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()
Try
'先执行单个事件
StartCustomEvent(SingleEventType, SingleEventData)
'再挨个执行事件集合中的事件
If EventCollection IsNot Nothing Then
For Each AnEvent In RunInUiWait(Function() EventCollection.DeepCloneToStructureList())
StartCustomEvent(AnEvent.EventType, AnEvent.EventData)
Next
End If
Catch ex As Exception
Log(ex, "自定义事件执行器发生异常", LogLevel.Feedback)
End Try
End Sub, "CustomEventProcessor " & GetUuid())
End Sub
''' <summary>
''' 对当前线程阻塞地调用自定义事件处理器，接受来自 xaml 原始输入作为参数。
''' </summary>
Private Sub StartCustomEvent(Type As String, DataRaw As String)
If String.IsNullOrEmpty(Type) Then Exit Sub
Dim Data = If(DataRaw Is Nothing, {""}, DataRaw.Split("|"))
Log("[Control] 执行自定义事件：" & Type & ", " & Join(Data, ", "))
'检测是否存在对应事件
If Not CustomEventProcessorsDict.ContainsKey(Type) Then
MyMsgBox($"未知的事件类型：'{Type}'{vbCrLf}请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败", ForceWait:=True)
Exit Sub
End If
'调用事件处理器
Try
CustomEventProcessorsDict(Type)(Data)
Catch ex As Exception
Log(ex, $"自定义事件执行失败：{Type}", LogLevel.Msgbox, "自定义主页事件执行失败")
End Try
Sub()
For Each e In Events
e.Raise()
Next
End Sub, "执行自定义事件 " & GetUuid())
End Sub
''' <summary>
''' 存储各个自定义事件处理器的字典，以 EventType 为键，执行自定义事件时在工作线程中调用 Action 并传入分割后的 EventData 。
''' Action 应当在事件逻辑结束后，即可以开始下一个事件时再结束；以便于挨个调用事件不打架。
''' </summary>
Private ReadOnly CustomEventProcessorsDict As New Dictionary(Of String, Action(Of String())) From {
{"打开网页",
Sub(Data As String())
Data(0) = Data(0).Replace("\", "/")
If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议（#2200）
MyMsgBox("打开网页事件中，EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败")
Exit Sub
End If
Hint("网页正在开启中，请稍候……")
OpenWebsite(Data(0))
End Sub},
{"打开文件",
Sub(Data As String())
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), "打开文件")
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
Log($"[Control] 打开文件：路径：{Location}，工作目录：{WorkingDir}")
If Not CommandRunUserConfirm(If(Data.Length < 2, Location, $"{Location} {Data(1)}")) Then Exit Sub
Dim Info As New ProcessStartInfo With {
.Arguments = If(Data.Length < 2, "", Data(1)),
.FileName = Location,
.WorkingDirectory = ShortenPath(WorkingDir)
}
Process.Start(Info)
End Sub},
{"打开帮助",
Sub(Data As String())
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), "打开帮助")
Dim Location = ActualPaths(0)
Log($"[Control] 打开帮助：{Location}")
PageOtherHelp.EnterHelpPage(Location)
End Sub},
{"执行命令",
Sub(Data As String())
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), "执行命令")
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
Log($"[Control] 执行命令：路径：{Location}，工作目录：{WorkingDir}")
If Not CommandRunUserConfirm(If(Data.Length < 2, Location, $"{Location} {Data(1)}")) Then Exit Sub
Dim Info As New ProcessStartInfo With {
.Arguments = If(Data.Length < 2, "", Data(1)),
.FileName = Location,
.WorkingDirectory = ShortenPath(WorkingDir)
}
Process.Start(Info)
End Sub},
{"启动游戏",
Sub(Data As String())
If Data(0) = "\current" Then
If McVersionCurrent Is Nothing Then
Hint("请先选择一个 Minecraft 版本！", HintType.Critical)
Exit Sub
Else
Data(0) = McVersionCurrent.Name
End If
End If
RunInUiWait(
Sub()
If McLaunchStart(New McLaunchOptions With {.Version = New McVersion(Data(0)), .ServerIp = If(Data.Length >= 2, Data(1), Nothing)}) Then
Hint("正在启动 " & Data(0) & "……")
End If
End Sub)
End Sub},
{"复制文本", Sub(Data As String()) ClipboardSet(Join(Data, "|"))},
{"刷新主页",
Sub(Data As String())
RunInUiWait(Sub() FrmLaunchRight.ForceRefresh())
If Data(0) = "" Then Hint("已刷新主页！", HintType.Finish)
End Sub},
{"刷新帮助", Sub() RunInUi(Sub() PageOtherLeft.RefreshHelp())},
{"今日人品", Sub() PageOtherTest.Jrrp()},
{"内存优化",
Sub(Data As String())
If Data.Length >= 1 AndAlso Data(0) = "前台运行" Then
PageOtherTest.MemoryOptimize(Data.Length >= 2 AndAlso Data(1) = "显示提示")
Else
RunInNewThread(Sub() PageOtherTest.MemoryOptimize(True))
End If
End Sub},
{"弹出窗口", Sub(Data As String()) MyMsgBox(Data(1).Replace("\n", vbCrLf), Data(0).Replace("\n", vbCrLf), ForceWait:=True)},
{"切换页面", Sub(Data As String()) RunInUiWait(Sub() FrmMain.PageChange(Val(Data(0)), Val(Data(1))))},
{"安装整合包", Sub() RunInUiWait(Sub() ModpackInstall())},
{"导入整合包", Sub() RunInUiWait(Sub() ModpackInstall())},
{"下载文件",
Sub(Data As String())
Data(0) = Data(0).Replace("\", "/")
If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败")
Exit Sub
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
End Sub}
}
End Module
#End Region
#Region "工具方法"
''' <summary>
''' 自定义事件。
''' </summary>
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
''' <summary>
''' 弹窗询问用户是否同意继续执行打开类事件。
''' 在当前线程中触发该自定义事件。
''' </summary>
Private Function CommandRunUserConfirm(TextShowToUser As String) As Boolean
If Setup.Get("HintCustomCommand") Then Return True
Select Case MyMsgBox("即将执行：" & TextShowToUser & vbCrLf & "请在确认该操作没有安全隐患后继续。", "执行确认", "继续", "继续且今后不再要求确认", "取消")
Case 1
Return True
Case 2
Setup.Set("HintCustomCommand", True)
Return True
Case Else '3
Log("[Control] 用户取消了打开类事件")
Return False
End Select
End Function
Public Sub Raise()
Raise(Type, Data)
End Sub
#End Region
Public Enum EventType
None = 0
打开网页
打开文件
打开帮助
执行命令
启动游戏
复制文本
刷新主页
刷新页面
刷新帮助
今日人品
内存优化
清理垃圾
弹出窗口
弹出提示
切换页面
导入整合包
安装整合包
下载文件
修改设置
写入设置
修改变量
写入变量
End Enum
''' <summary>
''' 在当前线程中触发一个自定义事件。
''' </summary>
Public Shared Sub Raise(Type As EventType, Arg As String)
If Type = EventType.None Then Return
Log($"[Control] 执行自定义事件：{Type}, {Arg}")
Try
Dim Args As String() = If(Arg?.Split("|"), {""})
Select Case Type
Case EventType.打开网页
Arg = Arg.Replace("\", "/")
If Not Arg.Contains("://") OrElse Arg.StartsWithF("file", True) Then '为了支持更多协议（#2200）
MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败")
Return
End If
Hint("正在开启中，请稍候：" & Arg)
RunInThread(Sub() OpenWebsite(Arg))
Case EventType.打开文件, EventType.打开帮助, EventType.执行命令
RunInThread(
Sub()
Try
'确认实际路径
Dim ActualPaths = GetAbsoluteUrls(Args(0), Type)
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
Log($"[Control] 打开类自定义事件实际路径：{Location}，工作目录：{WorkingDir}")
'执行
If Type = EventType.打开帮助 Then
PageOtherHelp.EnterHelpPage(Location)
Else
If Not EventSafetyConfirm("即将执行：" & Location & If(Args.Length >= 2, " " & Args(1), "")) Then Return
Dim Info As New ProcessStartInfo With {
.Arguments = If(Args.Length >= 2, Args(1), ""),
.FileName = Location,
.WorkingDirectory = WorkingDir
}
StartProcess(Info)
End If
Catch ex As Exception
Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox)
End Try
End Sub)
Case EventType.启动游戏
If Args(0) = "\current" Then
If McVersionCurrent Is Nothing Then
Hint("请先选择一个 Minecraft 版本！", HintType.Red)
Return
Else
Args(0) = McVersionCurrent.Name
End If
End If
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.刷新主页, 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 EventType.刷新帮助
RunInUiWait(Sub() PageOtherLeft.RefreshHelp())
If String.IsNullOrEmpty(Arg) Then Hint("已刷新！", HintType.Green)
Case EventType.今日人品
PageOtherTest.Jrrp()
Case EventType.内存优化
RunInThread(Sub() PageOtherTest.MemoryOptimize(True))
Case EventType.清理垃圾
RunInThread(Sub() PageOtherTest.RubbishClear())
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 EventType.弹出提示
Hint(Args(0).Replace("\n", vbCrLf), If(Args.Length = 1, HintType.Blue, Args(1).ParseToEnum(Of HintType)))
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 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
If Not EventSafetyConfirm("即将从该网址下载文件：" & vbCrLf & Args(0)) Then Return
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
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 Else
MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL 是否为最新版本。", "事件执行失败")
End Select
Catch ex As Exception
Log(ex, $"事件执行失败（{Type}, {Arg}）", LogLevel.Msgbox)
End Try
End Sub
''' <summary>
''' 返回自定义事件的绝对 Url。实际返回 {绝对 Url, WorkingDir}。
''' 失败会抛出异常。
''' </summary>
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
@@ -216,25 +326,25 @@ Public Module ModEvent
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)
@@ -243,42 +353,20 @@ Public Module ModEvent
Return {Location, WorkingDir}
End Function
#End Region
End Module
#Region "数据结构类声明"
Public Class CustomEventCollection
Inherits ObservableCollection(Of CustomEvent)
Public Function DeepCloneToStructureList() As IList(Of CustomEventStructure)
DeepCloneToStructureList = New List(Of CustomEventStructure)
For Each AnEvent In Me
DeepCloneToStructureList.Add(New CustomEventStructure With {.EventType = AnEvent.EventType, .EventData = AnEvent.EventData})
Next
''' <summary>
''' 弹出安全确认弹窗。返回是否继续执行。
''' </summary>
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
Public Class CustomEvent
Inherits DependencyObject
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(CustomEvent), 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(CustomEvent), New PropertyMetadata(Nothing))
End Class
Public Structure CustomEventStructure
Public EventType As String
Public EventData As String
End Structure
#End Region
End Class
Plain Craft Launcher 2/Modules/ModMain.vb
+86 -35
View File
@@ -7,23 +7,12 @@ Public Module ModMain
''' <summary>
''' 提示信息的种类。
''' 该枚举在自定义事件中使用，是公开 API 的一部分。
''' </summary>
Public Enum HintType
''' <summary>
''' 信息，通常是蓝色的“i”。
''' </summary>
''' <remarks></remarks>
Info
''' <summary>
''' 已完成，通常是绿色的“√”。
''' </summary>
''' <remarks></remarks>
Finish
''' <summary>
''' 错误，通常是红色的“×”。
''' </summary>
''' <remarks></remarks>
Critical
Blue
Green
Red
End Enum
Private Structure HintMessage
Public Text As String
@@ -38,7 +27,7 @@ Public Module ModMain
''' <summary>
''' 在窗口左下角弹出提示文本。
''' </summary>
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
@@ -490,7 +479,7 @@ EndHint:
''' 是否为 “执行事件”。
''' </summary>
Public IsEvent As Boolean
Public EventType As String
Public EventType As CustomEvent.EventType
Public EventData As String
''' <summary>
''' 若非执行事件，其对应的 .xaml 本地文件内容。
@@ -504,7 +493,7 @@ EndHint:
''' </summary>
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
@@ -524,8 +513,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
@@ -550,7 +538,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"
@@ -567,9 +555,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
@@ -669,15 +657,6 @@ NextFile:
Log("[Help] 已解压内置帮助文件，目前状态：" & File.Exists(PathTemp & "Help\启动器\备份设置.xaml"), LogLevel.Debug)
End If
End Sub
''' <summary>
''' 对帮助文件约定的替换标记进行处理，如果遇到需要转义的字符会进行转义。
''' </summary>
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
@@ -836,6 +815,78 @@ NextFile:
End Using
End Sub
''' <summary>
''' 对替换标记进行处理。会对替换内容使用 EscapeHandler 进行转义。
''' </summary>
Public Function ArgumentReplace(Text As String, Optional EscapeHandler As Func(Of String, String) = Nothing, Optional ReplaceTime As Boolean = True) As String
'预处理
If Text Is Nothing 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, Nothing)))
Return Text
End Function
#End Region
#Region "任务缓存"
Plain Craft Launcher 2/Modules/ModMusic.vb
+12 -12
View File
@@ -111,7 +111,7 @@
''' </summary>
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
Plain Craft Launcher 2/Modules/ModSecret.vb
+4 -2
View File
@@ -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
''' <summary>
''' 获取设备标识码。
''' </summary>
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")