You need libpcre.a otherwise it will fail.
Compile it with -s console
Code: Select all
'Ported from WinHTTP.au3 by trancexx to FB by UEZ
'v0.1 build 2021-01-05 beta
#Include Once "windows.bi"
'libpcre.a needed in lib folder! Download link here: https://www.freebasic.net/forum/viewtopic.php?f=17&t=19095&start=495#p278794
#Ifdef __Fb_64bit__
#Libpath "lib\win64\"
#Else
#Libpath "lib\win32\"
#Endif
#Define PCRE_STATIC
#Include "pcre.bi"
'https://www.pcre.org/original/doc/html/index.html
Function StringRegEx(sPattern As String, sString As String, aArr() As String, iOptions as Ulong = 0, bDebug As Boolean = False) As Long
Const iStrVecCnt = 300
Dim As Zstring Ptr pErrorStr, pSubStrMatchStr
Dim As Long iRegexExec, iErrOffset, aStrVec(iStrVecCnt - 1), iResult = -1, i, j = 0, k = 1
Dim As pcre_extra tRegexStudy
Dim As pcre Ptr pRegexCompiled
Dim As pcre_extra Ptr pRegexStudy
' OPTIONS (second argument) (||'ed together) can be:
' PCRE_ANCHORED -- Like adding ^ at start of pattern.
' PCRE_CASELESS -- Like m//i
' PCRE_DOLLAR_ENDONLY -- Make $ match end of string regardless of \n's
' No Perl equivalent.
' PCRE_DOTALL -- Makes . match newlins too. Like m//s
' PCRE_EXTENDED -- Like m//x
' PCRE_EXTRA --
' PCRE_MULTILINE -- Like m//m
' PCRE_UNGREEDY -- Set quantifiers to be ungreedy. Individual quantifiers
' may be set to be greedy if they are followed by "?".
' PCRE_UTF8 -- Work with UTF8 strings.
'first, the regex string must be compiled
pRegexCompiled = pcre_compile(sPattern, iOptions, @pErrorStr, Cast(Long Ptr, @iErrOffset), 0)
If pRegexCompiled = NULL Then
Return iResult
End If
'optimize the regex
'pcre_study() returns NULL for both errors and when it can not optimize the regex.
'The last argument is how one checks for errors (it is NULL if everything works, and points to an error string otherwise.
pRegexStudy = pcre_study(pRegexCompiled, 0, @pErrorStr)
If pRegexStudy = NULL Then
Return iResult - 1
End If
Redim aArr(0 To iStrVecCnt)
Do
iRegexExec = pcre_exec(pRegexCompiled, pRegexStudy, Strptr(sString), Len(sString), j, 0, Cast(Long Ptr, @aStrVec(0)), iStrVecCnt)
If iRegexExec > 0 Then
For i = 0 To iRegexExec - 1
pcre_get_substring(Strptr(sString), @aStrVec(0), iRegexExec, i, @pSubStrMatchStr)
If k > Ubound(aArr) Then Redim Preserve aArr(0 To (Ubound(aArr) Shl 1))
aArr(k) = pSubStrMatchStr[0]
'? aStrVec(i * 2), aStrVec(i * 2 + 1), pSubStrMatchStr
k += 1
Next
j = aStrVec(1)
Else
If bDebug Then
Select Case iRegexExec
Case PCRE_ERROR_NOMATCH
? "String did not match the pattern"
Case PCRE_ERROR_NULL
? "Something was null"
Case PCRE_ERROR_BADOPTION
? "A bad option was passed"
Case PCRE_ERROR_BADMAGIC
? "Magic number bad (compiled re corrupt?)"
Case PCRE_ERROR_UNKNOWN_NODE
? "Something kooky in the compiled re"
Case PCRE_ERROR_NOMEMORY
? "Ran out of memory"
Case Else
? "Unknown error"
End Select
Endif
Endif
pcre_free_substring(Cast(Zstring Ptr, @pSubStrMatchStr))
Loop Until iRegexExec < 1
Redim Preserve aArr(0 To k - 1)
pcre_free(pRegexCompiled)
#Ifdef PCRE_CONFIG_JIT
pcre_free_study(pRegexStudy)
#Else
pcre_free(pRegexStudy)
#Endif
pcre_free(pRegexCompiled)
aArr(0) = Str(k - 1)
Return 1
End Function
Type HINTERNET As LPVOID
Const CRLF = Chr(10, 13), WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0, WINHTTP_ACCESS_TYPE_NO_PROXY = 1, WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3, WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY = 4, WINHTTP_FLAG_ESCAPE_DISABLE = &h00000040, INTERNET_DEFAULT_HTTPS_PORT = 443, INTERNET_DEFAULT_HTTP_PORT = 80, INTERNET_DEFAULT_PORT = 0, WINHTTP_NO_PROXY_NAME = "", WINHTTP_NO_PROXY_BYPASS = "", WINHTTP_NO_REFERER = "", WINHTTP_DEFAULT_ACCEPT_TYPES = 0, WINHTTP_FLAG_SECURE = &h00800000, WINHTTP_NO_ADDITIONAL_HEADERS = "", WINHTTP_NO_REQUEST_DATA = ""
Dim Shared As Any Ptr __hWinHTTPLib = 0
Dim Shared WinHttpOpen As Function(sUserAgent As LPCWSTR, iAccessType As Long, sProxyName As LPCWSTR, sProxyBypass As LPCWSTR, iFlag As Long) As HINTERNET
Dim Shared WinHttpCloseHandle As Function(__hWinHTTPLib As Any Ptr) As Boolean
Dim Shared WinHttpConnect As Function(hSession As HINTERNET, sServerName As LPCWSTR, iServerPort As Long, Reserved As DWORD) As HINTERNET
Dim Shared WinHttpOpenRequest As Function(hConnect As HINTERNET, sVerb As LPCWSTR, sObjectName As LPCWSTR, sVersion As LPCWSTR, sReferrer As LPCWSTR, pAcceptTypes As Any Ptr, iFlags As Long) As HINTERNET
Dim Shared WinHttpSendRequest As Function(hInternet As HINTERNET, sHeader As LPCWSTR, iHeadersLength As Long, pOptionalBuff As HINTERNET, iOptionalLength As Long, iTotalLength As Long, pContext As DWORD_PTR) As Boolean
Dim Shared WinHttpReceiveResponse As Function(hInternet As HINTERNET, iReserved As LPVOID) As Boolean
Dim Shared WinHttpReadData As Function(hRequest As HINTERNET, pBuffer As LPVOID, iNumberOfBytesToRead As Long, pNumberOfBytesRead As LPDWORD) As Boolean
Dim Shared WinHttpQueryDataAvailable As Function(hRequest As HINTERNET, pNumberOfBytesAvailable As LPDWORD) As Boolean
Function _WinHttpStartup() As Boolean
__hWinHTTPLib = Dylibload("Winhttp.dll")
If __hWinHTTPLib = 0 Then Return False
WinHttpOpen = Dylibsymbol(__hWinHTTPLib, "WinHttpOpen")
WinHttpCloseHandle = Dylibsymbol(__hWinHTTPLib, "WinHttpCloseHandle")
WinHttpConnect = Dylibsymbol(__hWinHTTPLib, "WinHttpConnect")
WinHttpOpenRequest = Dylibsymbol(__hWinHTTPLib, "WinHttpOpenRequest")
WinHttpSendRequest = Dylibsymbol(__hWinHTTPLib, "WinHttpSendRequest")
WinHttpReceiveResponse = Dylibsymbol(__hWinHTTPLib, "WinHttpReceiveResponse")
WinHttpReadData = Dylibsymbol(__hWinHTTPLib, "WinHttpReadData")
WinHttpQueryDataAvailable = Dylibsymbol(__hWinHTTPLib, "WinHttpQueryDataAvailable")
Return True
End Function
Function _WinHttpShutdown() As Boolean
If __hWinHTTPLib Then
Dylibfree(__hWinHTTPLib)
Return True
Endif
Return False
End Function
Function _WinHttpOpen(sUserAgent As String = "FB_WinHHTP/1.0", iAccessType As Long = WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY, sProxyName As String = WINHTTP_NO_PROXY_NAME, sProxyBypass As String = WINHTTP_NO_PROXY_BYPASS, iFlag As Long = 0) As HINTERNET
If __hWinHTTPLib = 0 Then Return 0
Return WinHttpOpen(Wstr(sUserAgent), iAccessType, Wstr(sProxyName), Wstr(sProxyBypass), iFlag)
End Function
Function _WinHttpCloseHandle(__hInternet As Any Ptr = __hWinHTTPLib) As Boolean
If __hInternet = 0 Then Return False
Return WinHttpCloseHandle(__hInternet)
End Function
Function _WinHttpConnect(hSession As HINTERNET, sServerName As String, iServerPort As Long = INTERNET_DEFAULT_PORT) As HINTERNET
If hSession = 0 Then Return 0
Return WinHttpConnect(hSession, Wstr(sServerName), iServerPort, 0)
End Function
Function _WinHttpOpenRequest(hConnect As HINTERNET, sVerb As String = "GET", sObjectName As String = "", sVersion As String = "HTTP/1.1", sReferrer As String = WINHTTP_NO_REFERER, pAcceptTypes As Any Ptr = WINHTTP_DEFAULT_ACCEPT_TYPES, iFlags As Long = WINHTTP_FLAG_ESCAPE_DISABLE) As HINTERNET
If hConnect = 0 Then Return 0
Return WinHttpOpenRequest(hConnect, Wstr(Ucase(sVerb)), Wstr(sObjectName), Wstr(Ucase(sVersion)), Wstr(sReferrer), pAcceptTypes, iFlags)
End Function
Function _WinHttpQueryDataAvailable(hRequest As HINTERNET, Byref pNumberOfBytesAvailable As LPDWORD = NULL) As Ulong
If hRequest = 0 Then Return 0
Return WinHttpQueryDataAvailable(hRequest, pNumberOfBytesAvailable)
End Function
Function _WinHttpReadData(hRequest As HINTERNET, iMode As Ubyte = 0, iNumberOfBytesToRead As Uinteger = 8192, pBuffer As LPDWORD = 0) As String
If hRequest = 0 Then Return ""
Dim As Ulong iNumberOfBytesRead = 0, i
Dim As Ubyte aBuffer(iNumberOfBytesToRead)
WinHttpReadData(hRequest, @aBuffer(0), iNumberOfBytesToRead, @iNumberOfBytesRead)
If iNumberOfBytesRead = 0 Then Return ""
Dim As String sHTML
For i = 0 To iNumberOfBytesRead
sHTML &= Chr(aBuffer(i))
Next
Return sHTML
End Function
Function _WinHttpReceiveResponse(hRequest As HINTERNET) As Boolean
If hRequest = 0 Then Return False
Return WinHttpReceiveResponse(hRequest, 0)
End Function
Function _WinHttpSendRequest(hRequest As HINTERNET, sHeaders As String = WINHTTP_NO_ADDITIONAL_HEADERS, sOptional As String = WINHTTP_NO_REQUEST_DATA, iTotalLength As Ulong = 0, iContext As ULong = 0) As Boolean
If hRequest = 0 Then Return False
Dim As Ulong iOptionalLength = Len(sOptional), i
Dim As Ubyte aOptional(Len(sOptional) - 1)
If iOptionalLength > 0 Then
For i = 0 To iOptionalLength - 1
aOptional(i) = Asc(Mid(sOptional, i + 1, 1))
Next
End If
If iTotalLength = 0 Or iTotalLength < iOptionalLength Then iTotalLength += iOptionalLength
Return WinHttpSendRequest(hRequest, Wstr(sHeaders), 0, @aOptional(0), iOptionalLength, iTotalLength, iContext)
End Function
Function _WinHttpSimpleReadData(hRequest As HINTERNET, iMode As Ubyte = 0) As String
If hRequest = 0 Then Return ""
If iMode > 2 Then iMode = 2
If _WinHttpQueryDataAvailable(hRequest) > 0 Then
Dim As String sData, d
Select Case iMode
Case 0
Do
d = _WinHttpReadData(hRequest, 0)
If d = "" Then Exit Do
sData &= d
Loop Until False
Return sData
End Select
End If
End Function
Function _WinHttpSimpleSendRequest(hConnect As HINTERNET, sPath As String = "", sType As String = "GET", sReferrer As String = WINHTTP_NO_REFERER, sData As String = WINHTTP_NO_REQUEST_DATA, sHeader As String = WINHTTP_NO_ADDITIONAL_HEADERS) As HINTERNET
If hConnect = 0 Then Return 0
Dim As HINTERNET hRequest = _WinHttpOpenRequest(hConnect, sType, sPath, "HTTP/1.1", sReferrer)
If hRequest = 0 Then Return 0
If sType = Ucase("POST") And sHeader = WINHTTP_NO_ADDITIONAL_HEADERS Then sHeader = "Content-Type: application/x-www-form-urlencoded" & CRLF
If _WinHttpSendRequest(hRequest, sHeader, sData) = False Then Return 0
If _WinHttpReceiveResponse(hRequest) = False Then Return 0
Return hRequest
End Function
Dim As Any Ptr hSession, hConnect, hRequest
Dim As String sRead
Dim As String aResult()
If _WinHttpStartup() = False Then End
hSession = _WinHttpOpen()
hConnect = _WinHttpConnect(hSession, "forum.qbasic.at")
hRequest = _WinHttpSimpleSendRequest(hConnect, "viewtopic.php?t=8996")
sRead = _WinHttpSimpleReadData(hRequest)
StringRegEx("<title>.*Color Constants v(\d*\.\d+)\h*\[", sRead, aResult())
If aResult(0) = "2" Then ? "Online Color Constants version is v" & aResult(2)
_WinHttpCloseHandle(hRequest)
_WinHttpCloseHandle(hConnect)
_WinHttpCloseHandle(hSession)
_WinHttpShutdown()
Sleep
The output should be: Online Color Constants version is v0.75