2025.7.18.0

API.Instagram: fix special folder issue
API.OnlyFans: bypass unpurchased videos; add support for GIF files
API.Reddit: add OAuth credentials validation; add extended 429 error handling
API.Xhamster: remove 'UserOptions' function ('SiteSettings'); add support for downloading 'moments'
API.XVIDEOS: remove 'UserOptions' function ('SiteSettings'); remove 'UserExchangeOptions' class
Add 'EditorExchangeOptionsBase_P' and update base classes for user options
This commit is contained in:
Andy
2025-07-18 20:29:35 +03:00
parent 24ad338c60
commit 05772a9fc4
19 changed files with 251 additions and 148 deletions

View File

@@ -1,3 +1,21 @@
# 2025.7.18.0
*2025-07-18*
- Added
- Sites:
- OnlyFans:
- **bypass unpurchased videos**
- support for GIF files
- Reddit: extended `429` error handling
- Xhamster: support for downloading 'moments'
- Minor improvements
- Updated
- yt-dlp up to version **2025.06.30**
- gallery-dl up to version **1.30.0**
- Fixed
- Minor bugs
# 2025.6.12.0
*2025-06-12*

View File

@@ -0,0 +1,43 @@
' Copyright (C) Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.Plugin.Attributes
Namespace API.Base
Friend Interface IPSite
Property QueryString As String
End Interface
Friend Class EditorExchangeOptionsBase_P : Inherits EditorExchangeOptionsBase : Implements IPSite
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property UserName As String
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadText As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadTextPosts As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadTextSpecialFolder As Boolean
<PSetting(Address:=SettingAddress.User, Caption:="Query",
ToolTip:="Query string. Don't change this field when creating a user! Change it only for the same request.")>
Friend Property QueryString As String Implements IPSite.QueryString
Friend Sub New()
DisableBase()
End Sub
Friend Sub New(ByVal u As UserDataBase)
MyBase.New(u)
DisableBase()
If TypeOf u Is IPSite Then QueryString = DirectCast(u, IPSite).QueryString
End Sub
Friend Sub New(ByVal s As SiteSettingsBase)
MyBase.New(s)
DisableBase()
End Sub
Friend Overridable Sub Apply(ByRef u As IPSite)
ApplyBase(u)
u.QueryString = QueryString
End Sub
Protected Overridable Sub DisableBase()
_ApplyBase_Name = False
_ApplyBase_Text = False
End Sub
End Class
End Namespace

View File

@@ -2288,6 +2288,7 @@ stxt:
End Function
#End Region
#Region "Errors functions"
''' <summary>ToStringForLog(): Message</summary>
Protected Sub LogError(ByVal ex As Exception, ByVal Message As String, Optional ByVal e As ErrorsDescriber = Nothing)
ErrorsDescriber.Execute(If(e.Exists, e, New ErrorsDescriber(EDP.SendToLog)), ex, $"{ToStringForLog()}: {Message}")
End Sub

View File

@@ -1151,12 +1151,30 @@ NextPageBlock:
If TryExtractImage Then
t = 1
abstractDecision = True
If Not SpecialFolder.IsEmptyString AndAlso PutImageVideoFolder Then
Dim endsAbs As Boolean = SpecialFolder.EndsWith("*")
If endsAbs Then SpecialFolder = SpecialFolder.TrimEnd("*")
If Not SpecialFolder.IsEmptyString Then SpecialFolder = $"{SpecialFolder.TrimEnd("\")}\{VideoFolderName}{IIf(Not endsAbs, "*", String.Empty)}"
If endsAbs Then SpecialFolder &= "*"
Dim endsAbs As Boolean
Dim newFolderName$
If PutImageVideoFolder Then
If SpecialFolder.IsEmptyString Then
newFolderName = $"{VideoFolderName}\*"
Else
endsAbs = SpecialFolder.EndsWith("*")
SpecialFolder = SpecialFolder.TrimEnd({CChar("\"), CChar("*")})
If Not endsAbs Then SpecialFolder = $"{SpecialFolder}\{VideoFolderName}"
newFolderName = $"{SpecialFolder}*"
End If
'Dim endsAbs As Boolean = SpecialFolder.EndsWith("*")
'If endsAbs Then SpecialFolder = SpecialFolder.TrimEnd("*")
'If Not SpecialFolder.IsEmptyString Then SpecialFolder = $"{SpecialFolder.TrimEnd("\")}\{VideoFolderName}{IIf(Not endsAbs, "*", String.Empty)}"
'If endsAbs Then SpecialFolder &= "*"
ElseIf Not SpecialFolder.IsEmptyString Then
endsAbs = SpecialFolder.EndsWith("*")
SpecialFolder = SpecialFolder.TrimEnd({CChar("\"), CChar("*")})
If endsAbs Then SpecialFolder = $"{SpecialFolder}\Photos"
newFolderName = $"{SpecialFolder}*"
Else
newFolderName = SpecialFolder
End If
SpecialFolder = newFolderName
ElseIf t = -1 And InitialType = 8 And ObtainMedia_AllowAbstract Then
If n.Contains(vid) Then
t = 2

View File

@@ -431,7 +431,7 @@ Namespace API.OnlyFans
Result = False
With n("media")
If .ListExists Then
For Each m In .Self
For Each m As EContainer In .Self
postUrl = GetMediaURL(m)
'If IsHL Then
' 'postUrl = m.Value({"files", "source"}, "url")
@@ -440,10 +440,11 @@ Namespace API.OnlyFans
' 'postUrl = m.Value({"source"}, "source").IfNullOrEmpty(m.Value("full"))
' postUrl = GetMediaURL(m)
'End If
If m.Value("canView").FromXML(Of Boolean)(True) Then
postUrlBase = String.Empty
Select Case m.Value("type")
Case "photo" : t = UTypes.Picture : ext = "jpg"
Case "video"
Case "video", "gif"
t = UTypes.Video
ext = "mp4"
If postUrl.IsEmptyString And Not IsHL And TryUseOFS Then
@@ -467,6 +468,7 @@ Namespace API.OnlyFans
Result = True
mList.Add(media)
End If
End If
Next
End If
End With

View File

@@ -15,7 +15,7 @@ Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.PornHub
Friend Class UserData : Inherits UserDataBase
Friend Class UserData : Inherits UserDataBase : Implements IPSite
Private Const UrlPattern As String = "https://www.pornhub.com/{0}"
#Region "Declarations"
#Region "XML names"
@@ -140,7 +140,7 @@ Namespace API.PornHub
End Get
End Property
Friend Property SiteMode As SiteModes = SiteModes.User
Friend Property QueryString As String
Friend Property QueryString As String Implements IPSite.QueryString
Get
If IsUser Then
Return String.Empty
@@ -163,17 +163,7 @@ Namespace API.PornHub
Return New UserExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
DownloadUHD = .DownloadUHD
DownloadUploaded = .DownloadUploaded
DownloadTagged = .DownloadTagged
DownloadPrivate = .DownloadPrivate
DownloadFavorite = .DownloadFavorite
DownloadGifs = .DownloadGifs
QueryString = .QueryString
End With
End If
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
#End Region
Private ReadOnly Property MySettings As SiteSettings

View File

@@ -6,9 +6,10 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.PornHub
Friend Class UserExchangeOptions : Inherits Xhamster.UserExchangeOptions
Friend Class UserExchangeOptions : Inherits EditorExchangeOptionsBase_P
<PSetting(NameOf(SiteSettings.DownloadUHD), NameOf(MySettings))>
Friend Property DownloadUHD As Boolean
<PSetting(NameOf(SiteSettings.DownloadUploaded), NameOf(MySettings))>
@@ -23,16 +24,17 @@ Namespace API.PornHub
Friend Property DownloadGifs As Boolean
Private ReadOnly Property MySettings As SiteSettings
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
DownloadUHD = u.DownloadUHD
DownloadUploaded = u.DownloadUploaded
DownloadTagged = u.DownloadTagged
DownloadPrivate = u.DownloadPrivate
DownloadFavorite = u.DownloadFavorite
DownloadGifs = u.DownloadGifs
QueryString = u.QueryString
MySettings = u.HOST.Source
End Sub
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
Dim v As CheckState = CInt(s.DownloadGifs.Value)
DownloadUHD = s.DownloadUHD.Value
DownloadUploaded = s.DownloadUploaded.Value
@@ -42,5 +44,16 @@ Namespace API.PornHub
DownloadGifs = Not v = CheckState.Unchecked
MySettings = s
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
MyBase.Apply(u)
With DirectCast(u, UserData)
.DownloadUHD = DownloadUHD
.DownloadUploaded = DownloadUploaded
.DownloadTagged = DownloadTagged
.DownloadPrivate = DownloadPrivate
.DownloadFavorite = DownloadFavorite
.DownloadGifs = DownloadGifs
End With
End Sub
End Class
End Namespace

View File

@@ -9,6 +9,7 @@
Imports SCrawler.API.Base
Imports SCrawler.Plugin
Imports SCrawler.Plugin.Attributes
Imports System.Reflection
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Clients.Base
Imports PersonalUtilities.Tools.Web.Documents.JSON
@@ -58,6 +59,48 @@ Namespace API.Reddit
Return {AuthUserName.Value, AuthPassword.Value, ApiClientID.Value, ApiClientSecret.Value}.All(Function(v$) Not v.IsEmptyString)
End Get
End Property
<PropertiesDataChecker({NameOf(AuthUserName), NameOf(AuthPassword), NameOf(ApiClientID), NameOf(ApiClientSecret),
NameOf(UseTokenForTimelines), NameOf(UseCookiesForTimelines)})>
Private Function OAuthCredentialsChecker(ByVal p As IEnumerable(Of PropertyData)) As Boolean
Const msgTitle$ = "OAuth credentials"
If p.ListExists Then
Dim useToken As Boolean = False, useCookies As Boolean = False
Dim d$ = String.Empty
Dim dCount As Byte = 0
Dim members As IEnumerable(Of MemberInfo) = GetObjectMembers(Me)
Dim getPropText As Func(Of String, String) = Function(name) members.First(Function(m) m.Name = name).GetCustomAttribute(Of PropertyOption).ControlText
Dim dataStr As Action(Of String, String) = Sub(dd, name) If dd.IsEmptyString Then d.StringAppendLine(getPropText(name)) : dCount += 1
For Each pp As PropertyData In p
Select Case pp.Name
Case NameOf(AuthUserName) : dataStr(pp.Value, NameOf(AuthUserName))
Case NameOf(AuthPassword) : dataStr(pp.Value, NameOf(AuthPassword))
Case NameOf(ApiClientID) : dataStr(pp.Value, NameOf(ApiClientID))
Case NameOf(ApiClientSecret) : dataStr(pp.Value, NameOf(ApiClientSecret))
Case NameOf(UseTokenForTimelines) : useToken = pp.Value
Case NameOf(UseCookiesForTimelines) : useCookies = pp.Value
Case Else : Throw New ArgumentException($"Property name '{pp.Name}' is not implemented", "Property Name")
End Select
Next
If d.IsEmptyString Then
If useToken And useCookies Then
Return True
Else
If Not useToken Then d.StringAppendLine(getPropText(NameOf(UseTokenForTimelines)))
If Not useCookies Then d.StringAppendLine(getPropText(NameOf(UseCookiesForTimelines)))
MsgBoxE({$"You need to check the following options:{vbCr}{d}", msgTitle}, vbCritical)
Return False
End If
ElseIf dCount = 4 Then
Return MsgBoxE({$"You haven't configured OAuth. It's highly recommended to use OAuth.{vbCr}Do you still want to continue?", msgTitle},
vbExclamation,,, {"Process", "Cancel"}) = 0
Else
MsgBoxE({$"You haven't filled in the following fields:{vbCr}{d}.{vbCr}{vbCr}" &
"To use OAuth authorization, you must fill in all authorization fields.", msgTitle}, vbCritical)
Return False
End If
End If
Return True
End Function
#End Region
#Region "Other"
<PropertyOption(ControlText:="Use M3U8", ControlToolTip:="Use M3U8 or mp4 for Reddit videos", IsAuth:=False), PXML, PClonable>
@@ -233,23 +276,6 @@ Namespace API.Reddit
End Sub
#End Region
#Region "Token"
<PropertiesDataChecker({NameOf(AuthUserName), NameOf(AuthPassword), NameOf(ApiClientID), NameOf(ApiClientSecret)})>
Private Function TokenPropertiesChecker(ByVal p As IEnumerable(Of PropertyData)) As Boolean
If p.ListExists Then
Dim wrong As New List(Of String)
For i% = 0 To p.Count - 1
If CStr(p(i).Value).IsEmptyString Then wrong.Add(p(i).Name)
Next
If wrong.Count > 0 And wrong.Count <> 4 Then
MsgBoxE({$"You have not completed the following fields: {wrong.ListToString}." & vbCr &
"To use OAuth authorization, all authorization fields must be filled in.", "Validate token fields"}, vbCritical)
Return False
Else
Return True
End If
End If
Return False
End Function
Private Function UpdateTokenIfRequired() As Boolean
UpdateRedGifsToken()
If (CBool(UseTokenForTimelines.Value) Or CBool(UseTokenForSavedPosts.Value)) AndAlso CredentialsExists Then

View File

@@ -135,6 +135,7 @@ Namespace API.Reddit
DownloadTextSpecialFolder = .DownloadTextSpecialFolder
RedGifsAccount = .RedGifsAccount
RedditAccount = .RedditAccount
If TypeOf Options Is RedditViewExchange Then DirectCast(Options, RedditViewExchange).ApplyBase(Me)
End With
End If
End Sub
@@ -1089,25 +1090,28 @@ Namespace API.Reddit
ElseIf .StatusCode = HttpStatusCode.Forbidden Then '403
UserSuspended = True
ElseIf .StatusCode = HttpStatusCode.BadGateway Or .StatusCode = HttpStatusCode.ServiceUnavailable Then '502, 503
MyMainLOG = $"{ToStringForLog()}: [{CInt(Responser.StatusCode)}] Reddit is currently unavailable"
LogError(Nothing, $"[{CInt(Responser.StatusCode)}] Reddit is currently unavailable")
Throw New Plugin.ExitException With {.Silent = True}
ElseIf .StatusCode = HttpStatusCode.GatewayTimeout Then '504
Return 1
ElseIf .StatusCode = HttpStatusCode.Unauthorized Then '401
MyMainLOG = $"{ToStringForLog()}: [{CInt(Responser.StatusCode)}] Reddit credentials expired"
LogError(Nothing, $"[{CInt(Responser.StatusCode)}] Reddit credentials expired")
MySiteSettings.SessionInterrupted = True
Throw New Plugin.ExitException With {.Silent = True}
ElseIf .StatusCode = HttpStatusCode.InternalServerError Then '500
If Not IsNothing(EObj) AndAlso IsNumeric(EObj) AndAlso CInt(EObj) = HttpStatusCode.InternalServerError Then Return 1
Return HttpStatusCode.InternalServerError
ElseIf .StatusCode = 429 And IsSavedPosts And Err429Count = 0 Then
ElseIf .StatusCode = 429 And IsSavedPosts And Err429Count = 0 Then '429 (saved)
Err429Count += 1
Return 429
ElseIf .StatusCode = 429 AndAlso
((Not IsSavedPosts And CBool(MySiteSettings.UseTokenForTimelines.Value)) Or (IsSavedPosts And CBool(MySiteSettings.UseTokenForSavedPosts.Value))) AndAlso
Not MySiteSettings.CredentialsExists Then '429
MyMainLOG = $"{ToStringForLog()}: [{CInt(Responser.StatusCode)}] You should use OAuth authorization or disable " &
IIf(IsSavedPosts, "token usage for downloading saved posts", "the use of token and cookies for downloading timelines")
ElseIf .StatusCode = 429 Then '429 (all)
If ((Not IsSavedPosts And CBool(MySiteSettings.UseTokenForTimelines.Value)) Or (IsSavedPosts And CBool(MySiteSettings.UseTokenForSavedPosts.Value))) AndAlso
Not MySiteSettings.CredentialsExists Then
LogError(Nothing, $"[{CInt(Responser.StatusCode)}] You should use OAuth authorization or disable " &
IIf(IsSavedPosts, "token usage for downloading saved posts", "the use of token and cookies for downloading timelines"))
Else
LogError(Nothing, "Too many requests (429). Try again later!")
End If
MySiteSettings.SessionInterrupted = True
Throw New Plugin.ExitException With {.Silent = True}
Else

View File

@@ -14,7 +14,7 @@ Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools
Imports PersonalUtilities.Tools.Web.Documents.JSON
Namespace API.ThisVid
Friend Class UserData : Inherits UserDataBase
Friend Class UserData : Inherits UserDataBase : Implements IPSite
#Region "XML names"
Private Const Name_DownloadPublic As String = "DownloadPublic"
Private Const Name_DownloadPrivate As String = "DownloadPrivate"
@@ -51,7 +51,7 @@ Namespace API.ThisVid
Return {SearchRequestLabelName}
End Get
End Property
Friend Property QueryString As String
Friend Property QueryString As String Implements IPSite.QueryString
Get
If SiteMode = SiteModes.User Then
Return String.Empty
@@ -161,15 +161,7 @@ Namespace API.ThisVid
Return New UserExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
DownloadPublic = .DownloadPublic
DownloadPrivate = .DownloadPrivate
DownloadFavourite = .DownloadFavourite
DifferentFolders = .DifferentFolders
QueryString = .QueryString
End With
End If
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Initializer"

View File

@@ -6,9 +6,10 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.ThisVid
Friend Class UserExchangeOptions : Inherits Xhamster.UserExchangeOptions
Friend Class UserExchangeOptions : Inherits EditorExchangeOptionsBase_P
<PSetting(Caption:="Download public videos")>
Friend Property DownloadPublic As Boolean = True
<PSetting(Caption:="Download private videos")>
@@ -19,6 +20,7 @@ Namespace API.ThisVid
Friend Property DifferentFolders As Boolean = True
Private ReadOnly Property MySettings As SiteSettings
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
DownloadPublic = s.DownloadPublic.Value
DownloadPrivate = s.DownloadPrivate.Value
DownloadFavourite = s.DownloadFavourite.Value
@@ -26,12 +28,21 @@ Namespace API.ThisVid
MySettings = s
End Sub
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
DownloadPublic = u.DownloadPublic
DownloadPrivate = u.DownloadPrivate
DownloadFavourite = u.DownloadFavourite
DifferentFolders = u.DifferentFolders
QueryString = u.QueryString
MySettings = u.HOST.Source
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
MyBase.Apply(u)
With DirectCast(u, UserData)
.DownloadPublic = DownloadPublic
.DownloadPrivate = DownloadPrivate
.DownloadFavourite = DownloadFavourite
.DifferentFolders = DifferentFolders
End With
End Sub
End Class
End Namespace

View File

@@ -50,6 +50,7 @@ Namespace API.XVIDEOS
_SubscriptionsAllowed = True
UrlPatternUser = "https://xvideos.com/{0}"
UserOptionsType = GetType(EditorExchangeOptionsBase_P)
End Sub
Friend Overrides Sub EndInit()
Domains.PopulateInitialDomains(SiteDomains.Value)
@@ -152,14 +153,6 @@ Namespace API.XVIDEOS
Return Nothing
End Function
#End Region
#Region "UserOptions"
Friend Overrides Sub UserOptions(ByRef Options As Object, ByVal OpenForm As Boolean)
If Options Is Nothing OrElse Not TypeOf Options Is UserExchangeOptions Then Options = New UserExchangeOptions
If OpenForm Then
Using f As New InternalSettingsForm(Options, Me, False) : f.ShowDialog() : End Using
End If
End Sub
#End Region
#Region "IDisposable Support"
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If Not disposedValue And disposing Then _Domains.Dispose()

View File

@@ -15,7 +15,7 @@ Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.XVIDEOS
Friend Class UserData : Inherits UserDataBase
Friend Class UserData : Inherits UserDataBase : Implements IPSite
#Region "XML names"
Private Const Name_PersonType As String = "PersonType"
#End Region
@@ -62,7 +62,7 @@ Namespace API.XVIDEOS
Return {SearchRequestLabelName}
End Get
End Property
Friend Property QueryString As String
Friend Property QueryString As String Implements IPSite.QueryString
Get
If SiteMode = SiteModes.User Then
Return String.Empty
@@ -82,10 +82,10 @@ Namespace API.XVIDEOS
#End Region
#Region "Load"
Friend Overrides Function ExchangeOptionsGet() As Object
Return New UserExchangeOptions(Me)
Return New EditorExchangeOptionsBase_P(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then QueryString = DirectCast(Obj, UserExchangeOptions).QueryString
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptionsBase_P Then DirectCast(Obj, EditorExchangeOptionsBase_P).Apply(Me)
End Sub
Private Function UpdateUserOptions(Optional ByVal Force As Boolean = False, Optional ByVal NewUrl As String = Nothing) As Boolean
If Not Force OrElse (Not SiteMode = SiteModes.User AndAlso Not NewUrl.IsEmptyString AndAlso MyFileSettings.Exists) Then

View File

@@ -1,17 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Namespace API.XVIDEOS
Friend Class UserExchangeOptions : Inherits Xhamster.UserExchangeOptions
Friend Sub New()
End Sub
Friend Sub New(ByVal u As UserData)
QueryString = u.QueryString
End Sub
End Class
End Namespace

View File

@@ -51,6 +51,7 @@ Namespace API.Xhamster
UrlPatternUser = "https://xhamster.com/{0}/{1}"
UserRegex = RParams.DMS($"/({UserOption}|{ChannelOption}|{P_Creators})/([^/]+)(\Z|.*)", 0, RegexReturn.ListByMatch)
ImageVideoContains = "xhamster"
UserOptionsType = GetType(UserExchangeOptions)
End Sub
Friend Overrides Sub EndInit()
Domains.PopulateInitialDomains(SiteDomains.Value)
@@ -163,14 +164,6 @@ Namespace API.Xhamster
Return Nothing
End Function
#End Region
#Region "UserOptions"
Friend Overrides Sub UserOptions(ByRef Options As Object, ByVal OpenForm As Boolean)
If Options Is Nothing OrElse Not TypeOf Options Is UserExchangeOptions Then Options = New UserExchangeOptions
If OpenForm Then
Using f As New InternalSettingsForm(Options, Me, False) : f.ShowDialog() : End Using
End If
End Sub
#End Region
#Region "IDisposable Support"
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If Not disposedValue And disposing Then _Domains.Dispose()

View File

@@ -16,10 +16,11 @@ Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.Xhamster
Friend Class UserData : Inherits UserDataBase
Friend Class UserData : Inherits UserDataBase : Implements IPSite
#Region "XML names"
Private Const Name_Gender As String = "Gender"
Private Const Name_IsCreator As String = "IsCreator"
Private Const Name_GetMoments As String = "GetMoments"
#End Region
#Region "Declarations"
Friend Overrides ReadOnly Property FeedIsUser As Boolean
@@ -29,6 +30,7 @@ Namespace API.Xhamster
End Property
Friend Property IsChannel As Boolean = False
Friend Property IsCreator As Boolean = False
Friend Property GetMoments As Boolean = False
Friend Property Gender As String = String.Empty
Friend Property SiteMode As SiteModes = SiteModes.User
Friend Property Arguments As String = String.Empty
@@ -47,7 +49,7 @@ Namespace API.Xhamster
Return {SearchRequestLabelName}
End Get
End Property
Friend Property QueryString As String
Friend Property QueryString As String Implements IPSite.QueryString
Get
If SiteMode = SiteModes.User Then
Return String.Empty
@@ -143,6 +145,7 @@ Namespace API.Xhamster
If Loading Then
IsChannel = .Value(Name_IsChannel).FromXML(Of Boolean)(False)
IsCreator = .Value(Name_IsCreator).FromXML(Of Boolean)(False)
GetMoments = .Value(Name_GetMoments).FromXML(Of Boolean)(False)
Gender = .Value(Name_Gender)
SiteMode = .Value(Name_SiteMode).FromXML(Of Integer)(SiteModes.User)
Arguments = .Value(Name_Arguments)
@@ -155,6 +158,7 @@ Namespace API.Xhamster
End If
.Add(Name_IsChannel, IsChannel.BoolToInteger)
.Add(Name_IsCreator, IsCreator.BoolToInteger)
.Add(Name_GetMoments, GetMoments.BoolToInteger)
.Add(Name_TrueName, NameTrue(True))
.Add(Name_Gender, Gender)
.Add(Name_SiteMode, CInt(SiteMode))
@@ -169,7 +173,7 @@ Namespace API.Xhamster
Return New UserExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then QueryString = DirectCast(Obj, UserExchangeOptions).QueryString
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Initializer"
@@ -237,21 +241,23 @@ Namespace API.Xhamster
_PageVideosRepeat = 0
SessionPosts.Clear()
Responser.CookiesAsHeader = True
If DownloadVideos Then DownloadData(1, True, Token)
If DownloadVideos Then DownloadData(1, True, False, Token)
If GetMoments Then DownloadData(1, True, True, Token)
If Not IsChannel And Not IsCreator And DownloadImages And Not IsSubscription Then
DownloadData(1, False, Token)
DownloadData(1, False, False, Token)
ReparsePhoto(Token)
End If
Finally
Responser.CookiesAsHeader = False
End Try
End Sub
Private Overloads Sub DownloadData(ByVal Page As Integer, ByVal IsVideo As Boolean, ByVal Token As CancellationToken)
Private Overloads Sub DownloadData(ByVal Page As Integer, ByVal IsVideo As Boolean, ByVal GetMoments As Boolean, ByVal Token As CancellationToken)
Dim URL$ = String.Empty
Try
Dim MaxPage% = -1
Dim Type As UTypes = IIf(IsVideo, UTypes.VideoPre, UTypes.Picture)
Dim mPages$ = IIf(IsVideo, "maxVideoPages", "maxPhotoPages")
Dim specFolder$ = IIf(GetMoments, "Moments*", String.Empty)
Dim listNode$()
Dim containerNodes As New List(Of String())
Dim skipped As Boolean = False
@@ -271,6 +277,7 @@ Namespace API.Xhamster
End If
ElseIf Not SiteMode = SiteModes.Search Then
If IsVideo Then
If GetMoments Then containerNodes.Add({"momentListComponent", "videoThumbProps"})
containerNodes.Add({"trendingVideoListComponent", "models"})
containerNodes.Add({"pagesCategoryComponent", "trendingVideoListProps", "models"})
containerNodes.Add({"trendingVideoSectionComponent", "videoModels"})
@@ -294,7 +301,7 @@ Namespace API.Xhamster
ElseIf IsCreator Or SiteMode = SiteModes.Tags Or SiteMode = SiteModes.Categories Or SiteMode = SiteModes.Pornstars Then
URL = GetNonUserUrl(Page)
Else
URL = $"https://xhamster.com/users/{NameTrue}/{IIf(IsVideo, "videos", "photos")}{IIf(Page = 1, String.Empty, $"/{Page}")}"
URL = $"https://xhamster.com/users/{NameTrue}/{If(GetMoments, "moments", IIf(IsVideo, "videos", "photos"))}{IIf(Page = 1, String.Empty, $"/{Page}")}"
End If
ThrowAny(Token)
@@ -314,7 +321,7 @@ Namespace API.Xhamster
ProgressPre.ChangeMax(.Count)
For Each e As EContainer In .Self
ProgressPre.Perform()
m = ExtractMedia(e, Type)
m = ExtractMedia(e, Type,,,, specFolder)
If Not m.URL.IsEmptyString Then
pids.ListAddValue(m.Post.ID, LNC)
If m.File.IsEmptyString Then Continue For
@@ -374,7 +381,7 @@ Namespace API.Xhamster
(MaxPage = -1 Or Page < MaxPage) And
((Not _TempMediaList.Count = cBefore Or skipped) And (IsUser Or Page < 1000))
) Or
(IsChannel Or (Not IsUser And Page < 1000 And prevPostsFound And Not newPostsFound))) Then DownloadData(Page + 1, IsVideo, Token)
(IsChannel Or (Not IsUser And Page < 1000 And prevPostsFound And Not newPostsFound))) Then DownloadData(Page + 1, IsVideo, GetMoments, Token)
Catch ex As Exception
ProcessException(ex, Token, $"data downloading error [{URL}]")
End Try
@@ -396,7 +403,7 @@ Namespace API.Xhamster
If Not m.URL_BASE.IsEmptyString Then
m2 = Nothing
ThrowAny(Token)
If GetM3U8(m2, m.URL_BASE) Then
If GetM3U8(m2, m.URL_BASE, m.SpecialFolder) Then
m2.URL_BASE = m.URL_BASE
_TempMediaList(i) = m2
Else
@@ -426,7 +433,7 @@ Namespace API.Xhamster
If Not m.URL_BASE.IsEmptyString Then
m2 = Nothing
ThrowAny(Token)
If GetM3U8(m2, m.URL_BASE) Then
If GetM3U8(m2, m.URL_BASE, String.Empty) Then
m2.URL_BASE = m.URL_BASE
_TempMediaList(i) = m2
c += 1
@@ -507,7 +514,7 @@ Namespace API.Xhamster
If m.State = UserMedia.States.Missing AndAlso Not m.URL_BASE.IsEmptyString Then
ThrowAny(Token)
m2 = Nothing
If GetM3U8(m2, m.URL_BASE) Then
If GetM3U8(m2, m.URL_BASE, m.SpecialFolder) Then
m2.URL_BASE = m.URL_BASE
m2.State = UserMedia.States.Missing
m2.Attempts = m.Attempts
@@ -528,7 +535,7 @@ Namespace API.Xhamster
End Sub
#End Region
#Region "GetM3U8"
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal URL As String) As Boolean
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal URL As String, ByVal SpecFolder As String) As Boolean
Try
If Not URL.IsEmptyString Then
Dim r$ = Responser.GetResponse(URL)
@@ -536,7 +543,7 @@ Namespace API.Xhamster
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists Then
m = ExtractMedia(j("videoModel"), UTypes.VideoPre)
m = ExtractMedia(j("videoModel"), UTypes.VideoPre,,,, SpecFolder)
m.URL_BASE = URL
If IsSubscription Then
With j("videoModel")
@@ -546,7 +553,7 @@ Namespace API.Xhamster
End If
End With
Else
Return GetM3U8(m, j)
Return GetM3U8(m, j, SpecFolder)
End If
End If
End Using
@@ -557,7 +564,7 @@ Namespace API.Xhamster
Return ErrorsDescriber.Execute(EDP.ReturnValue, ex, $"[{ToStringForLog()}]: API.Xhamster.GetM3U8({URL})", False)
End Try
End Function
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal j As EContainer) As Boolean
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal j As EContainer, ByVal SpecFolder As String) As Boolean
Dim node As EContainer = j({"xplayerSettings", "sources", "hls"})
If node.ListExists Then
Dim url$ = node.GetNode({New NodeParams("url", True, True, True, True, 2)}).XmlIfNothingValue
@@ -583,7 +590,8 @@ Namespace API.Xhamster
#End Region
#Region "Create media"
Private Function ExtractMedia(ByVal j As EContainer, ByVal t As UTypes, Optional ByVal UrlNode As String = "pageURL",
Optional ByVal DetectGalery As Boolean = True, Optional ByVal PostDate As Date? = Nothing) As UserMedia
Optional ByVal DetectGalery As Boolean = True, Optional ByVal PostDate As Date? = Nothing,
Optional ByVal SpecFolder As String = Nothing) As UserMedia
If Not j Is Nothing Then
Dim m As New UserMedia(j.Value(UrlNode).Replace("\", String.Empty), t) With {
.Post = New UserPost With {
@@ -626,6 +634,8 @@ Namespace API.Xhamster
End If
m.File.Separator = "\"
End If
If Not SpecFolder.IsEmptyString Then _
m.SpecialFolder = $"{m.SpecialFolder.StringTrimEnd("\")}{IIf(m.SpecialFolder.IsEmptyString, String.Empty, "\")}{SpecFolder}"
Return m
Else
Return Nothing

View File

@@ -6,16 +6,22 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.Xhamster
Friend Class UserExchangeOptions
<PSetting(Address:=SettingAddress.User, Caption:="Query",
ToolTip:="Query string. Don't change this field when creating a user! Change it only for the same request.")>
Friend Property QueryString As String
Friend NotInheritable Class UserExchangeOptions : Inherits API.Base.EditorExchangeOptionsBase_P
<PSetting(Address:=SettingAddress.User, Caption:="Get moments")>
Friend Property GetMoments As Boolean = False
Friend Sub New()
MyBase.New
End Sub
Friend Sub New(ByVal u As UserData)
QueryString = u.QueryString
Friend Sub New(ByVal u As IPSite)
MyBase.New(DirectCast(u, UserData))
GetMoments = DirectCast(u, UserData).GetMoments
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
MyBase.Apply(u)
DirectCast(u, UserData).GetMoments = GetMoments
End Sub
End Class
End Namespace

View File

@@ -32,6 +32,6 @@ Imports System.Runtime.InteropServices
' by using the '*' as shown below:
' <Assembly: AssemblyVersion("1.0.*")>
<Assembly: AssemblyVersion("2025.6.12.0")>
<Assembly: AssemblyFileVersion("2025.6.12.0")>
<Assembly: AssemblyVersion("2025.7.18.0")>
<Assembly: AssemblyFileVersion("2025.7.18.0")>
<Assembly: NeutralResourcesLanguage("en")>

View File

@@ -169,6 +169,7 @@
<Compile Include="API\Base\DeclaredNames.vb" />
<Compile Include="API\Base\DownDetector.vb" />
<Compile Include="API\Base\EditorExchangeOptionsBase.vb" />
<Compile Include="API\Base\EditorExchangeOptionsBase_P.vb" />
<Compile Include="API\Base\GDL.vb" />
<Compile Include="API\Base\IUserData.vb" />
<Compile Include="API\Base\M3U8Base.vb" />
@@ -268,7 +269,6 @@
<Compile Include="API\XVIDEOS\M3U8.vb" />
<Compile Include="API\XVIDEOS\SiteSettings.vb" />
<Compile Include="API\XVIDEOS\UserData.vb" />
<Compile Include="API\XVIDEOS\UserExchangeOptions.vb" />
<Compile Include="API\YouTube\SiteSettings.vb" />
<Compile Include="API\YouTube\UserData.vb" />
<Compile Include="API\YouTube\UserExchangeOptions.vb" />