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

2.8.4

Browse Source
This commit is contained in:
龙腾猫跃
2024-08-17 01:46:19 +08:00
parent c62ab46b99
commit 62394e0052
37 changed files with 2654 additions and 1565 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Plain Craft Launcher 2/Modules/Base/ModBase.vb
+8 -14
View File
@@ -11,12 +11,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.8.3" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.3." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.8.4" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.8.4." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 332 'Release
#Else
Public Const VersionCode As Integer = 331 'Snapshot
Public Const VersionCode As Integer = 333 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -80,10 +80,6 @@ Public Module ModBase
''' </summary>
Public IsGBKEncoding As Boolean = Encoding.Default.CodePage = 936
''' <summary>
''' 操作系统版本。Win10 为 10.0。
''' </summary>
Public OsVersion As Version = Environment.OSVersion.Version
''' <summary>
''' 系统盘盘符，以 \ 结尾。例如 “C:\”。
''' </summary>
Public OsDrive As String = Environment.GetLogicalDrives().Where(Function(p) Directory.Exists(p)).First.ToUpper.First & ":\" '#3799
@@ -1108,8 +1104,6 @@ Re:
Dim Retry As Boolean = False
Re:
Try
''检测该文件是否在下载中，若在下载则放弃检测
'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return ""
'获取 SHA1
Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
Dim sha1 As SHA1 = New SHA1CryptoServiceProvider()
@@ -1587,14 +1581,14 @@ RetryDir:
''' 获取处于两个子字符串之间的部分。
''' 会裁切尽可能多的内容：匹配开始使用 LastIndexOf，匹配结束使用 IndexOf，但如果未找到子字符串则不裁切。
''' </summary>
<Extension> Public Function Between(Str As String, Before As String, After As String, Optional IgnoreCase As Boolean = False) As String
Dim StartPos As Integer = If(String.IsNullOrEmpty(Before), -1, Str.LastIndexOfF(Before, IgnoreCase))
<Extension> Public Function Between(Str As String, After As String, Before As String, Optional IgnoreCase As Boolean = False) As String
Dim StartPos As Integer = If(String.IsNullOrEmpty(After), -1, Str.LastIndexOfF(After, IgnoreCase))
If StartPos >= 0 Then
StartPos += Before.Length
StartPos += After.Length
Else
StartPos = 0
End If
Dim EndPos As Integer = If(String.IsNullOrEmpty(After), -1, Str.IndexOfF(After, StartPos, IgnoreCase))
Dim EndPos As Integer = If(String.IsNullOrEmpty(Before), -1, Str.IndexOfF(Before, StartPos, IgnoreCase))
If EndPos >= 0 Then
Return Str.Substring(StartPos, EndPos - StartPos)
ElseIf StartPos > 0 Then
@@ -2682,7 +2676,7 @@ Retry:
Public Sub FeedbackInfo()
On Error Resume Next
Log("[System] 诊断信息：" & vbCrLf &
"操作系统：" & My.Computer.Info.OSFullName & vbCrLf &
"操作系统：" & My.Computer.Info.OSFullName & "（32 位：" & Is32BitSystem & "）" & vbCrLf &
"剩余内存：" & Int(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024) & " M / " & Int(My.Computer.Info.TotalPhysicalMemory / 1024 / 1024) & " M" & vbCrLf &
"DPI：" & DPI & "（" & Math.Round(DPI / 96, 2) * 100 & "%）" & vbCrLf &
"MC 文件夹：" & If(PathMcFolder, "Nothing") & vbCrLf &
Plain Craft Launcher 2/Modules/Base/ModLoader.vb
+18 -30
View File
@@ -566,38 +566,33 @@ Restart:
End Class
'任务栏进度条
Public LoaderTaskbarLock As New Object
Public LoaderTaskbar As New List(Of LoaderBase)
Public LoaderTaskbar As New Concurrent.ConcurrentBag(Of LoaderBase)
Public LoaderTaskbarProgress As Double = 0 '平滑后的进度
Private LoaderTaskbarProgressLast As Shell.TaskbarItemProgressState = Shell.TaskbarItemProgressState.None
Public Sub LoaderTaskbarAdd(Of T)(Loader As LoaderCombo(Of T))
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRemove(Loader)
SyncLock LoaderTaskbarLock
LoaderTaskbar.Add(Loader)
Log($"[Taskbar] {Loader.Name} 已加入任务列表")
End SyncLock
LoaderTaskbar.Add(Loader)
Log($"[Taskbar] {Loader.Name} 已加入任务列表")
End Sub
Public Sub LoaderTaskbarProgressRefresh()
Try
Dim NewState As Shell.TaskbarItemProgressState
Dim NewProgress As Double = LoaderTaskbarProgressGet()
'检查任务是否完成，若完成则移除
SyncLock LoaderTaskbarLock
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成，则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
Next
End SyncLock
'外显任务是否已经全部完成
Dim IsAllDownloadTaskCompleted As Boolean = True
For Each Loader In LoaderTaskbar
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
Next
'若单个任务已中止或全部任务已完成，则刷新并移除
For Each Task In LoaderTaskbar.ToList()
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
LoaderTaskbar.TryTake(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If
Next
'更新平滑后的进度
If NewProgress <= 0 OrElse NewProgress >= 1 OrElse LoaderTaskbarProgress > NewProgress Then
LoaderTaskbarProgress = NewProgress
@@ -625,15 +620,8 @@ Restart:
End Sub
Public Function LoaderTaskbarProgressGet() As Double
Try
Dim Total As Double = 0, Count As Integer = 0
SyncLock LoaderTaskbarLock
For Each Task In LoaderTaskbar.ToList
Total += Task.Progress
Count += 1 '避免多线程影响导致计数出错
Next
End SyncLock
If Count = 0 Then Return 1
Return MathClamp(Total / Count, 0, 1)
If Not LoaderTaskbar.Any Then Return 1
Return MathClamp(LoaderTaskbar.Select(Function(e) e.Progress).Average(), 0, 1)
Catch ex As Exception
Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
Return 0.5
Plain Craft Launcher 2/Modules/Base/ModNet.vb
+36 -53
View File
@@ -1,8 +1,6 @@
Imports System.Net
Public Module ModNet
Public Const NetDownloadEnd As String = ".PCLDownloading"
''' <summary>
@@ -208,10 +206,10 @@ RequestFinished:
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
If ex.GetType.Equals(GetType(WebException)) AndAlso CType(ex, WebException).Status = WebExceptionStatus.Timeout Then
Throw New TimeoutException("连接服务器超时，已接收 " & Result.Count & " B（" & Url & "）")
If TypeOf ex Is WebException AndAlso CType(ex, WebException).Status = WebExceptionStatus.Timeout Then
Throw New TimeoutException($"获取结果失败（{CType(ex, WebException).Status}，{ex.Message}，{Url}）", ex)
Else
Throw New WebException("获取结果失败，" & ex.Message & "（" & Url & "）", ex)
Throw New WebException($"获取结果失败（{If(TypeOf ex Is WebException, CType(ex, WebException).Status & "，", "")}{ex.Message}，{Url}）", ex)
End If
Finally
Request.Abort()
@@ -420,7 +418,7 @@ RequestFinished:
Throw
Catch ex As WebException
If ex.Status = WebExceptionStatus.Timeout Then
Throw New WebException("连接服务器超时，请检查你的网络环境是否良好（" & Url & "）", ex)
ex = New WebException($"连接服务器超时，请检查你的网络环境是否良好（{ex.Message}，{Url}）", ex)
Else
'获取请求失败的返回
Dim Res As String = ""
@@ -434,10 +432,14 @@ RequestFinished:
End Using
Catch
End Try
Throw New WebException("网络请求失败（" & Url & "，" & ex.Message & "）" & If(String.IsNullOrEmpty(Res), "", vbCrLf & Res), ex)
ex = New WebException($"网络请求失败（{ex.Status}，{ex.Message}，{Url}）{If(String.IsNullOrEmpty(Res), "", vbCrLf & Res)}", ex)
End If
If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer)
Throw ex
Catch ex As Exception
Throw New WebException("网络请求失败（" & Url & "）", ex)
ex = New WebException("网络请求失败（" & Url & "）", ex)
If MakeLog Then Log(ex, "NetRequestOnce 失败", LogLevel.Developer)
Throw ex
Finally
If DataStream IsNot Nothing Then DataStream.Dispose()
If Resp IsNot Nothing Then Resp.Dispose()
@@ -689,7 +691,7 @@ RequestFinished:
''' <summary>
''' 所属的文件列表任务。
''' </summary>
Public Tasks As New List(Of LoaderDownload)
Public Tasks As New Concurrent.ConcurrentBag(Of LoaderDownload)
''' <summary>
''' 所有下载源。
@@ -882,7 +884,6 @@ RequestFinished:
Public ReadOnly LockState As New Object
Public ReadOnly LockChain As New Object
Public ReadOnly LockSource As New Object
Public ReadOnly LockTasks As New Object
Public ReadOnly Uuid As Integer = GetUuid()
Public Overrides Function Equals(obj As Object) As Boolean
@@ -965,7 +966,7 @@ Capture:
Next
'是否禁用多线程，以及规定碎片大小
Dim TargetUrl As String = GetSource().Url
If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("gitcode.net") OrElse TargetUrl.Contains("github.com") OrElse TargetUrl.Contains("modrinth.com") Then Return Nothing
If TargetUrl.Contains("pcl2-server") OrElse TargetUrl.Contains("gitcode.net") OrElse TargetUrl.Contains("github.com") OrElse TargetUrl.Contains("modrinth") Then Return Nothing
'寻找最大碎片
'FUTURE: 下载引擎重做，计算下载源平均链接时间和线程下载速度，按最高时间节省来开启多线程
Dim FilePieceMax As NetThread = Threads
@@ -981,10 +982,8 @@ StartThread:
If (StartPosition > FileSize AndAlso FileSize >= 0 AndAlso Not IsUnknownSize) OrElse StartPosition < 0 OrElse IsNothing(StartSource) Then Return Nothing
'构建线程
Dim ThreadUuid As Integer = GetUuid()
SyncLock LockTasks
If Not Tasks.Any() Then Return Nothing '由于中断，已没有可用任务
Th = New Thread(AddressOf Thread) With {.Name = $"NetTask {Tasks(0).Uuid}/{Uuid} Download {ThreadUuid}#", .Priority = ThreadPriority.BelowNormal}
End SyncLock
If Not Tasks.Any() Then Return Nothing '由于中断，已没有可用任务
Th = New Thread(AddressOf Thread) With {.Name = $"NetTask {Tasks(0).Uuid}/{Uuid} Download {ThreadUuid}#", .Priority = ThreadPriority.BelowNormal}
ThreadInfo = New NetThread With {.Uuid = ThreadUuid, .DownloadStart = StartPosition, .Thread = Th, .Source = StartSource, .Task = Me, .State = NetState.WaitForDownload}
'链表处理
If ThreadInfo.IsFirstThread OrElse Threads Is Nothing Then
@@ -1141,11 +1140,9 @@ NotSupportRange:
End If
SyncLock LockCount
Info.Source.FailCount = 0
SyncLock LockTasks
For Each Task In Tasks
Task.FailCount = 0
Next
End SyncLock
For Each Task In Tasks
Task.FailCount = 0
Next
End SyncLock
NetManager.DownloadDone += RealDataCount
SyncLock LockDone
@@ -1199,11 +1196,9 @@ SourceBreak:
'状态变更
SyncLock LockCount
Info.Source.FailCount += 1
SyncLock LockTasks
For Each Task In Tasks
Task.FailCount += 1
Next
End SyncLock
For Each Task In Tasks
Task.FailCount += 1
Next
End SyncLock
Dim IsTimeoutString As String = GetExceptionSummary(ex).ToLower.Replace(" ", "")
Dim IsTimeout As Boolean = IsTimeoutString.Contains("由于连接方在一段时间后没有正确答复或连接的主机没有反应") OrElse
@@ -1308,7 +1303,7 @@ Retry:
'合并文件
If IsNoSplit Then
'仅有一个线程，从缓存中输出
If ModeDebug Then Log($"[Download] {LocalName}：下载结束，从缓存输出文件")
If ModeDebug Then Log($"[Download] {LocalName}：下载结束，从缓存输出文件，长度：" & SmailFileCache.Count)
MergeFile = New FileStream(LocalPath, FileMode.Create)
AddWriter = New BinaryWriter(MergeFile)
AddWriter.Write(SmailFileCache.ToArray)
@@ -1345,7 +1340,7 @@ Retry:
'检查文件
Dim CheckResult As String = Check?.Check(LocalPath)
If CheckResult IsNot Nothing Then
Log($"[Download] {LocalName} 合并文件失败，下载线程细节：")
Log($"[Download] {LocalName} 文件校验失败，下载线程细节：")
For Each Th As NetThread In Threads
Log($"[Download] {Th.Uuid}#，状态 {GetStringFromEnum(Th.State)}，范围 {Th.DownloadStart}~{Th.DownloadStart + Th.DownloadDone}，完成 {Th.DownloadDone}，剩余 {Th.DownloadUndone}")
Next
@@ -1398,10 +1393,8 @@ Retry:
''' </summary>
Public Sub Abort(CausedByTask As LoaderDownload)
'从特定任务中移除，如果它还属于其他任务，则继续下载
SyncLock LockTasks
Tasks.Remove(CausedByTask)
If Tasks.Any Then Exit Sub
End SyncLock
Tasks.TryTake(CausedByTask)
If Tasks.Any Then Exit Sub
'确认中断
SyncLock LockState
If State >= NetState.Finish Then Exit Sub
@@ -1431,11 +1424,9 @@ Retry:
NetManager.FileRemain -= 1
If PrintLog Then Log("[Download] " & LocalName & "：已完成，剩余文件 " & NetManager.FileRemain)
End SyncLock
SyncLock LockTasks
For Each Task In Tasks
Task.OnFileFinish(Me)
Next
End SyncLock
For Each Task In Tasks
Task.OnFileFinish(Me)
Next
End Sub
End Class
@@ -1962,9 +1953,7 @@ Retry:
If Files(File.LocalPath).State >= NetState.Finish Then
'该文件已经下载过一次，且下载完成
'将已下载的文件替换成当前文件，重新下载
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
Files(File.LocalPath) = File
SyncLock LockRemain
FileRemain += 1
@@ -1975,15 +1964,11 @@ Retry:
'该文件正在下载中
'将当前文件替换成下载中的文件，即两个任务指向同一个文件
File = Files(File.LocalPath)
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
End If
Else
'没有该文件
SyncLock File.LockTasks
File.Tasks.Add(Task)
End SyncLock
File.Tasks.Add(Task)
Files.Add(File.LocalPath, File)
SyncLock LockRemain
FileRemain += 1
@@ -2005,14 +1990,12 @@ Retry:
''' 是否有正在进行中、需要在下载管理页面显示的下载任务？
''' </summary>
Public Function HasDownloadingTask(Optional IgnoreCustomDownload As Boolean = False) As Boolean
SyncLock LoaderTaskbarLock
For Each Task In LoaderTaskbar
If (Task.Show AndAlso Task.State = LoadState.Loading) AndAlso
(Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载")) Then
Return True
End If
Next
End SyncLock
For Each Task In LoaderTaskbar
If (Task.Show AndAlso Task.State = LoadState.Loading) AndAlso
(Not IgnoreCustomDownload OrElse Not Task.Name.ToString.Contains("自定义下载")) Then
Return True
End If
Next
Return False
End Function
Plain Craft Launcher 2/Modules/Minecraft/ModComp.vb
+19 -43
View File
@@ -278,7 +278,8 @@
End If
'Tags
Tags = New List(Of String)
For Each Category In Data("categories").Select(Of Integer)(Function(t) t("id")).Distinct.OrderByDescending(Function(c) c)
For Each Category In If(Data("categories"), New JArray). '镜像源 API 可能丢失此字段：https://github.com/Hex-Dragon/PCL2/issues/4267#issuecomment-2254590831
Select(Of Integer)(Function(t) t("id")).Distinct.OrderByDescending(Function(c) c)
Select Case Category
'Mod
Case 406 : Tags.Add("世界元素")
@@ -387,7 +388,7 @@
Case "adventure" : Tags.Add("冒险")
Case "kitchen-sink" : Tags.Add("大杂烩")
Case "lightweight" : Tags.Add("轻量")
'FUTURE: Res
'FUTURE: Res
End Select
Next
If Not Tags.Any() Then Tags.Add("杂项")
@@ -962,7 +963,7 @@ Retry:
Log($"[Comp] 从 CurseForge 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.CurseForgeOffset} 个，共 {Storage.CurseForgeTotal} 个）")
Catch ex As Exception
Log(ex, "从 CurseForge 获取工程列表失败")
Storage.CurseForgeTotal = Storage.CurseForgeOffset
Storage.CurseForgeTotal = -1 'Storage.CurseForgeOffset
[Error] = ex
CurseForgeFailed = True
End Try
@@ -995,7 +996,7 @@ Retry:
Log($"[Comp] 从 Modrinth 获取到了 {ProjectList.Count} 个工程（已获取 {Storage.ModrinthOffset} 个，共 {Storage.ModrinthTotal} 个）")
Catch ex As Exception
Log(ex, "从 Modrinth 获取工程列表失败")
Storage.ModrinthTotal = Storage.ModrinthOffset
Storage.ModrinthTotal = -1 'Storage.ModrinthOffset
[Error] = ex
ModrinthFailed = True
End Try
@@ -1021,7 +1022,7 @@ Retry:
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWithF("/") Then
Throw New Exception("Modrinth 不兼容所选的类型")
Else
Throw New Exception("没有符合条件的结果")
Throw New Exception("没有搜索结果")
End If
End If
ElseIf [Error] IsNot Nothing Then
@@ -1190,10 +1191,6 @@ Retry:
''' </summary>
Public DownloadUrls As List(Of String)
''' <summary>
''' 文件所有可能的镜像源。
''' </summary>
Public MirrorUrls As List(Of String)
''' <summary>
''' 文件的 SHA1 或 MD5。
''' </summary>
Public ReadOnly Hash As String = Nothing
@@ -1211,9 +1208,7 @@ Retry:
''' </summary>
''' <param name="LocalAddress">目标本地文件夹，或完整的文件路径。会自动判断类型。</param>
Public Function ToNetFile(LocalAddress As String) As NetFile
Dim urls As List(Of String) = DownloadUrls
urls.AddRange(MirrorUrls)
Return New NetFile(urls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True)
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True)
End Function
'实例化
@@ -1259,7 +1254,9 @@ Retry:
DownloadUrls = (New List(Of String) From {Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"),
Url}).Distinct().ToList()
Url}).Distinct.ToList '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源，这个写法是为了让镜像源排在后面
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
'Dependencies
If Type = CompType.Mod Then
RawDependencies = Data("dependencies").
@@ -1293,11 +1290,10 @@ Retry:
ReleaseDate = Data("date_published")
Status = If(Data("version_type").ToString = "release", CompFileStatus.Release, If(Data("version_type").ToString = "beta", CompFileStatus.Beta, CompFileStatus.Alpha))
DownloadCount = Data("downloads")
'可能为空
If CType(Data("files"), JArray).Any() Then
If CType(Data("files"), JArray).Any() Then '可能为空
Dim File As JToken = Data("files")(0)
FileName = File("filename")
DownloadUrls = New List(Of String) From {File("url")}
DownloadUrls = New List(Of String) From {File("url"), DlSourceModGet(File("url"))}.Distinct.ToList '同时添加了镜像源
Hash = File("hashes")("sha1")
End If
'Dependencies
@@ -1331,11 +1327,6 @@ Retry:
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
#End Region
End If
'末尾添加备用镜像 URL
MirrorUrls = New List(Of String)
For Each u In DownloadUrls
MirrorUrls.Add(DlSourceModGet(u))
Next
End If
End Sub
''' <summary>
@@ -1437,24 +1428,10 @@ Retry:
Dim TargetProject As CompProject
If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存
TargetProject = CompProjectCache(ProjectId)
Else
Dim retryCount As Integer = 0
Retry:
Dim comp As Object
If FromCurseForge Then 'CurseForge
comp = DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data"))
Else 'Modrinth
comp = DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True)
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True))
End If
If comp Is Nothing Then '获取 ("data") 时会报值不能为 null
If retryCount > 2 Then Throw New Exception("工程对象获取失败，请等待一段时间后刷新再试！")
retryCount += 1
Thread.Sleep(1000)
GoTo Retry
End If
TargetProject = New CompProject(If(FromCurseForge, comp("data"), comp))
ElseIf FromCurseForge Then 'CurseForge
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data"))
Else 'Modrinth
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True))
End If
'获取工程对象的文件列表
Log("[Comp] 开始获取文件列表：" & ProjectId)
@@ -1464,11 +1441,11 @@ Retry:
If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data")
Else '否则使用全部文件
ResultJsonArray = NetGetCodeByRequestRetry($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", Accept:="application/json", IsJson:=True, BackupUrl:=DlSourceModGet($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999"))("data")
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data")
End If
Else
'Modrinth
ResultJsonArray = NetGetCodeByRequestRetry($"https://api.modrinth.com/v2/project/{ProjectId}/version", Accept:="application/json", IsJson:=True, BackupUrl:=DlSourceModGet($"https://api.modrinth.com/v2/project/{ProjectId}/version"))
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True)
End If
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
Where(Function(a) a.Available).ToList.Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项（#1330）
@@ -1485,8 +1462,7 @@ Retry:
Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods",
"POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data")
Else
Projects = NetGetCodeByRequestRetry($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]",
Accept:="application/json", IsJson:=True)
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]", IsJson:=True)
End If
For Each Project In Projects
Dim NewProject As New CompProject(Project) '在 New 的时候就添加了缓存
Plain Craft Launcher 2/Modules/Minecraft/ModCrash.vb
+4 -1
View File
@@ -881,7 +881,10 @@ NextStack:
FileName = "游戏崩溃前的输出.txt"
End Select
If File.Exists(OutputFile) Then
WriteFile(TempFolder & "Report\" & FileName, SecretFilter(ReadFile(OutputFile), If(FileName = "启动脚本.bat", "F", "*")))
Dim FileEncoding As Encoding = GetEncoding(OutputFile)
WriteFile(TempFolder & "Report\" & FileName,
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
Encoding:=FileEncoding)
End If
Next
'导出报告
Plain Craft Launcher 2/Modules/Minecraft/ModDownload.vb
+69 -53
View File
@@ -1,6 +1,4 @@
Imports Newtonsoft
Public Module ModDownload
Public Module ModDownload
#Region "DlClient* | Minecraft 客户端"
@@ -838,8 +836,8 @@ Public Module ModDownload
''' <summary>
''' NeoForge 版本列表，BMCLAPI。
''' </summary>
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeVersionBmclapiMain)
Public Sub DlNeoForgeVersionBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
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 = NetGetCodeByDownload("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
Dim ResultLegacy As String = NetGetCodeByDownload("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
@@ -1085,12 +1083,17 @@ Public Module ModDownload
#End Region
#Region "DlMod* | Mod 列表 / 信息 / 下载"
Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As String
#Region "DlMod | Mod 镜像源请求"
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。
''' 调用 NetGetCodeByRequestOnce。
''' </summary>
Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As Object
Dim McimUrl As String = DlSourceModGet(Url)
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
If McimUrl <> Url Then
Select Case Setup.Get("ToolDownloadVersion")
Select Case Setup.Get("ToolDownloadMod")
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
@@ -1102,14 +1105,27 @@ Public Module ModDownload
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End Select
End If
Return DlModRequest(Urls, IsJson:=IsJson)
Dim Exs As String = ""
For Each Source In Urls
Try
Return NetGetCodeByRequestOnce(Source.Key, Encode:=Encoding.UTF8, Timeout:=Source.Value * 1000,
IsJson:=IsJson, UseBrowserUserAgent:=True)
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
Next
Throw New Exception(Exs)
End Function
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String,
Optional Headers As Dictionary(Of String, String) = Nothing) As String
''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理。
''' 调用 NetRequestOnce。
''' </summary>
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String, Optional Headers As Dictionary(Of String, String) = Nothing) As String
Dim McimUrl As String = DlSourceModGet(Url)
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
If McimUrl <> Url Then
Select Case Setup.Get("ToolDownloadVersion")
Select Case Setup.Get("ToolDownloadMod")
Case 0
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 60))
@@ -1121,66 +1137,66 @@ Public Module ModDownload
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 60))
End Select
End If
Return DlModRequest(Urls, Method, Data, ContentType, Headers:=Headers)
End Function
Private Function DlModRequest(Urls As List(Of KeyValuePair(Of String, Integer)), Optional IsJson As Boolean = False) As String
Dim exMessage As String = ""
For Each url In Urls
Dim Exs As String = ""
For Each Source In Urls
Try
Return NetGetCodeByDownload(url.Key, Timeout:=url.Value, IsJson:=IsJson)
Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000, Headers:=Headers)
Catch ex As Exception
exMessage += ex.Message + vbCrLf
Exs += ex.Message + vbCrLf
End Try
Next
Throw New Exception(exMessage)
End Function
Private Function DlModRequest(Urls As List(Of KeyValuePair(Of String, Integer)), Method As String, Data As String,
ContentType As String, Optional Headers As Dictionary(Of String, String) = Nothing) As String
Dim exMessage As String = ""
For Each url In Urls
Try
Return NetRequestOnce(url.Key, Method, Data, ContentType, Timeout:=url.Value, Headers:=Headers)
Catch ex As Exception
exMessage += ex.Message + vbCrLf
End Try
Next
Throw New Exception(exMessage)
Throw New Exception(Exs)
End Function
#End Region
#Region "DlSource | 镜像下载源"
Public Function DlSourceResourceGet(MojangBase As String) As String()
MojangBase = MojangBase.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
Public Function DlSourceResourceGet(Original As String) As String()
Original = Original.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").
Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
Original
}
End Function
Public Function DlSourceLibraryGet(MojangBase As String) As String()
Public Function DlSourceLibraryGet(Original As String) As String()
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
Original
}
End Function
Public Function DlSourceModGet(CfMrBase As String) As String
'If CfMrBase Is Nothing Then Throw New Exception("无对应的 Mod 下载地址")
Return CfMrBase.Replace("api.modrinth.com/v2", "mod.mcmirror.top/modrinth") _
.Replace("staging-api.modrinth.com/v2", "mod.mcmirror.top/modrinth") _
.Replace("cdn.modrinth.com", "mod.mcimirror.top") _
.Replace("api.curseforge.com", "mod.mcimirror.top/curseforge") _
.Replace("edge.forgecdn.net", "mod.mcimirror.top") _
.Replace("mediafilez.forgecdn.net", "mod.mcimirror.top") _
.Replace("media.forgecdn.net", "mod.mcimirror.top")
Public Function DlSourceModGet(Original As String) As String
Return Original.
Replace("api.modrinth.com", "mod.mcimirror.top/modrinth").
Replace("staging-api.modrinth.com", "mod.mcimirror.top/modrinth").
Replace("cdn.modrinth.com", "mod.mcimirror.top").
Replace("api.curseforge.com", "mod.mcimirror.top/curseforge").
Replace("edge.forgecdn.net", "mod.mcimirror.top").
Replace("mediafilez.forgecdn.net", "mod.mcimirror.top").
Replace("media.forgecdn.net", "mod.mcimirror.top")
End Function
Public Function DlSourceLauncherOrMetaGet(MojangBase As String) As String()
If MojangBase Is Nothing Then Throw New Exception("无对应的 json 下载地址")
Public Function DlSourceLauncherOrMetaGet(Original As String) As String()
If Original Is Nothing Then Throw New Exception("无对应的 json 下载地址")
Return {
MojangBase.Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
MojangBase
Original.
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").
Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
Original
}
End Function
Plain Craft Launcher 2/Modules/Minecraft/ModJava.vb
+4 -2
View File
@@ -1,5 +1,5 @@
Public Module ModJava
Public JavaListCacheVersion As Integer = 6
Public JavaListCacheVersion As Integer = 7
''' <summary>
''' 目前所有可用的 Java。
@@ -220,6 +220,8 @@
JavaSearchFolder(GetPathFromFullPath(PathMcFolder), JavaPreList, False, True) 'Minecraft 文件夹的父文件夹（如果不是根目录的话）
End If
JavaSearchFolder(PathMcFolder, JavaPreList, False, True) 'Minecraft 文件夹
JavaPreList = JavaPreList.Where(Function(j) Not j.Key.Contains(".minecraft\runtime")).
ToDictionary(Function(j) j.Key, Function(j) j.Value) '排除官启自带 Java（#4286）
If RelatedVersion IsNot Nothing Then JavaSearchFolder(RelatedVersion.Path, JavaPreList, False, True) '所选版本文件夹
Dim TargetJavaList As New List(Of JavaEntry)
For Each Entry In JavaPreList
@@ -550,7 +552,7 @@ NoUserJava:
'若不全为特殊引用，则清除特殊引用的地址
Dim JavaWithoutInherit As New Dictionary(Of String, Boolean)
For Each Pair In JavaPreList
If Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") Then
If Pair.Key.Contains("java8path_target_") OrElse Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") Then
Log("[Java] 位于 " & Pair.Key & " 的 Java 包含特殊引用")
Else
Log("[Java] 位于 " & Pair.Key & " 的 Java 不含特殊引用")
Plain Craft Launcher 2/Modules/Minecraft/ModLaunch.vb
+126 -81
View File
@@ -225,7 +225,7 @@ NextInner:
"如果觉得 PCL 还算好用的话，也可以考虑赞助一下作者……一点心意也行……" & vbCrLf &
"毕竟一个人开发也不容易（悲）……",
"求赞助啦……", "这就赞助！", "但是我拒绝") = 1 Then
OpenWebsite("https://afdian.net/a/LTCat")
OpenWebsite("https://afdian.com/a/LTCat")
End If
End Select
End Sub, "Donate")
@@ -510,6 +510,7 @@ NextInner:
'无 RefreshToken
Relogin:
Dim OAuthCode As String = MsLoginStep1(Data)
If OAuthCode = "Cancel" Then Exit Sub
If Data.IsAborted Then Throw New ThreadInterruptedException
Data.Progress = 0.2
OAuthTokens = MsLoginStep2(OAuthCode, False)
@@ -518,6 +519,7 @@ Relogin:
OAuthTokens = MsLoginStep2(Input.OAuthRefreshToken, True)
End If
'要求重新打开登录网页认证
If OAuthTokens(0) = "Cancel" Then Exit Sub
If OAuthTokens(0) = "Relogin" Then GoTo Relogin
Data.Progress = 0.35
If Data.IsAborted Then Throw New ThreadInterruptedException
@@ -808,62 +810,18 @@ LoginFinish:
'微软登录步骤 1：打开网页认证，获取 OAuth Code
Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
McLaunchLog("开始微软登录步骤 1")
If True OrElse OsVersion <= New Version(10, 0, 17763, 0) Then '由于 #3849，WebBrowser 已经无法正常加载微软登录网页了
SystemBrowser:
'Windows 7 或老版 Windows 10 登录
OpenWebsite(FormLoginOAuth.LoginUrl1)
Dim Result As String =
MyMsgBoxInput("等待网页登录",
"登录完成后，网页会变得完全空白，把那个空白网页的网址复制到下面的框中就行了！" & vbCrLf &
"如果网络环境不佳，它可能一直加载不出来，那就只能试试用 VPN 或加速器了。",
ValidateRules:=New ObjectModel.Collection(Of Validate) From {New ValidateRegex("(?<=code\=)[^&]+", "返回网址应以 https://login.live.com/oauth20_desktop.srf?code= 开头")},
HintText:="https://login.live.com/oauth20_desktop.srf?code=XXXXXX")
If Result Is Nothing Then
McLaunchLog("微软登录已在步骤 1 被取消")
Throw New ThreadInterruptedException("$$")
Else
Return RegexSeek(Result, "(?<=code\=)[^&]+")
End If
Hint("网页登录成功，你可以关闭浏览器啦！", HintType.Finish)
OpenWebsite(FormLoginOAuth.LoginUrl1)
Dim Result As String =
MyMsgBoxInput("等待网页登录",
"登录完成后，网页会变得完全空白。把那个空白网页的网址复制到下面的框中就行！" & vbCrLf &
"如果网络环境不佳，它可能一直加载不出来，那就只能试试用 VPN 或加速器了。",
ValidateRules:=New ObjectModel.Collection(Of Validate) From {New ValidateRegex("(?<=code\=)[^&]+", "返回网址应以 https://login.live.com/oauth20_desktop.srf?code= 开头")},
HintText:="https://login.live.com/oauth20_desktop.srf?code=XXXXXX")
If Result Is Nothing Then
McLaunchLog("微软登录已在步骤 1 被取消")
Throw New ThreadInterruptedException("$$")
Else
'Windows 10 登录
Dim ReturnCode As String = Nothing
Dim ReturnEx As Exception = Nothing
Dim IsFinished As LoadState = LoadState.Loading
Dim LoginForm As FormLoginOAuth = Nothing
Dim IsSwitchToSystemBrowser As Boolean = False
RunInUi(Sub()
Try
LoginForm = New FormLoginOAuth
LoginForm.Show()
AddHandler LoginForm.OnLoginSuccess, Sub(Code As String)
ReturnCode = Code
IsFinished = LoadState.Finished
End Sub
AddHandler LoginForm.OnLoginCanceled, Sub(IsSwitch As Boolean)
IsFinished = LoadState.Aborted
IsSwitchToSystemBrowser = IsSwitch
End Sub
Catch ex As Exception
ReturnEx = ex
IsFinished = LoadState.Failed
End Try
End Sub)
Do While IsFinished = LoadState.Loading AndAlso Not Data.IsAborted
Thread.Sleep(20)
Loop
RunInUi(Sub() If LoginForm IsNot Nothing Then LoginForm.Close())
If IsFinished = LoadState.Finished Then
Return ReturnCode
ElseIf IsFinished = LoadState.Failed Then
Throw ReturnEx
ElseIf IsSwitchToSystemBrowser Then
McLaunchLog("微软登录在步骤 1 要求切换到系统浏览器")
GoTo SystemBrowser
Else
McLaunchLog("微软登录已在步骤 1 被取消")
Throw New ThreadInterruptedException("$$")
End If
Return RegexSeek(Result, "(?<=code\=)[^&]+")
End If
End Function
'微软登录步骤 2：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
@@ -900,19 +858,112 @@ SystemBrowser:
Dim RefreshToken As String = ResultJson("refresh_token").ToString
Return {AccessToken, RefreshToken}
End Function
''微软登录步骤 1：获取 DeviceCode 并显示验证提示
''https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code
'Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
' McLaunchLog("开始微软登录步骤 1：获取验证信息")
' Dim PrepareJson As JObject = GetJson(NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
' $"client_id={OAuthClientId}&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded", 2))
' '从这里开始直到步骤 2 结束都没有 Review
' '参考：https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code
' If MyMsgBox("请在打开的网页里输入 PCL2 提供的设备代码（会自动复制到剪贴板）。" & vbCrLf &
' "设备代码有时效性，若操作时间过长需要重新进行登录流程。", "正版验证确认", "继续", "取消") <> 1 Then
' Return "Cancel"
' End If
' Dim DeviceCode As String = PrepareJson("device_code")
' Dim UserCode As String = PrepareJson("user_code")
' Dim VerifyUri As String = PrepareJson("verification_uri")
' 'ResultJson("expires_in")
' ClipboardSet(UserCode)
' OpenWebsite(VerifyUri)
' Dim MsgBoxValue As String = ""
' While MsgBoxValue IsNot "1"
' MsgBoxValue = MyMsgBox("本次验证的设备代码为：" & UserCode & vbCrLf & vbCrLf & "你也可以在任意设备上打开下列网址进行验证：" & vbCrLf & VerifyUri & vbCrLf & vbCrLf & "在验证完成后，你可以直接关闭这个弹窗，PCL2 会自动完成接下来的流程。", "正版验证", "关闭", "复制网址", "复制设备代码").ToString
' If MsgBoxValue = "2" Then
' ClipboardSet(VerifyUri)
' Continue While
' ElseIf MsgBoxValue = "3" Then
' ClipboardSet(UserCode)
' Continue While
' ElseIf MsgBoxValue = "1" Then
' Exit While
' End If
' End While
' Return DeviceCode
'End Function
''微软登录步骤 2：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
'Private Function MsLoginStep2(Code As String, IsRefresh As Boolean, Optional ExpiresIn As String = "900") As String()
' McLaunchLog("开始微软登录步骤 2（" & If(IsRefresh, "", "非") & "刷新登录）")
' Dim Request As String
' If IsRefresh Then
' Request = "grant_type=refresh_token" & "&" &
' "client_id=" & OAuthClientId & "&" &
' "device_code=" & Code & "&" &
' "refresh_token=" & Uri.EscapeDataString(Code) & "&" &
' "scope=XboxLive.signin%20offline_access"
' Else
' Request = "grant_type=urn:ietf:params:oauth:grant-type:device_code" & "&" &
' "client_id=" & OAuthClientId & "&" &
' "device_code=" & Code & "&" &
' "scope=XboxLive.signin%20offline_access"
' End If
' Dim Result As String
' Dim stopwatch As Stopwatch = Stopwatch.StartNew()
' While stopwatch.Elapsed < TimeSpan.FromSeconds(ExpiresIn)
' Try
' Result = NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/token", "POST", Request, "application/x-www-form-urlencoded", 2)
' Catch ex As Exception
' If ex.Message.Contains("must sign in again") OrElse ex.Message.Contains("invalid_grant") Then '#269
' Return {"Relogin", ""}
' ElseIf ex.Message.Contains("authorization_declined") Then
' Hint("你拒绝了 PCL2 的访问权限申请，验证过程被中断！")
' Return {"Cancel", ""}
' ElseIf ex.Message.Contains("expired_token") Then
' Hint("Token 已过期，请尝试重新验证！")
' Exit While
' ElseIf ex.Message.Contains("AADSTS70016") Then
' Continue While
' Else
' Throw
' End If
' End Try
' If Result IsNot Nothing Then
' Dim ResultJson As JObject = GetJson(Result)
' Dim AccessToken As String = ResultJson("access_token").ToString
' Dim RefreshToken As String = ResultJson("refresh_token").ToString
' Return {AccessToken, RefreshToken}
' End If
' Thread.Sleep(1000)
' End While
' Hint("验证超时，请尝试重新验证！")
' Return {"Cancel", ""}
'End Function
'微软登录步骤 3：从 OAuth AccessToken 获取 XBLToken
Private Function MsLoginStep3(AccessToken As String) As String
McLaunchLog("开始微软登录步骤 3")
Dim Request As String = "{
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}"
""Properties"": {
""AuthMethod"": ""RPS"",
""SiteName"": ""user.auth.xboxlive.com"",
""RpsTicket"": """ & AccessToken & """
},
""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT""
}" 'TODO: 新版登录改为 ""RpsTicket"": ""d=" & AccessToken & """
Dim Result As String = NetRequestMulty("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
Dim ResultJson As JObject = GetJson(Result)
@@ -1069,7 +1120,7 @@ SystemBrowser:
Case 3
'使用正版用户名
Try
If Not SkinName = "" Then
If SkinName <> "" AndAlso McVersionCurrent.Version.McCodeMain < 20 Then '1.20+ 或快照版不能使用该项（#3746）
Log("[Skin] 由于离线皮肤设置，使用正版 UUID：" & SkinName)
Uuid = McLoginMojangUuid(SkinName, False)
End If
@@ -1199,7 +1250,7 @@ SystemBrowser:
'统一通行证检测
If Setup.Get("LoginType") = McLoginType.Nide Then
'至少 Java 8u101
MinVer = If(New Version(1, 8, 0, 101) > MinVer, New Version(1, 8, 0, 101), MinVer)
MinVer = If(New Version(1, 8, 0, 141) > MinVer, New Version(1, 8, 0, 141), MinVer)
End If
SyncLock JavaLock
@@ -1226,12 +1277,12 @@ SystemBrowser:
ElseIf MaxVer < New Version(1, 8, 0, 0) Then
JavaCode = 7
If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 100) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = "8u101"
If Not JavaDownloadConfirm("Java 8.0.101 ~ 8.0.320", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 100) Then
JavaCode = "8u101"
If Not JavaDownloadConfirm("Java 8.0.101 或更高版本的 Java 8", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 140) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = "8u141"
If Not JavaDownloadConfirm("Java 8.0.141 ~ 8.0.320", True) Then Throw New Exception("$$")
ElseIf MinVer > New Version(1, 8, 0, 140) Then
JavaCode = "8u141"
If Not JavaDownloadConfirm("Java 8.0.141 或更高版本的 Java 8", True) Then Throw New Exception("$$")
ElseIf MaxVer < New Version(1, 8, 0, 321) Then
JavaCode = 8
If Not JavaDownloadConfirm("Java 8.0.320 或更低版本的 Java 8") Then Throw New Exception("$$")
@@ -1785,7 +1836,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1816,7 +1866,6 @@ NextVersion:
{
""authenticationDatabase"": {
""00000111112222233333444445555566"": {
""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
""username"": """ & McLoginLoader.Output.Name.Replace("""", "-") & """,
""profiles"": {
""66666555554444433333222221111100"": {
@@ -1892,16 +1941,12 @@ NextVersion:
End Try
'离线皮肤 Alex 警告
Try
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.7 ~ 1.2
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.2 ~ 1.7
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)
End If
Catch ex As Exception
Log(ex, "检查离线皮肤失效失败")
End Try
Hint("此 Minecraft 版本尚不支持 Alex 皮肤，你的皮肤可能会显示为 Steve！", HintType.Critical)
End If
'离线皮肤资源包
Try
Plain Craft Launcher 2/Modules/Minecraft/ModMinecraft.vb
+6 -4
View File
@@ -565,6 +565,7 @@ Recheck:
Log(ex, "合并版本依赖项 json 失败（" & If(InheritVersion, "null").ToString & "）")
End Try
Catch ex As Exception
Log($"[Minecraft] 传入的版本 json 文件内容（共 {Text.Length} 字符，最多输出前 5000 字符）：{vbCrLf}{Text.Substring(0, 5000)}")
Throw New Exception("版本 json 不规范（" & If(Name, "null") & "）", ex)
End Try
Try
@@ -665,7 +666,7 @@ Recheck:
Try
Dim JsonObjCheck = JsonObject
Catch ex As Exception
Log(ex, "版本 json 可用性检查失败（" & Path & "）")
Log(ex, "版本 JSON 可用性检查失败（" & Path & "）")
JsonText = ""
JsonObject = Nothing
Info = ex.Message
@@ -2026,8 +2027,9 @@ OnLoaded:
If Token.Url IsNot Nothing Then
'获取 Url 的真实地址
Urls.Add(Token.Url)
If Token.Url.Contains("launcher.mojang.com/v1/objects") Then
Urls = DlSourceLauncherOrMetaGet(Token.Url).ToList() 'Mappings
If Token.Url.Contains("launcher.mojang.com/v1/objects") OrElse Token.Url.Contains("client.txt") OrElse
Token.Url.Contains(".tsrg") Then
Urls.AddRange(DlSourceLauncherOrMetaGet(Token.Url).ToList()) 'Mappings（#4425）
End If
If Token.Url.Contains("maven") Then
Urls.Insert(0, Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOfF("maven")), "https://bmclapi2.bangbang93.com/").
@@ -2049,7 +2051,7 @@ OnLoaded:
'普通文件
Urls.AddRange(DlSourceLibraryGet("https://libraries.minecraft.net" & Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries", "").Replace("\", "/")))
End If
Result.Add(New NetFile(Urls.Distinct.ToArray, Token.LocalPath, Checker))
Result.Add(New NetFile(Urls.Distinct, Token.LocalPath, Checker))
Next
'去重并返回
Return Result.Distinct(Function(a, b) a.LocalPath = b.LocalPath)
Plain Craft Launcher 2/Modules/Minecraft/ModMod.vb
+9 -6
View File
@@ -924,7 +924,7 @@ Finished:
End Try
End Sub
'联网加载 Mod 详情
Private Const LocalModCacheVersion As Integer = 5
Private Const LocalModCacheVersion As Integer = 6
Public McModDetailLoader As New LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer)("Mod List Detail Loader", AddressOf McModDetailLoad)
Private Sub McModDetailLoad(Loader As LoaderTask(Of KeyValuePair(Of List(Of McMod), JObject), Integer))
Dim Mods As List(Of McMod) = Loader.Input.Key
@@ -973,7 +973,7 @@ Finished:
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3：获取工程信息
If Not ModrinthMapping.Any() Then Exit Sub
Dim ModrinthProject = CType(GetJson(NetRequestRetry(
Dim ModrinthProject = CType(GetJson(DlModRequest(
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]",
"GET", "", "application/json")), JArray)
For Each ProjectJson In ModrinthProject
@@ -1022,7 +1022,7 @@ Finished:
CurseForgeHashes.Add(Entry.CurseForgeHash)
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
Next
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432/", "POST",
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST",
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
@@ -1050,7 +1050,7 @@ Finished:
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject
If Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
If ProjectJson("isAvailable") IsNot Nothing AndAlso Not ProjectJson("isAvailable").ToObject(Of Boolean) Then Continue For
'设置 Entry 中的工程信息
Dim Project As New CompProject(ProjectJson)
For Each Entry In CurseForgeMapping(Project.Id) '倒查防止 CurseForge 返回的内容有漏
@@ -1066,7 +1066,8 @@ Finished:
Dim NewestVersion As String = Nothing
Dim NewestFileIds As New List(Of Integer)
For Each IndexEntry In ProjectJson("latestFilesIndexes")
If ModLoaders.Single <> IndexEntry("modLoader")?.ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
If IndexEntry("modLoader") Is Nothing OrElse Not IndexEntry("modLoader").HasValues OrElse '镜像源会返回一个值为 null 的键
ModLoaders.Single <> IndexEntry("modLoader").ToObject(Of Integer) Then Continue For 'ModLoader 唯一且匹配
Dim IndexVersion As String = IndexEntry("gameVersion")
If McVersion <> IndexVersion Then Continue For 'MC 版本匹配
'由于 latestFilesIndexes 是按时间从新到老排序的，所以只需取第一个；如果需要检查多个 releaseType 下的文件，将 > -1 改为 = 1，但这应当并不会获取到更新的文件
@@ -1134,6 +1135,8 @@ Finished:
Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
Next
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
'刷新下边栏（#4377）
RunInUi(Sub() FrmVersionMod?.RefreshBottomBar())
End Sub
Private Function GetTargetModLoaders() As List(Of CompModLoaderType)
Dim ModLoaders As New List(Of CompModLoaderType)
@@ -1275,4 +1278,4 @@ Finished:
End Function
#End If
End Module
End Module
Plain Craft Launcher 2/Modules/Minecraft/ModModpack.vb
+136 -138
View File
@@ -12,9 +12,10 @@ Public Module ModModpack
RunInThread(Sub() ModpackInstall(File))
End Sub
''' <summary>
''' 安装一个给定的整合包文件，返回是否安装成功。必须在工作线程执行。
''' 安装一个给定的整合包文件，返回启动的安装加载器，如果未成功启动则返回 Nothing。
''' 必须在工作线程执行。
''' </summary>
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True, Optional Logo As String = Nothing) As Boolean
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True, Optional Logo As String = Nothing) As LoaderCombo(Of String)
Log("[ModPack] 整合包安装请求：" & If(File, "null"))
Dim Archive As ZipArchive = Nothing
Dim ArchiveBaseFolder As String = ""
@@ -45,6 +46,7 @@ Public Module ModModpack
If FullNames.Count <> 2 Then Continue For
'判断是否为关键文件
If FullNames(1) = "mcbbs.packmeta" Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包（优先于 manifest.json 判断，#4194）
If FullNames(1) = "modrinth.index.json" Then PackType = 4 : Exit Try 'Modrinth 整合包
If FullNames(1) = "manifest.json" Then
Dim Json As JObject = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
@@ -55,54 +57,52 @@ Public Module ModModpack
End If
End If
If FullNames(1) = "modpack.json" Then PackType = 1 : Exit Try 'HMCL 整合包
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包
Next
Catch ex As Exception
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
Log(ex, "打开整合包文件失败", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
ElseIf File.EndsWithF(".rar", True) Then
Log(ex, "PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
Else
Log(ex, "打开整合包文件失败，文件可能损坏或为不支持的压缩包格式", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
Return False
Return Nothing
End If
End Try
'执行对应的安装方法
Select Case PackType
Case 0
Log("[ModPack] 整合包种类：CurseForge")
InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Return InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Case 1
Log("[ModPack] 整合包种类：HMCL")
InstallPackHMCL(File, Archive, ArchiveBaseFolder)
Return InstallPackHMCL(File, Archive, ArchiveBaseFolder)
Case 2
Log("[ModPack] 整合包种类：MMC")
InstallPackMMC(File, Archive, ArchiveBaseFolder)
Return InstallPackMMC(File, Archive, ArchiveBaseFolder)
Case 3
Log("[ModPack] 整合包种类：MCBBS")
InstallPackMCBBS(File, Archive, ArchiveBaseFolder)
Return InstallPackMCBBS(File, Archive, ArchiveBaseFolder, VersionName)
Case 4
Log("[ModPack] 整合包种类：Modrinth")
InstallPackModrinth(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Return InstallPackModrinth(File, Archive, ArchiveBaseFolder, VersionName, Logo)
Case 9
Log("[ModPack] 整合包种类：压缩包")
Archive.Dispose()
Archive = Nothing
InstallPackCompress(File, ArchiveBaseFolder)
Return InstallPackCompress(File, ArchiveBaseFolder)
Case Else
If ShowHint Then
Hint("未能识别该整合包的种类，无法安装！", HintType.Critical)
Else
Log("[ModPack] 未能识别该整合包的种类，无法安装！")
End If
Return False
Return Nothing
End Select
Return True
Catch ex As Exception
Log(ex, "准备安装整合包失败", LogLevel.Feedback)
Return False
Return Nothing
Finally
If Archive IsNot Nothing Then Archive.Dispose()
End Try
@@ -159,7 +159,8 @@ Retry:
#Region "不同类型整合包的安装方法"
'CurseForge
Private Sub InstallPackCurseForge(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing)
Private Function InstallPackCurseForge(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String,
Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
@@ -167,18 +168,18 @@ Retry:
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open))
If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Log(ex, "CurseForge 整合包安装信息存在问题", LogLevel.Hint)
Return Nothing
End Try
'获取版本名
Dim ShowRibble As Boolean = VersionName Is Nothing
If VersionName Is Nothing Then
Dim PackName As String = If(Json("name"), "")
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
VersionName = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Return Nothing
End If
'获取 Mod API 版本信息
@@ -191,7 +192,7 @@ Retry:
'Forge 指定
If Id.Contains("recommended") Then
Log("[ModPack] 该整合包版本过老，已不支持进行安装！", LogLevel.Hint)
Exit Sub
Return Nothing
End If
Try
Log("[ModPack] 整合包 Forge 版本：" & Id)
@@ -319,7 +320,7 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -350,14 +351,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "CurseForge 整合包安装：" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中！", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中！", HintType.Critical)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -365,11 +362,11 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
End Sub
Return Loader
End Function
'Modrinth
Private Sub InstallPackModrinth(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing)
Private Function InstallPackModrinth(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing, Optional Logo As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
@@ -378,7 +375,7 @@ Retry:
If Json("dependencies") Is Nothing OrElse Json("dependencies")("minecraft") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
End Try
'获取 Mod API 版本信息
Dim MinecraftVersion As String = Nothing
@@ -400,42 +397,42 @@ Retry:
Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion)
Case "quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
Case Else
Hint($"无法安装整合包，其中出现了未知的 Mod 加载器 {Entry.Value}！", HintType.Critical)
Exit Sub
Return Nothing
End Select
Next
'获取版本名
Dim ShowRibble As Boolean = VersionName Is Nothing
If VersionName Is Nothing Then
Dim PackName As String = If(Json("name"), "")
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
VersionName = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Return Nothing
End If
'解压和配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
'复制 overrides 文件夹和 client-overrides 文件夹
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName)
Else
Log("[ModPack] 整合包中未找到 override 目录，已跳过")
End If
Task.Progress = 0.8
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "client-overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "client-overrides", PathMcFolder & "versions\" & VersionName)
End If
Task.Progress = 0.9
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
Sub(Task As LoaderTask(Of String, Integer))
UnpackFiles(InstallTemp, FileAddress, Task)
Task.Progress = 0.5
'复制 overrides 文件夹和 client-overrides 文件夹
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName)
Else
Log("[ModPack] 整合包中未找到 override 目录，已跳过")
End If
Task.Progress = 0.8
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "client-overrides") Then
CopyDirectory(InstallTemp & ArchiveBaseFolder & "client-overrides", PathMcFolder & "versions\" & VersionName)
End If
Task.Progress = 0.9
'开启版本隔离
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
'获取下载文件列表
Dim FileList As New List(Of NetFile)
For Each File In If(Json("files"), {})
@@ -452,8 +449,10 @@ Retry:
End Select
End If
'添加下载文件
FileList.Add(New NetFile(File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToArray, '修复 #2390
PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
Dim Urls = File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToList
Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
Urls = Urls.Distinct.ToList()
FileList.Add(New NetFile(Urls, PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString), True))
Next
If FileList.Any Then
@@ -470,7 +469,7 @@ Retry:
.FabricVersion = FabricVersion
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -501,14 +500,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "Modrinth 整合包安装：" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中！", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中！", HintType.Critical)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -516,25 +511,26 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Sub
End Function
'HMCL
Private Sub InstallPackHMCL(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackHMCL(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modpack.json").Open, Encoding.UTF8))
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
End Try
'获取版本名
Dim PackName As String = If(Json("name"), "")
Dim VersionName As String = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Return Nothing
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
@@ -555,7 +551,7 @@ Retry:
'构造加载器
If Json("gameVersion") Is Nothing Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
@@ -563,7 +559,7 @@ Retry:
.MinecraftName = Json("gameVersion").ToString
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json（副加载器）",
@@ -591,14 +587,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "HMCL 整合包安装：" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中！", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中！", HintType.Critical)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -607,10 +599,11 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
Return Loader
End Function
'MMC
Private Sub InstallPackMMC(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackMMC(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String) As LoaderCombo(Of String)
'读取 Json 文件
Dim PackJson As JObject, PackInstance As String
Try
@@ -618,14 +611,14 @@ Retry:
PackInstance = ReadFile(Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open, Encoding.UTF8)
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
End Try
'获取版本名
Dim PackName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
Dim VersionName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Return Nothing
'解压、配置设置文件
Dim InstallTemp As String = $"{PathTemp}PackInstall\{RandomInteger(0, 100000)}\"
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
@@ -685,7 +678,7 @@ Retry:
'构造版本安装请求
If PackJson("components") Is Nothing Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"}
For Each Component In PackJson("components")
@@ -702,12 +695,12 @@ Retry:
Request.FabricVersion = Component("version")
Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
End Select
Next
'构造加载器
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -720,14 +713,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "MMC 整合包安装：" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中！", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中！", HintType.Critical)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -735,10 +724,12 @@ Retry:
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
Return Loader
End Function
'MCBBS
Private Sub InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
Private Function InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String,
Optional VersionName As String = Nothing) As LoaderCombo(Of String)
'读取 Json 文件
Dim Json As JObject
Try
@@ -746,14 +737,17 @@ Retry:
Json = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
Catch ex As Exception
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
Exit Sub
Return Nothing
End Try
'获取版本名
Dim PackName As String = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If VersionName Is Nothing Then Exit Sub
Dim ShowRibble As Boolean = VersionName Is Nothing
If VersionName Is Nothing Then
VersionName = If(Json("name"), "")
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(VersionName) <> "" Then VersionName = ""
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Return Nothing
End If
'解压与配置文件
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
Dim InstallLoaders As New List(Of LoaderBase)
@@ -774,7 +768,7 @@ Retry:
'构造加载器
If Json("addons") Is Nothing Then
Hint("该整合包未提供游戏版本附加信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Addons As New Dictionary(Of String, String)
For Each Entry In Json("addons")
@@ -782,11 +776,11 @@ Retry:
Next
If Not Addons.ContainsKey("game") Then
Hint("该整合包未提供游戏版本信息，无法安装！", HintType.Critical)
Exit Sub
Return Nothing
End If
If Addons.ContainsKey("quilt") Then
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
Exit Sub
Return Nothing
End If
Dim Request As New McInstallRequest With {
.TargetVersionName = VersionName,
@@ -798,7 +792,7 @@ Retry:
.FabricVersion = If(Addons.ContainsKey("fabric"), Addons("fabric"), Nothing)
}
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
If MergeLoaders Is Nothing Then Exit Sub
If MergeLoaders Is Nothing Then Return Nothing
'构造 Libraries 加载器
Dim LoadersLib As New List(Of LoaderBase)
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
@@ -811,14 +805,10 @@ Retry:
'重复任务检查
Dim LoaderName As String = "MCBBS 整合包安装：" & VersionName & " "
SyncLock LoaderTaskbarLock
For i = 0 To LoaderTaskbar.Count - 1
If LoaderTaskbar(i).Name = LoaderName Then
Hint("该整合包正在安装中！", HintType.Critical)
Exit Sub
End If
Next
End SyncLock
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
Hint("该整合包正在安装中！", HintType.Critical)
Return Nothing
End If
'启动
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
@@ -826,28 +816,36 @@ Retry:
Loader.Start(Request.TargetVersionFolder)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Function
'普通压缩包
Private Sub InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String)
Private Function InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String) As LoaderCombo(Of String)
MyMsgBox("请在接下来打开的窗口中选择安装目标文件夹，它必须是一个空文件夹。", "安装提示", "继续", ForceWait:=True)
'获取解压路径
Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）")
If String.IsNullOrEmpty(TargetFolder) Then Exit Sub
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Exit Sub
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Exit Sub
If String.IsNullOrEmpty(TargetFolder) Then Return Nothing
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Return Nothing
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Return Nothing
'要求显示名称
Dim NewName As String = MyMsgBoxInput("输入显示名称", "输入该文件夹在左边栏列表中显示的名称。", GetFolderNameFromPath(TargetFolder),
New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})})
If String.IsNullOrWhiteSpace(NewName) Then Exit Sub
If String.IsNullOrWhiteSpace(NewName) Then Return Nothing
'解压
Hint("正在解压压缩包……")
UnpackFiles(TargetFolder, FileAddress, Nothing)
'加入文件夹列表
PageSelectLeft.AddFolder(TargetFolder, NewName, False)
Hint("已加入游戏文件夹列表：" & NewName, HintType.Finish)
End Sub
Dim Loader As New LoaderCombo(Of String)("安装压缩包", {
New LoaderTask(Of String, Integer)("安装压缩包",
Sub()
UnpackFiles(TargetFolder, FileAddress, Nothing)
PageSelectLeft.AddFolder(TargetFolder, NewName, False) '加入文件夹列表
End Sub)
})
Loader.Start()
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
Return Loader
End Function
#End Region
Plain Craft Launcher 2/Modules/ModSecret.vb
+7 -7
View File
@@ -10,6 +10,8 @@ Friend Module ModSecret
'在开源内容的注册表键与普通内容的注册表键隔离
Public Const RegFolder As String = "PCLDebug"
'用于微软登录的 ClientId
Public Const OAuthClientId As String = ""
Friend Sub SecretOnApplicationStart()
'提升 UI 线程优先级
@@ -41,8 +43,9 @@ Friend Module ModSecret
Environment.[Exit](Result.Cancel)
End If
'开源版本提示
MyMsgBox($"该版本中不包含以下特性：
- CurseForge 查询：需要 API Key（你可以申请一个，然后添加到 SecretHeadersSign 方法中）
MyMsgBox($"该版本中无法使用以下特性：
- CurseForge API 调用：需要你自行申请 API Key，然后添加到 SecretHeadersSign 方法中
- 正版登录：需要你自行申请 Client ID，然后添加到 ModSecret.vb 的开头
- 更新与联网通知：避免滥用隐患
- 主题切换：这是需要赞助解锁的纪念性质的功能，别让赞助者太伤心啦……
- 百宝箱：开发早期往里面塞了些开发工具，整理起来太麻烦了", "开源版本说明")
@@ -89,7 +92,6 @@ Friend Module ModSecret
#Region "网络鉴权"
Friend Function SecretCdnSign(UrlWithMark As String)
'只处理以 {CDN} 结尾的链接
If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark
Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20")
End Function
@@ -97,26 +99,24 @@ Friend Module ModSecret
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Client As CookieWebClient, Optional UseBrowserUserAgent As Boolean = False)
If ApplicationStartTick < 1 Then Return '禁止在没有运行程序的情况下通过反射调用
If UseBrowserUserAgent Then
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode
End If
Client.Headers("Referer") = "http://" & VersionCode & ".pcl2.server/"
Client.Headers("Referer") = "http://" & VersionCode & ".pcl2.open.server/"
'如果你有 CurseForge API Key，请添加到 Headers 中，以恢复对 CurseForge 的访问
End Sub
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Request As HttpWebRequest, Optional UseBrowserUserAgent As Boolean = False)
If ApplicationStartTick < 1 Then Return '禁止在没有运行程序的情况下通过反射调用
If UseBrowserUserAgent Then
Request.UserAgent = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Request.UserAgent = "PCL2/" & VersionStandardCode
End If
Request.Referer = "http://" & VersionCode & ".pcl2.server/"
Request.Referer = "http://" & VersionCode & ".pcl2.open.server/"
'如果你有 CurseForge API Key，请添加到 Headers 中，以恢复对 CurseForge 的访问
End Sub