WEBGET for PB/CC (update)

[Lance Edmonds]

Please do not ask questions or carry out discussions in the Source Code forum. This forum is for the posting of code and "on topic" notes directly relating to the posted code only.

Place your questions in the appropriate non-source forum and include the URL for this thread if the question is directly related.

Thanks!

------------------
Lance
PowerBASIC Support
mailto:[email protected][email protected]</A>

[Javier Rodriguez]

Dear Dave:

First: Thanks! (for so many lines of code that you give us).
2nd: I am trying to use your webget updated routine to get
some https sites... HTTPS "must" work in some way...

Is this possible? What I need to change on the general
routine? (of course that I can spend some hours digging on
the RFCs for the httpS protocol... but I understand that
you can know this answer and share with us...

Regards,

Javier Rodriguez
Lima, Peru.

------------------
-------------------------
Javier Rodriguez
Lima, Peru. South America
[email protected]
Tel-Fax. 51-1-720-8994
http://www.redPE.com
-------------------------

[Dave Navarro]

April 27, 2001 - Update


------------------
Home of the BASIC Gurus
www.basicguru.com

[Scott Turchin]

I'd like to post mine in here since it's a relative topic.
Initially I had a function in here to get all images as well but that did not work out..

This is still kinda buggy on the dialog but works fine, and the function itself does work well as for returning a web page....

Scott

#Compile Dll "ccsinet.dll"
#Register None
#Option Version4
#Include "win32api.inc"
#Include "CommCtrl.inc"
#Resource "CCS.PBR"

%BUFFER_SIZE = 256
%HTML_404    = 404
%PROGRAM     = 1024
%PROGRESS    = %WM_USER + 900
%IDT_TIMER1  = %WM_USER + 901

%IDLABEL1    = %WM_USER + 1021
%IDLABEL2    = %WM_USER + 1022
%IDLABEL3    = %WM_USER + 1023
%IDLABEL4    = %WM_USER + 1024
%IDLABEL5    = %WM_USER + 1025
%IDLABEL6    = %WM_USER + 1026

' Constants FOR HTML ERRORS
%HTML_200 = 200
%HTML_403 = 403
%HTML_404 = 404
%HTML_405 = 405
%HTML_406 = 406
%HTML_407 = 407
%HTML_408 = 408
%HTML_500 = 500
%HTML_501 = 501
%HTML_502 = 502


Type HTML_HEADER
   ErrorMsg             As Asciiz * 100
   Current_Date         As Asciiz * 35
   ServerType           As Asciiz * 100
   LastModdate          As Asciiz * 35
   Etag                 As Asciiz * 25
   AcceptRanges         As Asciiz * 10
   ContentLength        As Long
   HeaderLength         As Long  'Thanks to Unix, MS doesn't have this problem
   Keep_Alive_Timeout   As Long
   Keep_Alive_Max       As Long
   Connection           As Asciiz * 25
   DataType             As Asciiz * 12
   Header              As Asciiz * 255
End Type


Declare Function GetWebPage(hWnd As Long,_
                            hMsg As Long,_
                            wwwPort As Long, _
                            ByVal wwwPage As String, _
                            AppName As String, _
                            Referrer As String, _
                            hHeader As HTML_HEADER,_
                            Buffer As String) As Long

Declare Function SendHtmlRequest(wwwPort As Long, _
                                wHostName As String, _
                                ByVal wwwPage As String,_
                                AppName As String, _
                                Referrer As String) As Long


Declare Function GetHtmlHeader(hHeader As HTML_HEADER) As Long
Declare Function StripHTTPandGetHostName(wwwPage As String, wHostName As String, RemoteDir As String) As String

Declare Function GetTCPBuffer()As String
Declare Function ShowHtmlDialog(ThreadId As Long) As Long
Declare CallBack Function HtmlProc() As Long
Declare Function ThreadDialog(ByVal hDlg As Long)As Long
Declare CallBack Function CancelButton() As Long

Declare Function GetWindowsVersion Lib "CCS.DLL" ()As String


Global ghLibTest        As Long
Global gReason          As Long
Global gReserved        As Long
Global gNumOfTimes      As Dword
Global gNumOfCheck      As Dword
Global g_sVer           As String

Global hDlg                     As Long
Global sDlg                     As Long
Global hTcp                     As Dword
Global g_hMsg                   As Long
Global g_Thread_Result          As Long
Global g_lngInitThreadHandle    As Long
Global g_CancelFlag             As Long
Global g_TotalBytes             As Long
Global hHeader                  As HTML_HEADER
Global g_sCCS                   As String
Global g_sMINE                  As String
Global g_WebPage                As String
'------------------------------------------------------------------------------------------------------------------------

Function LibMain(ByVal hInstance As Long, _
                 ByVal Reason    As Long, _
                 ByVal Reserved  As Long) Export As Long

  ghLibTest = hInstance
  gReason   = Reason
  gReserved = Reserved
  g_sCCS = "Computer Creations Software"
  g_sMINE = "HTML Internet DLL"
  g_sVer  = "v1.1"

  Incr gNumOfTimes

  Select Case Reason

    Case %DLL_PROCESS_ATTACH
      gNumOfCheck = 1234
       LibMain = 1   'success!
      Exit Function

    Case %DLL_PROCESS_DETACH

       LibMain = 1   'success!
      Exit Function

    Case %DLL_THREAD_ATTACH
       LibMain = 1   'success!
      Exit Function

    Case %DLL_THREAD_DETACH
       LibMain = 1   'success!
      Exit Function
  End Select
End Function


'------------------------------------------------------------------------------------------------------------------------
Function GetWebPage(hWnd As Long,_
                    hMsg As Long,_   'hStatus or whatever control you wish to send to, if NULL it won't send
                    wwwPort As Long, _ 'Port to open
                    ByVal wwwPage As String, _ 'Entire [url="http://www.tngbbs.com/winlog/index.html"]http://www.tngbbs.com/winlog/index.html[/url] 
                    AppName As String, _       'Application referring For web statistics on some pages
                    Referrer As String, _      'Referrer
                    hHeader As HTML_HEADER,_
                    Buffer As String) Export As Long 'What to save the local file as, entire path.

Local hFile         As Long
Local lCount        As Long
Local lLoop         As Long
Local lResult       As Long
Local ErrType       As Long
Local ThreadID      As Long

Local zText         As Asciiz * 120

Local sInArray      As String
Local HostName      As String
Local RemoteFile    As String
Local RemoteDir    As String

'Set Global vars
hDlg = hWnd 'Now it's global
g_hMsg = hMsg
g_WebPage = wwwPage 'For image use

'Set the mouse busy
MousePtr 11
Pc& = SetPriorityClass(GetCurrentProcess(), %HIGH_PRIORITY_CLASS)

'Create a user interface t hread, we will talk to it through our main functions
Thread Create ShowHtmlDialog(ThreadId) To g_lngInitThreadHandle
Thread Close g_lngInitThreadHandle To g_Thread_Result

wwwPage = StripHTTPandGetHostName(wwwPage,HostName,RemoteDir)
RemoteFile = Mid$(wwwPage,Instr(-1, wwwPage,"/") + 1)   'help.html
Control Set Text sDlg, %IDLABEL1, "Contacting "
Control Set Text sDlg, %IDLABEL2, HostName

'Tested good here so far
lResult = SendHtmlRequest(wwwPort, _
                          HostName, _
                          ByVal wwwPage, _
                          AppName, _
                          Referrer)

If lResult <> 200 Then
   Sleep 500
   Dialog End sDlg, 0
   Exit Function
End If

Control Set Text sDlg, %IDLABEL2, HostName + wwwPage
lResult = GetHtmlHeader(hHeader)
If lResult <> 200 Then
   Tcp Close hTcp
   Exit Function
End If

Buffer = hHeader.Header + GetTCPBuffer()

If IsTrue g_CancelFlag Then Exit Function
Function = lResult
MousePtr 0
Dialog End sDlg,1
End Function

'-----------------------------------------------------------------------------------
Function SendHtmlRequest(wwwPort As Long, _
                        wHostName As String, _
                        ByVal wwwPage As String,_
                        AppName As String, _
                        Referrer As String)Export As Long

Local ErrType       As Long
Local wwwRequest    As String

If hTcp = 0 Then    'And it should be, open main port here
    'Safety precaution
    If wwwPort = 0 Then wwwPort = 80
    'Open the port
    hTcp = FreeFile
    Tcp Open Port wwwPort At wHostName As hTcp TimeOut 1' 3000
    ErrType = Err
    Select Case ErrType
        Case 0
           Function = %HTML_200
        Case 52
           Control Set Text sDlg, %IDLABEL1, "Failed"
           Control Set Text sDlg, %IDLABEL2, "Host not found"
        Case Else
           Control Set Text sDlg, %IDLABEL1, "Failed"
           Control Set Text sDlg, %IDLABEL2, Trim$(Str$(ErrType))
           Function = ErrType
    End Select
    If ErrType <> 0 Then Exit Function
End If


'******************************
'We will use the temp directory, not a cache directory
'Build the HTTP header
wwwRequest = "GET " + wwwPage + " HTTP/1.1" + $CRLF
wwwRequest = wwwRequest + "Accept: */*" + $CRLF
wwwRequest = wwwRequest + "Referer: " + Referrer + $CRLF
wwwRequest = wwwRequest + "Accept-Language: en-us" + $CRLF
wwwRequest = wwwRequest + "Accept-Encoding: gzip, deflate" + $CRLF
wwwRequest = wwwRequest + "User-Agent: Mozilla/4.0 (compatable; " + AppName + "; " + GetWindowsVersion + ")" + $CRLF
wwwRequest = wwwRequest + "Host: " + wHostName + $CRLF
wwwRequest = wwwRequest + "Connection: Keep-Alive" + $CRLF
wwwRequest = wwwRequest + "" + $CRLF

If IsTrue g_CancelFlag Then Exit Function

Control Set Text  sDlg, %IDLABEL1, "Requesting"
Control Set Text  sDlg, %IDLABEL2, wwwPage

'Send the request
Tcp Print hTcp, wwwRequest
ErrType = Err
Select Case ErrType
    Case 0
       Function = %HTML_200
       Exit Function
    Case 52
       Control Set Text sDlg, %IDLABEL1, "Failed"
       Control Set Text sDlg, %IDLABEL2, "Host Not Found while sending request"
    Case Else
       Control Set Text sDlg, %IDLABEL1, "Failed"
       Control Set Text sDlg, %IDLABEL2, Trim$(Str$(ErrType))
       Function = ErrType
End Select
Function = ErrType
End Function

'------------------------------------------------------------------------------------------------------------------------
Function StripHTTPandGetHostName(wwwPage As String, wHostName As String,RemoteDir As String) As String 'Returns wwwPage stripped, wwwPage is the entire path
wwwPage= Remove$(wwwPage,"http://")
wHostName = Left$(wwwPage,Instr(wwwPage,"/") - 1)
wwwPage = Remove$(wwwPage,wHostName)
RemoteDir = Mid$(wwwPage,Instr(wwwPage,"/"),Instr(-1, wwwPage,"/"))
Function = wwwPage
End Function
'------------------------------------------------------------------------------------------------------------------------
Function GetTCPBuffer()Export As String
Local buffer As String
Local WebIn  As String
Local bufCount As Long
Local ByteCount As Long
Local ErrType   As Long

Control Set Text sDlg, %IDLABEL1, "Downloading "

TCPBEGIN:
Do
  Tcp Recv #hTcp,%BUFFER_SIZE, buffer
  BufCount = Len(buffer)
  ByteCount = ByteCount + BufCount
  g_TotalBytes = g_TotalBytes + ByteCount
  Control Set Text  sDlg, %IDLABEL4, Trim$(Str$(ByteCount))
  Control Set Text  sDlg, %IDLABEL6, Format$(g_TotalBytes,",000")'  Trim$(Str$(g_TotalBytes))
  WebIn = WebIn + buffer

  If IsTrue g_CancelFlag Then
     Tcp Close hTcp
     Exit Function
  End If
Loop While BufCount
Function = WebIn
Exit Function
TCPERR:
  ErrType = Err
  Select Case ErrType
         Case 0
'              Resume TCPBEGIN
         Case Else
            Control Set Text sDlg, %IDLABEL1, "Error: "
            Control Set Text sDlg, %IDLABEL2, Trim$(Str$(ErrType))
            g_CancelFlag = %TRUE 'Use to close dialog on error etc
            Exit Function
  End Select
End Function
'------------------------------------------------------------------------------------------------------------------------
Function GetHtmlHeader(hHeader As HTML_HEADER)Export As Long
Local lLoop         As Long
Local sInArray      As String
Local lHeaderLine   As String
Local lErMsg        As Long
Local ErrType       As Long

On Error GoTo TCPERR
Control Set Text sDlg, %IDLABEL1, "Downloading"
TCPBEGIN:

'This is an IIS header being returned. it appears to be 8 not 10 loops, vastly different than Unix.
'HTTP/1.1 200 OK
'Server: Microsoft-IIS/5.0
'Date: Mon, 14 Aug 2000 16:19:54 GMT
'Content-Type: Text/html
'Accept-Ranges: bytes
'Last-Modified: Sun, 13 Aug 2000 07:50:38 GMT
'ETag: "0db872bfb4c01:927"
'Content-Length: 2068

'This is an APACHE/Unix Header being returned, it also appears to be 7 now..
'HTTP/1.1 200 OK
'Date: Mon, 14 Aug 2000 20:53:07 GMT
'Server: Apache/1.3.6 (Unix) PHP/3.0.7 mod_perl/1.21 mod_frontpage/3.0.4.3
'Keep-Alive: timeout=35, Max=100
'Connection: Keep-Alive
'Transfer-Encoding: chunked
'Content-Type: Text/htmldc7

For lLoop = 1 To 8
    Tcp Line #hTcp, sInArray
    ErrType = Err
    Select Case ErrType
             Case 0
             Case Else
                Control Set Text sDlg, %IDLABEL1, "Error: "
                Control Set Text sDlg, %IDLABEL2, Trim$(Str$(ErrType))
                Exit Function
    End Select
    hHeader.Header = hHeader.Header + sInArray
    If Parse$(sInArray,"/",1) = "HTTP" Then
           lErMsg = Val(Parse$(sInArray," ",2))
           hHeader.ErrorMsg = sInArray
    End If

    lHeaderLine = Parse$(sInArray," ",1)
    Select Case lHeaderLine
                      'HTTP/X.X XXX ErrorMsg

              Case "Server:"
                 hHeader.ServerType = Parse$(sInArray," ", 2)
              Case "Date:"
                 hHeader.Current_Date  = Parse$(sInArray," ", 2)

              Case  "Content-Type:"
                 hHeader.Datatype = Parse$(sInArray," ", 2)

              Case "Transfer-Encoding:" 'Unix
                 hHeader.Datatype = Parse$(sInArray," ", 2)

              Case "Accept-Ranges:" 'Windows
                 hHeader.AcceptRanges = Trim$(Parse$(sInArray," ", 2))


              Case "Content-Length:"
                 hHeader.ContentLength = Val(Parse$(sInArray," ", -1))

              Case "Last-Modified:"
                 hHeader.LastModdate = Parse$(sInArray," ", 2)

              Case "ETag:"
                 hHeader.Etag = Parse$(sInArray," ", 2)

              Case "Keep-Alive:"
                 'These will still need to be parsed down one more from '='
                 hHeader.Keep_Alive_Timeout = Val(Parse$(Parse$(Parse$(sInArray," ", 2),"=",1),",",1))
                 hHeader.Keep_Alive_Max  = Val(Parse$(Parse$(sInArray," ", 3),"=",1))

              Case "Connection:"
                 hHeader.Connection = Parse$(sInArray," ", -1)

    End Select

Next
hHeader.HeaderLength = SizeOf(hHeader.Header)
Function = lErMsg
Exit Function

TCPERR:
  ErrType = Err
  Select Case ErrType
         Case 0
              Resume TCPBEGIN
         Case Else
            Control Set Text sDlg, %IDLABEL1, "Error: "
            Control Set Text sDlg, %IDLABEL2, Trim$(Str$(ErrType))
            g_CancelFlag = %TRUE 'Use to close dialog on error etc
            Exit Function
  End Select


End Function

'---------------------------------------------------------------------------------------------------------------------------------
Function ShowHtmlDialog(ThreadID As Long) As Long
    Dialog New hDlg, "",,, 180,50, %WS_POPUP Or %WS_DLGFRAME  To sDlg
    Control Add Label, sDlg, %IDLABEL1, "Opening", 5, 1, 43, 10
    Control Add Label, sDlg, %IDLABEL2, g_WebPage, 45, 1, 140, 10
    Control Add "msctls_progress32",sDlg, %PROGRESS,"",5,15,170,10, %WS_CHILD Or %WS_VISIBLE Or %WS_CLIPSIBLINGS Or %CCS_BOTTOM
    Control Add Button, sDlg, %IDCANCEL, "&Cancel",130,30,45,14 Call CancelButton
    Control Add Label, sDlg, %IDLABEL3, "bytes: ",5,30,50,10
    Control Add Label, sDlg, %IDLABEL4, "0",45,30,35,10
    Control Add Label, sDlg, %IDLABEL5, "Total: ", 5,40,40,10
    Control Add Label, sDlg, %IDLABEL6, "0", 45,40,40,10

    Dialog Send sDlg, %WM_SETICON, %ICON_BIG, LoadIcon( ghLibTest, ByVal %PROGRAM)
    Control Send sDlg, %PROGRESS,  %PBM_SETRANGE, 0, MakLng (0,30)
    Control Send sDlg, %PROGRESS,  %PBM_SETSTEP,1, 0
    Dialog Show Modal sDlg Call HtmlProc
End Function

'---------------------------------------------------------------------------------------------------------------------------------

CallBack Function HtmlProc() As Long
Static wCount As Long

    MousePtr 11 'BUSY

    Select Case CbMsg

    Case %WM_INITDIALOG
        SetTimer sDlg, %IDT_TIMER1,  1000, ByVal %NULL '30 second timeout
    Case %WM_DESTROY
         KillTimer sDlg,  %IDT_TIMER1

    Case %WM_TIMER
        Select Case CbWparam
          Case %IDT_TIMER1
             Control Set Focus sDLg, %IDCANCEL
             If IsTrue g_CancelFlag Then Dialog End sDlg, 0
             If wCount = 30 Then
                 MousePtr 0
                 Dialog End sDlg, 1
             Else
                Control Send sDlg, %PROGRESS, %PBM_STEPIT, 0, 0
                Incr wCount
             End If
        End Select

    End Select
 End Function
'---------------------------------------------------------------------------------------------------------------------------------
Function ThreadDialog(ByVal hDlg As Long) Export As Long
Local Rc As Long
Do
    Dialog DoEvents
    Dialog Get Size hDlg To Rc,Rc
Loop While Rc

Function = 1
End Function
'----------------------------------------------------------------------------------------------------------------
CallBack Function CancelButton() As Long
g_CancelFlag = %TRUE
End Function
'----------------------------------------------------------------------------------------------------------------

------------------
Scott
mailto:[email protected][email protected]</A>

[This message has been edited by Scott Turchin (edited November 30, 2000).]

[Dave Navarro]

Supports the HTTP 1.1 protocol (the earlier version will not work with sites like Microsoft.Com or hosts using a single IP address for multiple domains).

Apr 27, 2001 -- Header is displayed to STDOUT and data is written to a file.

'==============================================================================
'
'  WEBGET v1.2 - Grab a file from a web site
'  Copyright (c) 1999-2001 PowerBASIC, Inc. All Rights Reserved.
'
'==============================================================================
 
%port = 80
 
FUNCTION PbMain() AS LONG
 
  LOCAL buffer AS STRING
  LOCAL site   AS STRING
  LOCAL file   AS STRING
  LOCAL save   AS STRING
  LOCAL temp   AS STRING
 
  STDOUT "Webget v1.2 - Grab a file from a web site"
  STDOUT "Copyright (c) 1999-2001 PowerBASIC, Inc. All Rights Reserved."
  STDOUT ""
 
  IF LEN(COMMAND$) = 0 OR COMMAND$ = "/?" THEN
    STDOUT "Usage: webget url/file"
    STDOUT ""
    STDOUT "   Ex: webget <A HREF="http://www.powerbasic.com/index.html"" TARGET=_blank>http://www.powerbasic.com/index.html"</A> 
    EXIT FUNCTION
  END IF
 
  site = EXTRACT$(LTRIM$(LCASE$(COMMAND$),"http://"), "/")
 
  IF LEN(site) = 0 THEN
    STDOUT "Error!  You must specify a web site."
    EXIT FUNCTION
  END IF
 
  file = TRIM$(MID$(COMMAND$, INSTR(LCASE$(COMMAND$), site) + LEN(site)))
 
  IF LEN(file) = 0 THEN
    STDOUT "Error!  You must specify a file"
    EXIT FUNCTION
  END IF
 
  save = MID$(file, INSTR(-1, file, "/") + 1)
 
  IF LEN(save) = 0 THEN
    save = EXTRACT$(LTRIM$(site, "www."), ".") + ".html"
  END IF
 
  STDOUT "Connecting to " & site & " ..."
 
  TCP OPEN PORT %port AT site AS #1 TIMEOUT 30
 
  IF ERR THEN
    STDOUT "Could not connect to " & site
    EXIT FUNCTION
  END IF
 
  STDOUT "Retrieving " & site & file & " to " & save & " ..."
 
  TCP PRINT #1, "GET " & file & " HTTP/1.1"
  TCP PRINT #1, "Accept: */*"
  TCP PRINT #1, "Accept-Language: en-us"
  TCP PRINT #1, "Host: " & site
  TCP PRINT #1, "Pragma: no-cache"
  TCP PRINT #1, "Referer: <A HREF="http://www.powerbasic.com/"" TARGET=_blank>http://www.powerbasic.com/"</A> 
  TCP PRINT #1, "UserAgent: webget 1.2 (www.powerbasic.com)
  TCP PRINT #1, ""
 
  DO
     TCP RECV #1, 4096, buffer
     temp = temp & buffer
  LOOP WHILE LEN(buffer)
 
  buffer = REMAIN$(temp, $CRLF & $CRLF)
  temp   = EXTRACT$(temp, $CRLF & $CRLF)
 
' ** Display the header information
  STDOUT temp
 
' ** Write the data section to a file
  OPEN save FOR BINARY AS #2
     SETEOF #2
     PUT$ #2, buffer
  CLOSE #2
 
  TCP CLOSE #1
 
END FUNCTION

------------------
Home of the BASIC Gurus
www.basicguru.com



[This message has been edited by Dave Navarro (edited April 27, 2001).]