This commit is contained in:
龙腾猫跃
2025-09-12 23:40:01 +08:00
parent 2210da6fda
commit 6f6744dfd2
18 changed files with 200 additions and 212 deletions
+3 -2
View File
@@ -19,6 +19,9 @@ Public Class Application
'开始 '开始
Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup
Try Try
'动态 DLL 调用(必须尽量在前面,否则模块加载 CacheCow 等 DLL 就可能导致崩溃)
AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve
'开始
SecretOnApplicationStart() SecretOnApplicationStart()
'检查参数调用 '检查参数调用
If e.Args.Length > 0 Then If e.Args.Length > 0 Then
@@ -116,8 +119,6 @@ WaitRetry:
FrmStart = New SplashScreen("Images\icon.ico") FrmStart = New SplashScreen("Images\icon.ico")
FrmStart.Show(False, True) FrmStart.Show(False, True)
End If End If
'动态 DLL 调用
AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf AssemblyResolve
'日志初始化 '日志初始化
LogStart() LogStart()
'添加日志 '添加日志
@@ -121,7 +121,6 @@
RunInNewThread( RunInNewThread(
Sub() Sub()
Try Try
RetryStart:
'下载 '下载
ActualSource = LoadingSource '显示加载中的占位图片 ActualSource = LoadingSource '显示加载中的占位图片
NetDownloadByLoader( NetDownloadByLoader(
+14 -1
View File
@@ -11,6 +11,14 @@ Public Class FormMain
Dim FeatureList As New List(Of KeyValuePair(Of Integer, String)) Dim FeatureList As New List(Of KeyValuePair(Of Integer, String))
'统计更新日志条目 '统计更新日志条目
#If BETA Then #If BETA Then
If LastVersion < 369 Then 'Release 2.10.8
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增:允许在版本设置中设置禁止更新 Mod,以防整合包玩家误操作"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:网络与下载稳定性优化"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "优化:若整合包需要 PCL 不兼容的加载器,允许选择跳过它的安装"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "删除:由于已不再需要,删除手动安装包下载功能"))
FeatureCount += 21
BugCount += 32
End If
If LastVersion < 367 Then 'Release 2.10.6 If LastVersion < 367 Then 'Release 2.10.6
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:启用 MCIM 社区资源镜像源,以缓解社区资源难以下载的问题")) FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:启用 MCIM 社区资源镜像源,以缓解社区资源难以下载的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:正版登录出错时无法给出正确的错误信息")) FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:正版登录出错时无法给出正确的错误信息"))
@@ -96,6 +104,11 @@ Public Class FormMain
'3:BUG+ IMP* FEAT- '3:BUG+ IMP* FEAT-
'2:BUG* IMP- '2:BUG* IMP-
'1:BUG- '1:BUG-
If LastVersion < 370 Then 'Snapshot 2.10.8
If LastVersion >= 368 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:网络与下载稳定性优化"))
FeatureCount += 3
BugCount += 4
End If
If LastVersion < 368 Then 'Snapshot 2.10.7 If LastVersion < 368 Then 'Snapshot 2.10.7
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增:允许在版本设置中设置禁止更新 Mod,以防整合包玩家误操作")) FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "新增:允许在版本设置中设置禁止更新 Mod,以防整合包玩家误操作"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:网络与下载稳定性优化")) FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:网络与下载稳定性优化"))
@@ -590,7 +603,7 @@ Public Class FormMain
FeedbackInfo() FeedbackInfo()
Log("请在 https://github.com/Meloong-Git/PCL/issues 提交错误报告,以便于作者解决此问题!") Log("请在 https://github.com/Meloong-Git/PCL/issues 提交错误报告,以便于作者解决此问题!")
IsLogShown = True IsLogShown = True
ShellOnly(Path & "PCL\Log1.txt") StartProcess(Path & "PCL\Log1.txt")
End If End If
Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉 Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉
End If End If
+49 -87
View File
@@ -13,13 +13,13 @@ Public Module ModBase
#Region "声明" #Region "声明"
'下列版本信息由更新器自动修改 '下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.10.7" '不含分支前缀的显示用版本名 Public Const VersionBaseName As String = "2.10.8" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.7." & VersionBranchCode '标准格式的四段式版本号 Public Const VersionStandardCode As String = "2.10.8." & VersionBranchCode '标准格式的四段式版本号
Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换 Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换
#If BETA Then #If BETA Then
Public Const VersionCode As Integer = 367 'Release Public Const VersionCode As Integer = 367 'Release
#Else #Else
Public Const VersionCode As Integer = 368 'Snapshot Public Const VersionCode As Integer = 370 'Snapshot
#End If #End If
'自动生成的版本信息 '自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -765,17 +765,6 @@ Public Module ModBase
Return FilePath Return FilePath
End Function End Function
''' <summary> ''' <summary>
''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。
''' </summary>
Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String
Dim Name As String = GetFileNameFromPath(FilePath)
If Name.Contains(".") Then
Return Name.Substring(0, Name.LastIndexOfF("."))
Else
Return Name
End If
End Function
''' <summary>
''' 从文件夹路径获取文件夹名。 ''' 从文件夹路径获取文件夹名。
''' </summary> ''' </summary>
Public Function GetFolderNameFromPath(FolderPath As String) As String Public Function GetFolderNameFromPath(FolderPath As String) As String
@@ -791,8 +780,8 @@ Public Module ModBase
Public Sub CopyFile(FromPath As String, ToPath As String) Public Sub CopyFile(FromPath As String, ToPath As String)
Try Try
'还原文件路径 '还原文件路径
FromPath = ShortenPath(If(FromPath.Contains(":\"), FromPath, Path & FromPath)) FromPath = If(FromPath.Contains(":\"), FromPath, Path & FromPath)
ToPath = ShortenPath(If(ToPath.Contains(":\"), ToPath, Path & ToPath)) ToPath = If(ToPath.Contains(":\"), ToPath, Path & ToPath)
'如果复制同一个文件则跳过 '如果复制同一个文件则跳过
If FromPath = ToPath Then Return If FromPath = ToPath Then Return
'确保目录存在 '确保目录存在
@@ -861,7 +850,7 @@ Public Module ModBase
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param> ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing)
'处理相对路径 '处理相对路径
FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath)) FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath)
'确保目录存在 '确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath)) Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件 '写入文件
@@ -886,7 +875,7 @@ Public Module ModBase
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param> ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
'处理相对路径 '处理相对路径
FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath)) FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath)
'确保目录存在 '确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath)) Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件 '写入文件
@@ -1294,11 +1283,11 @@ Re:
''' </summary> ''' </summary>
Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing, Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing,
Optional ProgressIncrementHandler As Action(Of Double) = Nothing) Optional ProgressIncrementHandler As Action(Of Double) = Nothing)
Directory.CreateDirectory(ShortenPath(DestDirectory)) Directory.CreateDirectory(DestDirectory)
If CompressFilePath.EndsWithF(".gz", True) Then If CompressFilePath.EndsWithF(".gz", True) Then
'以 gz 方式解压 '以 gz 方式解压
Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress) Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress)
Dim decompressedFile As New FileStream(ShortenPath(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", "")), FileMode.OpenOrCreate, FileAccess.Write) Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write)
Dim data As Integer = stream.ReadByte() Dim data As Integer = stream.ReadByte()
While data <> -1 While data <> -1
decompressedFile.WriteByte(data) decompressedFile.WriteByte(data)
@@ -1312,13 +1301,10 @@ Re:
Dim TotalCount As Long = Archive.Entries.Count Dim TotalCount As Long = Archive.Entries.Count
For Each Entry As ZipArchiveEntry In Archive.Entries For Each Entry As ZipArchiveEntry In Archive.Entries
If ProgressIncrementHandler IsNot Nothing AndAlso TotalCount > 0 Then ProgressIncrementHandler(1 / TotalCount) If ProgressIncrementHandler IsNot Nothing AndAlso TotalCount > 0 Then ProgressIncrementHandler(1 / TotalCount)
Dim DestinationPath As String = ShortenPath(IO.Path.Combine(DestDirectory, Entry.FullName)) Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName)
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then Continue For '不创建空文件夹
Continue For '不创建空文件夹 Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
Else Entry.ExtractToFile(DestinationPath, True)
Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
Entry.ExtractToFile(DestinationPath, True)
End If
Next Next
End Using End Using
End If End If
@@ -1342,6 +1328,7 @@ Re:
Try Try
Files = Directory.GetFiles(Path) Files = Directory.GetFiles(Path)
Catch ex As DirectoryNotFoundException '#4549 Catch ex As DirectoryNotFoundException '#4549
If Not Directory.Exists(Path) Then Return 0 '可能已被其他线程删除
Log(ex, $"疑似为孤立符号链接,尝试直接删除({Path})", LogLevel.Developer) Log(ex, $"疑似为孤立符号链接,尝试直接删除({Path})", LogLevel.Developer)
Directory.Delete(Path) Directory.Delete(Path)
Return 0 Return 0
@@ -1406,7 +1393,7 @@ RetryDir:
''' 遍历文件夹中的所有文件。 ''' 遍历文件夹中的所有文件。
''' </summary> ''' </summary>
Public Function EnumerateFiles(Directory As String) As IEnumerable(Of FileInfo) Public Function EnumerateFiles(Directory As String) As IEnumerable(Of FileInfo)
Dim Info As New DirectoryInfo(ShortenPath(Directory)) Dim Info As New DirectoryInfo(Directory)
If Not Info.Exists Then Return New List(Of FileInfo) If Not Info.Exists Then Return New List(Of FileInfo)
Return Info.EnumerateFiles("*", SearchOption.AllDirectories) Return Info.EnumerateFiles("*", SearchOption.AllDirectories)
End Function End Function
@@ -1414,13 +1401,15 @@ RetryDir:
''' <summary> ''' <summary>
''' 若路径长度大于指定值,则将长路径转换为短路径。 ''' 若路径长度大于指定值,则将长路径转换为短路径。
''' </summary> ''' </summary>
Public Function ShortenPath(LongPath As String, Optional ShortenThreshold As Integer = 247) As String Public Function ShortenPath(LongPath As String) As String
If LongPath.Length <= ShortenThreshold Then Return LongPath 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) Dim ShortPath As New StringBuilder(260)
GetShortPathName(LongPath, ShortPath, 260) GetShortPathName(LongPath, ShortPath, 260)
Return ShortPath.ToString ShortenPath = ShortPath.ToString
If String.IsNullOrEmpty(ShortenPath) Then Return LongPath
End Function End Function
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As StringBuilder, ByVal cchBuffer As Integer) As Integer Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (lpszLongPath As String, lpszShortPath As StringBuilder, cchBuffer As Integer) As Integer
#End Region #End Region
@@ -1500,7 +1489,7 @@ RetryDir:
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装,请先卸载较新版本的 .NET Framework,然后再尝试安装。" Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装,请先卸载较新版本的 .NET Framework,然后再尝试安装。"
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行,或将目标从 C 盘或桌面挪到其他硬盘。" Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行。"
ElseIf TypeOf InnerEx Is OutOfMemoryException Then ElseIf TypeOf InnerEx Is OutOfMemoryException Then
Return "你的电脑运行内存不足,导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。" Return "你的电脑运行内存不足,导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。"
ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then
@@ -2027,8 +2016,8 @@ RetryDir:
'构造函数 '构造函数
Public Sub New() Public Sub New()
End Sub End Sub
Public Sub New(data As IEnumerable(Of KeyValuePair(Of TKey, TValue))) Public Sub New(Data As IEnumerable(Of KeyValuePair(Of TKey, TValue)))
For Each DataItem In data For Each DataItem In Data
_Dictionary.Add(DataItem.Key, DataItem.Value) _Dictionary.Add(DataItem.Key, DataItem.Value)
Next Next
End Sub End Sub
@@ -2184,7 +2173,7 @@ RetryDir:
''' 返回程序的返回代码,如果运行失败将抛出异常。 ''' 返回程序的返回代码,如果运行失败将抛出异常。
''' </summary> ''' </summary>
Public Function RunAsAdmin(Argument As String) As Integer Public Function RunAsAdmin(Argument As String) As Integer
Dim NewProcess = Process.Start(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument}) Dim NewProcess = StartProcess(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument})
NewProcess.WaitForExit() NewProcess.WaitForExit()
Return NewProcess.ExitCode Return NewProcess.ExitCode
End Function End Function
@@ -2343,46 +2332,21 @@ NextElement:
End Class End Class
''' <summary> ''' <summary>
''' 前台运行文件。 ''' 启动进程并返回进程实例,若失败则抛出异常。
''' 会自动进行长路径处理。
''' </summary> ''' </summary>
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param> Public Function StartProcess(FileName As String, Optional Arguments As String = "") As Process
''' <param name="Arguments">运行参数。</param> Return StartProcess(New ProcessStartInfo With {.FileName = FileName, .Arguments = Arguments})
Public Sub ShellOnly(FileName As String, Optional Arguments As String = "") End Function
Try
FileName = ShortenPath(FileName)
Using Program As New Process
Program.StartInfo.Arguments = Arguments
Program.StartInfo.FileName = FileName
Log("[System] 执行外部命令:" & FileName & " " & Arguments)
Program.Start()
End Using
Catch ex As Exception
Log(ex, "打开文件或程序失败:" & FileName, LogLevel.Msgbox)
End Try
End Sub
''' <summary> ''' <summary>
''' 前台运行文件并返回返回值。 ''' 启动进程并返回进程实例,若失败则抛出异常。
''' 会自动进行长路径处理。
''' </summary> ''' </summary>
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param> Public Function StartProcess(StartInfo As ProcessStartInfo) As Process
''' <param name="Arguments">运行参数。</param> StartInfo.FileName = ShortenPath(StartInfo.FileName)
''' <param name="Timeout">等待该程序结束的最长时间(毫秒)。超时会返回 Result.Timeout。</param> If Not String.IsNullOrEmpty(StartInfo.WorkingDirectory) Then StartInfo.WorkingDirectory = ShortenPath(StartInfo.WorkingDirectory)
Public Function ShellAndGetExitCode(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000) As ProcessReturnValues Log("[System] 启动进程:" & StartInfo.FileName & " " & StartInfo.Arguments)
Try Return Process.Start(StartInfo)
Using Program As New Process
Program.StartInfo.Arguments = Arguments
Program.StartInfo.FileName = FileName
Log("[System] 执行外部命令并等待返回码:" & FileName & " " & Arguments)
Program.Start()
If Program.WaitForExit(Timeout) Then
Return Program.ExitCode
Else
Return ProcessReturnValues.Timeout
End If
End Using
Catch ex As Exception
Log(ex, "执行命令失败:" & FileName, LogLevel.Msgbox)
Return ProcessReturnValues.Fail
End Try
End Function End Function
''' <summary> ''' <summary>
''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。 ''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。
@@ -2390,10 +2354,11 @@ NextElement:
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param> ''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
''' <param name="Arguments">运行参数。</param> ''' <param name="Arguments">运行参数。</param>
''' <param name="Timeout">等待该程序结束的最长时间(毫秒)。超时会抛出错误。</param> ''' <param name="Timeout">等待该程序结束的最长时间(毫秒)。超时会抛出错误。</param>
Public Function ShellAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, Optional WorkingDirectory As String = Nothing) As String Public Function StartProcessAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000,
Optional WorkingDirectory As String = Nothing) As String
Dim Info = New ProcessStartInfo With { Dim Info = New ProcessStartInfo With {
.Arguments = Arguments, .Arguments = Arguments,
.FileName = FileName, .FileName = ShortenPath(FileName),
.UseShellExecute = False, .UseShellExecute = False,
.CreateNoWindow = True, .CreateNoWindow = True,
.RedirectStandardError = True, .RedirectStandardError = True,
@@ -2408,7 +2373,7 @@ NextElement:
End If End If
End If End If
Log("[System] 执行外部命令并等待返回结果:" & FileName & " " & Arguments) Log("[System] 执行外部命令并等待返回结果:" & FileName & " " & Arguments)
Using Program As New Process() With {.StartInfo = Info} Using Program As New Process With {.StartInfo = Info}
Program.Start() Program.Start()
Dim Result As String = Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd Dim Result As String = Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd
Program.WaitForExit(Timeout) Program.WaitForExit(Timeout)
@@ -2510,17 +2475,14 @@ NextElement:
''' <summary> ''' <summary>
''' 尝试从字典中获取某项,如果该项不存在,则返回默认值。 ''' 尝试从字典中获取某项,如果该项不存在,则返回默认值。
''' </summary> ''' </summary>
<Extension> Public Function GetOrDefault(Of TKey, TValue)(Dict As Dictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue <Extension> Public Function GetOrDefault(Of TKey, TValue)(Dict As IDictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue
If Dict.ContainsKey(Key) Then Dim Result As TValue
Return Dict(Key) Return If(Dict.TryGetValue(Key, Result), Result, DefaultValue)
Else
Return DefaultValue
End If
End Function End Function
''' <summary> ''' <summary>
''' 将某项添加到以列表作为值的字典中。 ''' 将某项添加到以列表作为值的字典中。
''' </summary> ''' </summary>
<Extension> Public Sub AddToList(Of TKey, TValue)(Dict As Dictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue) <Extension> Public Sub AddToList(Of TKey, TValue)(Dict As IDictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue)
If Dict.ContainsKey(Key) Then If Dict.ContainsKey(Key) Then
Dict(Key).Add(Value) Dict(Key).Add(Value)
Else Else
@@ -2568,7 +2530,7 @@ NextElement:
Throw New Exception(Url & " 不是一个有效的网址,它必须以 http 开头!") Throw New Exception(Url & " 不是一个有效的网址,它必须以 http 开头!")
End If End If
Log("[System] 正在打开网页:" & Url) Log("[System] 正在打开网页:" & Url)
Process.Start(Url) StartProcess(Url)
Catch ex As Exception Catch ex As Exception
Log(ex, "无法打开网页(" & Url & ")") Log(ex, "无法打开网页(" & Url & ")")
ClipboardSet(Url, False) ClipboardSet(Url, False)
@@ -2582,12 +2544,12 @@ NextElement:
''' </summary> ''' </summary>
Public Sub OpenExplorer(Location As String) Public Sub OpenExplorer(Location As String)
Try Try
Location = ShortenPath(Location.Replace("/", "\").Trim(" "c, """"c)) Location = Location.Replace("/", "\").Trim(" "c, """"c)
Log("[System] 正在打开资源管理器:" & Location) Log("[System] 正在打开资源管理器:" & Location)
If Location.EndsWith("\") Then If Location.EndsWith("\") Then
ShellOnly(Location) StartProcess(Location)
Else Else
ShellOnly("explorer", $"/select,""{Location}""") StartProcess("explorer", $"/select,""{Location}""")
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "打开资源管理器失败,请尝试关闭安全软件(如 360 安全卫士)", LogLevel.Msgbox) Log(ex, "打开资源管理器失败,请尝试关闭安全软件(如 360 安全卫士)", LogLevel.Msgbox)
+63 -49
View File
@@ -1,9 +1,7 @@
Imports System.Net.Http.Headers Imports System.Net.Http.Headers
Imports System.Net.Sockets Imports System.Net.Sockets
Imports System.Runtime.CompilerServices Imports System.Runtime.CompilerServices
Imports System.Security.Policy
Imports System.Threading.Tasks Imports System.Threading.Tasks
Imports CacheCow.Client
Public Module ModNet Public Module ModNet
@@ -75,6 +73,11 @@ Retry:
Catch ex As ThreadInterruptedException Catch ex As ThreadInterruptedException
Throw Throw
Catch ex As Exception Catch ex As Exception
If TypeOf ex Is ResponsedWebException Then
If CType(ex, ResponsedWebException).StatusCode = HttpStatusCode.Forbidden Then Throw
If CType(ex, ResponsedWebException).StatusCode = 429 Then Thread.Sleep(10000) 'Too Many Requests
End If
'重试
Select Case RetryCount Select Case RetryCount
Case 0 Case 0
RetryException = ex RetryException = ex
@@ -245,8 +248,20 @@ RequestFinished:
SecretHeadersSign(Url, Request, SimulateBrowserHeaders) SecretHeadersSign(Url, Request, SimulateBrowserHeaders)
'DNS 解析 'DNS 解析
CancelToken = New CancellationTokenSource(Timeout) CancelToken = New CancellationTokenSource(Timeout)
HostIp = DnsLookup(Request, CancelToken) HostIp = DNSLookup(Request, CancelToken)
If HostIp IsNot Nothing AndAlso Not IPReliability.ContainsKey(HostIp) Then
IPReliability(HostIp) = -0.01 '预先降低一点,这样快速的重复请求会使用不同的 IP 以提高成功率
End If
'发送请求 '发送请求
SyncLock RequestClientLock
'延迟初始化,以避免在程序启动前加载 CacheCow 导致 DLL 加载失败
If RequestClient Is Nothing Then
RequestClient = CacheCow.Client.ClientExtensions.CreateClient(New CacheCow.Client.FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With {
.AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None,
.UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies
})
End If
End SyncLock
Response = RequestClient.SendAsync(Request, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult() Response = RequestClient.SendAsync(Request, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult()
Dim ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult() Dim ResponseStream = Response.Content.ReadAsStreamAsync().GetAwaiter().GetResult()
Dim ResponseBytes As Byte() Dim ResponseBytes As Byte()
@@ -263,18 +278,18 @@ RequestFinished:
Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes) Dim ResponseMessage = If(Encoding, Encoding.UTF8).GetString(ResponseBytes)
Throw New ResponsedWebException( Throw New ResponsedWebException(
$"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)}),{Method},{Url},{HostIp}" & $"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)}),{Method},{Url},{HostIp}" &
If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), ResponseMessage) If(String.IsNullOrEmpty(ResponseMessage), "", vbCrLf & ResponseMessage), Response.StatusCode, ResponseMessage)
End If End If
Catch ex As ThreadInterruptedException Catch ex As ThreadInterruptedException
Throw Throw
Catch ex As ResponsedWebException Catch ex As ResponsedWebException
Throw Throw
Catch ex As DnsLookupException
Throw
Catch ex As Exception Catch ex As Exception
RecordIPReliability(HostIp, -1) RecordIPReliability(HostIp, -1)
If TypeOf ex Is OperationCanceledException Then 'CancellationToken 超时 If TypeOf ex Is OperationCanceledException Then 'CancellationToken 超时
Throw New WebException($"连接服务器超时,请稍后再试,或使用 VPN 改善网络环境({Method}, {Url},{HostIp})", WebExceptionStatus.Timeout) Throw New WebException($"连接服务器超时,请稍后再试,或使用 VPN 改善网络环境({Method}, {Url},IP:{HostIp})", WebExceptionStatus.Timeout)
ElseIf ex.IsNetworkRelated Then
Throw New WebException($"网络请求失败,请稍后再试,或使用 VPN 改善网络环境({Method}, {Url},IP:{HostIp})", WebExceptionStatus.Timeout)
Else Else
Throw New Exception($"网络请求出现意外异常({Method}, {Url},{HostIp})", ex) Throw New Exception($"网络请求出现意外异常({Method}, {Url},{HostIp})", ex)
End If End If
@@ -284,17 +299,15 @@ RequestFinished:
Response?.Dispose() Response?.Dispose()
End Try End Try
End Function End Function
Private RequestClient As HttpClient = ClientExtensions.CreateClient(New FileCacheStore.FileStore(PathTemp & "Cache/Http/"), New HttpClientHandler With { Private RequestClient As HttpClient = Nothing
.AutomaticDecompression = DecompressionMethods.Deflate Or DecompressionMethods.GZip Or DecompressionMethods.None, Private RequestClientLock As New Object
.UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies
})
''' <summary> ''' <summary>
''' 进行 DNS 解析。它仅在选择的 IP 与系统默认的不一致时才对 URL 中的 Host 进行替换。 ''' 进行 DNS 解析。它仅在选择的 IP 与系统默认的不一致时才对 URL 中的 Host 进行替换。
''' 返回请求时应使用的 IP;若为 IPv6,则加上了方括号。 ''' 返回请求时应使用的 IP;若为 IPv6,则加上了方括号。
''' 若解析失败,则返回 Nothing。
''' </summary> ''' </summary>
''' <exception cref="DnsLookupException"></exception> Private Function DNSLookup(Request As HttpRequestMessage, CancelToken As CancellationTokenSource) As String
Private Function DnsLookup(Request As HttpRequestMessage, CancelToken As CancellationTokenSource) As String
Dim GetIPReliability = Function(Key) IPReliability.GetOrDefault(Key.ToString, 0) Dim GetIPReliability = Function(Key) IPReliability.GetOrDefault(Key.ToString, 0)
'初步 DNS 解析 '初步 DNS 解析
Dim Host = Request.RequestUri.Host Dim Host = Request.RequestUri.Host
@@ -303,10 +316,14 @@ RequestFinished:
DnsTask = Dns.GetHostAddressesAsync(Host) DnsTask = Dns.GetHostAddressesAsync(Host)
DnsTask.Wait(CancelToken.Token) DnsTask.Wait(CancelToken.Token)
Catch ex As Exception Catch ex As Exception
Throw New DnsLookupException($"DNS 解析失败,请检查你的网络连接({Host})", ex) Log(ex, $"DNS 解析失败({Host})")
Return Nothing
End Try End Try
Dim Candidates As IPAddress() = DnsTask.Result.ToArray Dim Candidates As IPAddress() = DnsTask.Result.ToArray
If Not Candidates.Any Then Throw New DnsLookupException($"DNS 解析无结果,请检查你的网络连接({Host})") If Not Candidates.Any Then
Log($"[Net] DNS 解析无结果({Host})")
Return Nothing
End If
'若同时存在 IPv4 和 IPv6 地址,仅选择其中一类(因为 GFW 可能只屏蔽了 IPv4 或 IPv6) '若同时存在 IPv4 和 IPv6 地址,仅选择其中一类(因为 GFW 可能只屏蔽了 IPv4 或 IPv6)
Dim IPv4Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetwork).ToArray Dim IPv4Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetwork).ToArray
Dim IPv6Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetworkV6).ToArray Dim IPv6Targets = Candidates.Where(Function(i) i.AddressFamily = AddressFamily.InterNetworkV6).ToArray
@@ -322,20 +339,19 @@ RequestFinished:
Dim TargetIp As String = If(Target.AddressFamily = AddressFamily.InterNetworkV6, $"[{Target}]", Target.ToString) Dim TargetIp As String = If(Target.AddressFamily = AddressFamily.InterNetworkV6, $"[{Target}]", Target.ToString)
If Target IsNot Candidates.First Then If Target IsNot Candidates.First Then
'优选结果与系统默认 IP 不一致,替换域名并设置 Host 头 '优选结果与系统默认 IP 不一致,替换域名并设置 Host 头
If ModeDebug Then Log($"[Net] DNS 结果:{Host} → {Target},所有可能的 IP 与可靠度:{DnsTask.Result.Select(Function(i) $"{i} → {GetIPReliability(i):0.000}").Join(";")}") If ModeDebug Then Log($"[Net] DNS 解析结果:{Host} → {Target},所有可能的 IP 与可靠度:{DnsTask.Result.Select(Function(i) $"{i} → {GetIPReliability(i):0.000}").Join(";")}")
Request.Headers.Host = Host Request.Headers.Host = Host
Dim Builder As New UriBuilder(Request.RequestUri) Dim Builder As New UriBuilder(Request.RequestUri)
Builder.Host = TargetIp Builder.Host = TargetIp
Request.RequestUri = Builder.Uri Request.RequestUri = Builder.Uri
End If End If
If Not IPReliability.ContainsKey(TargetIp) Then IPReliability(TargetIp) = -0.01 '预先降低一点,这样快速的重复请求会使用不同的 IP 以提高成功率
Return TargetIp Return TargetIp
End Function End Function
''' <summary> ''' <summary>
''' 记录每个 IP 地址的请求可靠度。 ''' 记录每个 IP 地址的请求可靠度。
''' 通常取值 -1 ~ +0.5,越高越好。未尝试过的 IP 应视为 0。 ''' 通常取值 -1 ~ +0.5,越高越好。未尝试过的 IP 应视为 0。
''' </summary> ''' </summary>
Private IPReliability As New Dictionary(Of String, Double) Private IPReliability As New SafeDictionary(Of String, Double)
''' <summary> ''' <summary>
''' 根据请求结果,记录 IP 地址的可靠度。 ''' 根据请求结果,记录 IP 地址的可靠度。
''' </summary> ''' </summary>
@@ -346,29 +362,22 @@ RequestFinished:
End Sub End Sub
''' <summary> ''' <summary>
''' DNS 解析失败引发的异常。 ''' 当 HTTP 状态码不指示成功时引发的异常。
''' </summary> ''' 附带额外属性,可用于获取远程服务器给予的回复以及 HTTP 状态码。
Private Class DnsLookupException
Inherits Exception
Public Sub New(Message As String, Optional InnerException As Exception = Nothing)
MyBase.New(Message, InnerException)
End Sub
Public Sub New(Message As String)
MyBase.New(Message)
End Sub
End Class
''' <summary>
''' 当网络请求失败时引发的异常。
''' 附带 Response 属性,可用于获取远程服务器给予的回复。
''' </summary> ''' </summary>
Public Class ResponsedWebException Public Class ResponsedWebException
Inherits WebException Inherits WebException
''' <summary> ''' <summary>
''' HTTP 状态码。
''' </summary>
Public StatusCode As HttpStatusCode
''' <summary>
''' 远程服务器给予的回复。 ''' 远程服务器给予的回复。
''' </summary> ''' </summary>
Public Overloads Property Response As String Public Overloads Property Response As String
Public Sub New(Message As String, Response As String) Public Sub New(Message As String, StatusCode As HttpStatusCode, Response As String)
MyBase.New(Message) MyBase.New(Message)
Me.StatusCode = StatusCode
Me.Response = Response Me.Response = Response
End Sub End Sub
End Class End Class
@@ -750,7 +759,7 @@ RequestFinished:
''' </summary> ''' </summary>
Public Check As FileChecker Public Check As FileChecker
''' <summary> ''' <summary>
''' 下载时是否添加浏览器 UA。 ''' 是否模拟浏览器的 UserAgent 和 Referer。
''' </summary> ''' </summary>
Public SimulateBrowserHeaders As Boolean Public SimulateBrowserHeaders As Boolean
@@ -969,7 +978,7 @@ StartThread:
If ModeDebug OrElse Th.DownloadStart = 0 Then Log($"[Download] {LocalName}:开始,起始点 {Th.DownloadStart},{Th.Source.Url}") If ModeDebug OrElse Th.DownloadStart = 0 Then Log($"[Download] {LocalName}:开始,起始点 {Th.DownloadStart},{Th.Source.Url}")
Dim ResultStream As Stream = Nothing, HttpRequest As HttpRequestMessage = Nothing, Dim ResultStream As Stream = Nothing, HttpRequest As HttpRequestMessage = Nothing,
Response As HttpResponseMessage = Nothing, ResponseStream As Stream = Nothing, Response As HttpResponseMessage = Nothing, ResponseStream As Stream = Nothing,
CancelToken As CancellationTokenSource = Nothing, HostIp As String = "" CancelToken As CancellationTokenSource = Nothing, HostIp As String = Nothing
'部分下载源真的特别慢,并且只需要一个请求,例如 Ping 为 20s,如果增长太慢,就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟 '部分下载源真的特别慢,并且只需要一个请求,例如 Ping 为 20s,如果增长太慢,就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟
'延迟过长会导致某些特别慢的链接迟迟不被掐死 '延迟过长会导致某些特别慢的链接迟迟不被掐死
Dim Timeout As Integer = Math.Min(Math.Max(ConnectAverage, 6000) * (1 + Th.Source.FailCount), 30000) Dim Timeout As Integer = Math.Min(Math.Max(ConnectAverage, 6000) * (1 + Th.Source.FailCount), 30000)
@@ -980,7 +989,7 @@ StartThread:
HttpRequest = New HttpRequestMessage(HttpMethod.Get, Th.Source.Url) HttpRequest = New HttpRequestMessage(HttpMethod.Get, Th.Source.Url)
SecretHeadersSign(Th.Source.Url, HttpRequest, SimulateBrowserHeaders) SecretHeadersSign(Th.Source.Url, HttpRequest, SimulateBrowserHeaders)
CancelToken = New CancellationTokenSource(Timeout) CancelToken = New CancellationTokenSource(Timeout)
HostIp = DnsLookup(HttpRequest, CancelToken) 'DNS 预解析 HostIp = DNSLookup(HttpRequest, CancelToken) 'DNS 预解析
If Not Th.IsFirstThread Then HttpRequest.Headers.Range = New RangeHeaderValue(Th.DownloadStart, Nothing) If Not Th.IsFirstThread Then HttpRequest.Headers.Range = New RangeHeaderValue(Th.DownloadStart, Nothing)
Dim ContentLength As Long = 0 Dim ContentLength As Long = 0
Response = ThreadClient.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult() Response = ThreadClient.SendAsync(HttpRequest, HttpCompletionOption.ResponseHeadersRead, CancelToken.Token).GetAwaiter().GetResult()
@@ -1126,7 +1135,7 @@ SourceBreak:
RecordIPReliability(HostIp, 0.5) RecordIPReliability(HostIp, 0.5)
End If End If
Catch ex As Exception Catch ex As Exception
Log($"[Download] {LocalName}:出错,{If(TypeOf ex Is OperationCanceledException, $"已超时({Timeout}ms)", ex.GetDetail())},{HostIp}") Log($"[Download] {LocalName}:出错,{If(TypeOf ex Is OperationCanceledException, $"已超时({Timeout}ms)", ex.GetDetail())},IP:{HostIp}")
RecordIPReliability(HostIp, -0.7) RecordIPReliability(HostIp, -0.7)
SourceFail(Th, ex, False) SourceFail(Th, ex, False)
Finally Finally
@@ -1864,7 +1873,7 @@ Retry:
End Sub End Sub
Private IsManagerStarted As Boolean = False Private IsManagerStarted As Boolean = False
'Public FileRemainList As New List(Of String) Private DownloadCacheLock As New Object
Private IsDownloadCacheCleared As Boolean = False Private IsDownloadCacheCleared As Boolean = False
''' <summary> ''' <summary>
''' 开始一个下载任务。 ''' 开始一个下载任务。
@@ -1872,15 +1881,19 @@ Retry:
Public Sub Start(Task As LoaderDownload) Public Sub Start(Task As LoaderDownload)
StartManager() StartManager()
'清理缓存 '清理缓存
If Not IsDownloadCacheCleared Then SyncLock DownloadCacheLock '防止同时开启多个下载任务时重复清理
Try If Not IsDownloadCacheCleared Then
DeleteDirectory(PathTemp & "Download") Try
Catch ex As Exception Log("[Net] 开始清理下载缓存")
Log(ex, "清理下载缓存失败") DeleteDirectory(PathTemp & "Download")
End Try Log("[Net] 下载缓存已清理")
Catch ex As Exception
Log(ex, "清理下载缓存失败")
End Try
Directory.CreateDirectory(PathTemp & "Download")
End If
IsDownloadCacheCleared = True IsDownloadCacheCleared = True
End If End SyncLock
Directory.CreateDirectory(PathTemp & "Download")
'文件处理 '文件处理
SyncLock LockFiles SyncLock LockFiles
'添加每个文件 '添加每个文件
@@ -1959,11 +1972,12 @@ Retry:
''' 判断某个 Exception 是否为网络问题所导致。 ''' 判断某个 Exception 是否为网络问题所导致。
''' </summary> ''' </summary>
<Extension> Public Function IsNetworkRelated(Ex As Exception) As Boolean <Extension> Public Function IsNetworkRelated(Ex As Exception) As Boolean
If TypeOf Ex Is DnsLookupException Then Return True
Dim Detail = Ex.GetDetail() Dim Detail = Ex.GetDetail()
If Detail.Contains("(403)") Then Return False If Detail.Contains("(403)") Then Return False
Return {"(408)", "超时", "timeout", "网络请求失败", "连接尝试失败", "远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝"}. Return {
Any(Function(k) Detail.ContainsF(k, True)) "(408)", "超时", "timeout", "网络请求失败", "连接尝试失败", "远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称",
"由于目标计算机积极拒绝", "基础连接已经关闭"
}.Any(Function(k) Detail.ContainsF(k, True))
End Function End Function
End Module End Module
@@ -148,7 +148,7 @@ End Class
''' </summary> ''' </summary>
Public Class ValidateExcept Public Class ValidateExcept
Inherits Validate Inherits Validate
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) Public Property Excepts As New ObjectModel.Collection(Of String)
Public Property ErrorMessage As String Public Property ErrorMessage As String
Public Sub New() Public Sub New()
ErrorMessage = "输入内容不能包含 %" ErrorMessage = "输入内容不能包含 %"
@@ -157,12 +157,15 @@ Public Class ValidateExcept
Me.Excepts = Excepts Me.Excepts = Excepts
Me.ErrorMessage = ErrorMessage Me.ErrorMessage = ErrorMessage
End Sub End Sub
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能包含 %") Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能包含 %")
Me.Excepts = New ObjectModel.Collection(Of String) Me.New(
Me.ErrorMessage = ErrorMessage New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)),
For Each Data As String In Excepts ErrorMessage)
Me.Excepts.Add(Data) End Sub
Next Public Sub New(Excepts As IEnumerable(Of Char), Optional ErrorMessage As String = "输入内容不能包含 %")
Me.New(
New ObjectModel.Collection(Of String)(Excepts.Select(Function(c) c.ToString).ToList),
ErrorMessage)
End Sub End Sub
Public Overrides Function Validate(Str As String) As String Public Overrides Function Validate(Str As String) As String
For Each Ch As String In Excepts For Each Ch As String In Excepts
@@ -181,7 +184,7 @@ End Class
''' </summary> ''' </summary>
Public Class ValidateExceptSame Public Class ValidateExceptSame
Inherits Validate Inherits Validate
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String) Public Property Excepts As New ObjectModel.Collection(Of String)
Public Property ErrorMessage As String Public Property ErrorMessage As String
Public Property IgnoreCase As Boolean = False Public Property IgnoreCase As Boolean = False
Public Sub New() Public Sub New()
@@ -192,17 +195,14 @@ Public Class ValidateExceptSame
Me.IgnoreCase = IgnoreCase Me.IgnoreCase = IgnoreCase
End Sub End Sub
Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
Me.Excepts = New ObjectModel.Collection(Of String) Me.New(
For Each Data As String In Excepts New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)),
Me.Excepts.Add(Data) ErrorMessage, IgnoreCase)
Next
Me.ErrorMessage = ErrorMessage
Me.IgnoreCase = IgnoreCase
End Sub End Sub
Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False) Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
Me.Excepts = New ObjectModel.Collection(Of String) From {Except} Me.New(
Me.ErrorMessage = ErrorMessage New ObjectModel.Collection(Of String) From {Except},
Me.IgnoreCase = IgnoreCase ErrorMessage, IgnoreCase)
End Sub End Sub
Public Overrides Function Validate(Str As String) As String Public Overrides Function Validate(Str As String) As String
If Str Is Nothing Then Return ErrorMessage.Replace("%", "null") If Str Is Nothing Then Return ErrorMessage.Replace("%", "null")
@@ -871,11 +871,11 @@ NextStack:
Sub() Sub()
'弹窗选择:查看日志 '弹窗选择:查看日志
If File.Exists(DirectFile.Value.Key) Then If File.Exists(DirectFile.Value.Key) Then
ShellOnly(DirectFile.Value.Key) StartProcess(DirectFile.Value.Key)
Else Else
Dim FilePath As String = PathTemp & "Crash.txt" Dim FilePath As String = PathTemp & "Crash.txt"
WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf)) WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf))
ShellOnly(FilePath) StartProcess(FilePath)
End If End If
End Sub)) End Sub))
Case 3 Case 3
@@ -98,7 +98,7 @@
If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326 If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
IsJre = Not File.Exists(PathFolder & "javac.exe") IsJre = Not File.Exists(PathFolder & "javac.exe")
'运行 -version '运行 -version
Output = ShellAndGetOutput(PathJava, "-version", 15000).ToLower Output = StartProcessAndGetOutput(PathJava, "-version", 15000).ToLower
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败") If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
If ModeDebug Then Log("[Java] Java 检查输出:" & PathJava & vbCrLf & Output) If ModeDebug Then Log("[Java] Java 检查输出:" & PathJava & vbCrLf & Output)
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java,请在删除 Java 文件夹中的 /lib/ext 文件夹后再试") If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java,请在删除 Java 文件夹中的 /lib/ext 文件夹后再试")
@@ -445,8 +445,8 @@ NoUserJava:
''' 将 Java 按照适用性排序。 ''' 将 Java 按照适用性排序。
''' </summary> ''' </summary>
Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean
Dim PathInfo As New DirectoryInfo(ShortenPath(Path)) Dim PathInfo As New DirectoryInfo(Path)
Dim PathMcInfo As New DirectoryInfo(ShortenPath(PathMcFolder)) Dim PathMcInfo As New DirectoryInfo(PathMcFolder)
'1. 尽量在当前文件夹或当前 Minecraft 文件夹 '1. 尽量在当前文件夹或当前 Minecraft 文件夹
Dim ProgramPathParent As String, MinecraftPathParent As String = "" Dim ProgramPathParent As String, MinecraftPathParent As String = ""
ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName
@@ -646,7 +646,7 @@ Wait:
Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False) Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
Try Try
Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找:" & OriginalPath) Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找:" & OriginalPath)
JavaSearchFolder(New DirectoryInfo(ShortenPath(OriginalPath)), Results, Source, IsFullSearch) JavaSearchFolder(New DirectoryInfo(OriginalPath), Results, Source, IsFullSearch)
Catch ex As UnauthorizedAccessException Catch ex As UnauthorizedAccessException
Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹:" & OriginalPath) Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹:" & OriginalPath)
Catch ex As Exception Catch ex As Exception
@@ -695,7 +695,7 @@ LoginFinish:
'发送登录请求 '发送登录请求
Dim RequestData As New JObject( Dim RequestData As New JObject(
New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True)) New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True))
NetRequestByClient( NetRequestByClientRetry(
Data.Input.BaseUrl & "/validate", HttpMethod.Post, Data.Input.BaseUrl & "/validate", HttpMethod.Post,
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None), Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}}, Headers:={{"Accept-Language", "zh-CN"}},
@@ -1827,9 +1827,9 @@ NextVersion:
''' </summary> ''' </summary>
Private Function GetNativesFolder() As String Private Function GetNativesFolder() As String
Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives" Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives"
If IsGBKEncoding OrElse Result.IsASCII() Then Return Result If IsGBKEncoding OrElse Result.IsASCII() Then Return ShortenPath(Result)
Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives" Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives"
If Result.IsASCII() Then Return Result If Result.IsASCII() Then Return ShortenPath(Result)
Return OsDrive & "ProgramData\PCL\natives" Return OsDrive & "ProgramData\PCL\natives"
End Function End Function
@@ -2159,14 +2159,15 @@ IgnoreCustomSkin:
'执行自定义命令 '执行自定义命令
If CustomCommandGlobal <> "" Then If CustomCommandGlobal <> "" Then
McLaunchLog("正在执行全局自定义命令:" & CustomCommandGlobal) McLaunchLog("正在执行全局自定义命令:" & CustomCommandGlobal)
Dim CustomProcess As New Process Dim CustomProcess As Process = Nothing
Try Try
CustomProcess.StartInfo.FileName = "cmd.exe" CustomProcess = StartProcess(New ProcessStartInfo With {
CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandGlobal & """" .FileName = "cmd.exe",
CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) .Arguments = $"/c ""{CustomCommandGlobal}""",
CustomProcess.StartInfo.UseShellExecute = False .WorkingDirectory = PathMcFolder,
CustomProcess.StartInfo.CreateNoWindow = True .UseShellExecute = False,
CustomProcess.Start() .CreateNoWindow = True
})
If Setup.Get("LaunchAdvanceRunWait") Then If Setup.Get("LaunchAdvanceRunWait") Then
Do Until CustomProcess.HasExited OrElse Loader.IsAborted Do Until CustomProcess.HasExited OrElse Loader.IsAborted
Thread.Sleep(10) Thread.Sleep(10)
@@ -2175,7 +2176,7 @@ IgnoreCustomSkin:
Catch ex As Exception Catch ex As Exception
Log(ex, "执行全局自定义命令失败", LogLevel.Hint) Log(ex, "执行全局自定义命令失败", LogLevel.Hint)
Finally Finally
If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
McLaunchLog("由于取消启动,已强制结束自定义命令 CMD 进程") '#1183 McLaunchLog("由于取消启动,已强制结束自定义命令 CMD 进程") '#1183
CustomProcess.Kill() CustomProcess.Kill()
End If End If
@@ -2183,14 +2184,15 @@ IgnoreCustomSkin:
End If End If
If CustomCommandVersion <> "" Then If CustomCommandVersion <> "" Then
McLaunchLog("正在执行版本自定义命令:" & CustomCommandVersion) McLaunchLog("正在执行版本自定义命令:" & CustomCommandVersion)
Dim CustomProcess As New Process Dim CustomProcess As Process = Nothing
Try Try
CustomProcess.StartInfo.FileName = "cmd.exe" CustomProcess = StartProcess(New ProcessStartInfo With {
CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandVersion & """" .FileName = "cmd.exe",
CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder) .Arguments = $"/c ""{CustomCommandVersion}""",
CustomProcess.StartInfo.UseShellExecute = False .WorkingDirectory = PathMcFolder,
CustomProcess.StartInfo.CreateNoWindow = True .UseShellExecute = False,
CustomProcess.Start() .CreateNoWindow = True
})
If Setup.Get("VersionAdvanceRunWait", Version:=McVersionCurrent) Then If Setup.Get("VersionAdvanceRunWait", Version:=McVersionCurrent) Then
Do Until CustomProcess.HasExited OrElse Loader.IsAborted Do Until CustomProcess.HasExited OrElse Loader.IsAborted
Thread.Sleep(10) Thread.Sleep(10)
@@ -2199,7 +2201,7 @@ IgnoreCustomSkin:
Catch ex As Exception Catch ex As Exception
Log(ex, "执行版本自定义命令失败", LogLevel.Hint) Log(ex, "执行版本自定义命令失败", LogLevel.Hint)
Finally Finally
If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
McLaunchLog("由于取消启动,已强制结束自定义命令 CMD 进程") '#1183 McLaunchLog("由于取消启动,已强制结束自定义命令 CMD 进程") '#1183
CustomProcess.Kill() CustomProcess.Kill()
End If End If
@@ -2210,7 +2212,6 @@ IgnoreCustomSkin:
Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process)) Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process))
'启动信息 '启动信息
Dim GameProcess = New Process()
Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263 Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263
'设置环境变量 '设置环境变量
@@ -2220,16 +2221,15 @@ IgnoreCustomSkin:
StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder) StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder)
'设置其他参数 '设置其他参数
StartInfo.WorkingDirectory = ShortenPath(McVersionCurrent.PathIndie) StartInfo.WorkingDirectory = McVersionCurrent.PathIndie
StartInfo.UseShellExecute = False StartInfo.UseShellExecute = False
StartInfo.RedirectStandardOutput = True StartInfo.RedirectStandardOutput = True
StartInfo.RedirectStandardError = True StartInfo.RedirectStandardError = True
StartInfo.CreateNoWindow = True StartInfo.CreateNoWindow = True
StartInfo.Arguments = McLaunchArgument StartInfo.Arguments = McLaunchArgument
GameProcess.StartInfo = StartInfo
'开始进程 '开始进程
GameProcess.Start() Dim GameProcess = StartProcess(StartInfo)
McLaunchLog("已启动游戏进程:" & McLaunchJavaSelected.PathJava) McLaunchLog("已启动游戏进程:" & McLaunchJavaSelected.PathJava)
If Loader.IsAborted Then If Loader.IsAborted Then
McLaunchLog("由于取消启动,已强制结束游戏进程") '#1631 McLaunchLog("由于取消启动,已强制结束游戏进程") '#1631
@@ -73,7 +73,7 @@ Public Module ModMod
Get Get
If _Name Is Nothing Then Load() If _Name Is Nothing Then Load()
If _Name Is Nothing Then _Name = _ModId If _Name Is Nothing Then _Name = _ModId
If _Name Is Nothing Then _Name = GetFileNameWithoutExtentionFromPath(Path) If _Name Is Nothing Then _Name = IO.Path.GetFileNameWithoutExtension(Path)
Return _Name Return _Name
End Get End Get
Set(value As String) Set(value As String)
@@ -335,7 +335,7 @@ Retry:
File.Delete(Target) File.Delete(Target)
End If End If
Next Next
If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Log("[ModPack] 删除安装整合包文件:" & FileAddress) Log("[ModPack] 删除安装整合包文件:" & FileAddress)
File.Delete(FileAddress) File.Delete(FileAddress)
End If End If
@@ -476,7 +476,7 @@ Retry:
File.Delete(Target) File.Delete(Target)
End If End If
Next Next
If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
Log("[ModPack] 删除安装整合包文件:" & FileAddress) Log("[ModPack] 删除安装整合包文件:" & FileAddress)
File.Delete(FileAddress) File.Delete(FileAddress)
End If End If
@@ -795,7 +795,7 @@ Retry:
Log("[Modpack] 找到压缩包中附带的启动器:" & Launcher) Log("[Modpack] 找到压缩包中附带的启动器:" & Launcher)
If MyMsgBox($"整合包里似乎自带了启动器,是否换用它继续安装?{vbCrLf}即将打开:{Launcher}", "换用整合包启动器?", "换用", "不换用") = 1 Then If MyMsgBox($"整合包里似乎自带了启动器,是否换用它继续安装?{vbCrLf}即将打开:{Launcher}", "换用整合包启动器?", "换用", "不换用") = 1 Then
OpenExplorer(TargetFolder) OpenExplorer(TargetFolder)
ShellOnly(Launcher, "--wait") '要求等待已有的 PCL 退出 StartProcess(Launcher, "--wait") '要求等待已有的 PCL 退出
Log("[Modpack] 为换用整合包中的启动器启动,强制结束程序") Log("[Modpack] 为换用整合包中的启动器启动,强制结束程序")
FrmMain.EndProgram(False) FrmMain.EndProgram(False)
Return Return
+2 -2
View File
@@ -45,9 +45,9 @@
Dim Info As New ProcessStartInfo With { Dim Info As New ProcessStartInfo With {
.Arguments = If(Data.Length >= 2, Data(1), ""), .Arguments = If(Data.Length >= 2, Data(1), ""),
.FileName = Location, .FileName = Location,
.WorkingDirectory = ShortenPath(WorkingDir) .WorkingDirectory = WorkingDir
} }
Process.Start(Info) StartProcess(Info)
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox) Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox)
+2 -2
View File
@@ -79,7 +79,7 @@
If MusicState = MusicStates.Pause Then If MusicState = MusicStates.Pause Then
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
FrmMain.BtnExtraMusic.LogoScale = 0.8 FrmMain.BtnExtraMusic.LogoScale = 0.8
ToolTipText = "已暂停:" & GetFileNameWithoutExtentionFromPath(MusicCurrent) ToolTipText = "已暂停:" & IO.Path.GetFileNameWithoutExtension(MusicCurrent)
If MusicAllList.Count > 1 Then If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键恢复播放,右键播放下一曲。" ToolTipText += vbCrLf & "左键恢复播放,右键播放下一曲。"
Else Else
@@ -88,7 +88,7 @@
Else Else
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
FrmMain.BtnExtraMusic.LogoScale = 1 FrmMain.BtnExtraMusic.LogoScale = 1
ToolTipText = "正在播放:" & GetFileNameWithoutExtentionFromPath(MusicCurrent) ToolTipText = "正在播放:" & IO.Path.GetFileNameWithoutExtension(MusicCurrent)
If MusicAllList.Count > 1 Then If MusicAllList.Count > 1 Then
ToolTipText += vbCrLf & "左键暂停,右键播放下一曲。" ToolTipText += vbCrLf & "左键暂停,右键播放下一曲。"
Else Else
+8 -7
View File
@@ -81,13 +81,14 @@ Friend Module ModSecret
''' 设置 Headers 的 UA、Referer。 ''' 设置 Headers 的 UA、Referer。
''' </summary> ''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False) Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False)
If Req.Headers.UserAgent.Any Then Return If Not Req.Headers.UserAgent.Any Then
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Req.Headers.Add("User-Agent", "LogStatistic") '#4951 Req.Headers.Add("User-Agent", "LogStatistic") '#4951
ElseIf SimulateBrowserHeaders Then ElseIf SimulateBrowserHeaders Then
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36") Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36")
Else Else
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}") Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}")
End If
End If End If
If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/") If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey) If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey)
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号 ' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*” ' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.10.7.0")> <Assembly: AssemblyVersion("2.10.8.0")>
<Assembly: AssemblyFileVersion("2.10.7.0")> <Assembly: AssemblyFileVersion("2.10.8.0")>
<Assembly: NeutralResourcesLanguage("")> <Assembly: NeutralResourcesLanguage("")>
@@ -424,7 +424,7 @@
If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder) If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder)
If Not Target.Contains("\") Then Return If Not Target.Contains("\") Then Return
'构造步骤加载器 '构造步骤加载器
Dim LoaderName As String = Desc & "下载:" & GetFileNameWithoutExtentionFromPath(Target) & " " Dim LoaderName As String = Desc & "下载:" & IO.Path.GetFileNameWithoutExtension(Target) & " "
If Target <> DefaultFolder Then CachedFolder(Project.Type) = GetPathFromFullPath(Target) If Target <> DefaultFolder Then CachedFolder(Project.Type) = GetPathFromFullPath(Target)
Dim Loaders As New List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True}) Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True})
@@ -171,6 +171,7 @@
<TextBlock Width="120" Margin="0,1.5" Text="Ciallo~(∠?ω" /> <TextBlock Width="120" Margin="0,1.5" Text="Ciallo~(∠?ω" />
<TextBlock Width="120" Margin="0,1.5" Text="九十九" /> <TextBlock Width="120" Margin="0,1.5" Text="九十九" />
<TextBlock Width="120" Margin="0,1.5" Text="Guuzen" /> <TextBlock Width="120" Margin="0,1.5" Text="Guuzen" />
<TextBlock Width="120" Margin="0,1.5" Text="极光" />
<TextBlock Width="120" Margin="0,1.5" Text="9331" /> <TextBlock Width="120" Margin="0,1.5" Text="9331" />
<TextBlock Width="120" Margin="0,1.5" Text="钱程" /> <TextBlock Width="120" Margin="0,1.5" Text="钱程" />
<TextBlock Width="120" Margin="0,1.5" Text="杏坂和人" /> <TextBlock Width="120" Margin="0,1.5" Text="杏坂和人" />
@@ -344,14 +344,11 @@ Public Class MyLocalModItem
End If End If
'标题与描述 '标题与描述
Dim DescFileName As String Dim DescFileName As String
Select Case Entry.State If Entry.State = McMod.McModState.Fine OrElse Entry.State = McMod.McModState.Disabled Then
Case McMod.McModState.Fine DescFileName = IO.Path.GetFileNameWithoutExtension(Entry.Path)
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path) Else
Case McMod.McModState.Disabled DescFileName = GetFileNameFromPath(Entry.Path)
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", "")) End If
Case Else 'McMod.McModState.Unavailable
DescFileName = GetFileNameFromPath(Entry.Path)
End Select
Dim NewDescription As String Dim NewDescription As String
If Setup.Get("ToolModLocalNameStyle") = 1 Then If Setup.Get("ToolModLocalNameStyle") = 1 Then
'标题显示文件名,详情显示译名 '标题显示文件名,详情显示译名