Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Text aus Internetseite auslesen?
Gehe zu Seite Zurück  1, 2
 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
UEZ



Anmeldungsdatum: 24.06.2016
Beiträge: 126
Wohnort: Opel Stadt

BeitragVerfasst am: 05.01.2021, 21:07    Titel: Antworten mit Zitat

Ich habe mal versucht die nötigen WinHTTP Funktionen von AutoIt nach FB inkl. RegEx zu portieren:

Code:

'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


Zum Ausführen wird die libpcre.a in dem Verzeichnis lib\win32\ bzw. lib\win64\ benötigt.

DL: https://www.freebasic.net/forum/viewtopic.php?f=17&t=19095&start=495#p278794

Dieses Beispiel liest die Version von Color Constants aus, das hier ist: https://forum.qbasic.at/viewtopic.php?t=8996

Der Consolen Output sollte "Online Color Constants version is v0.75" sein.
_________________
Gruß,
UEZ
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC. Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite Zurück  1, 2
Seite 2 von 2

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz