'==============================================================================
'
'  CGI code for the PowerBASIC Console Compiler 2.0 or later
'
'  Note:  The POST method only works with Microsoft compatible web servers
'         including:  IIS, Peer Web Server, Personal Web Server, WebSite,
'         EMWAC, and Apache NT.
'
'  Last update: March 14, 2000
'
'==============================================================================
'=============================[ Global Variables ]=============================
GLOBAL cgiContent AS STRING
'==========================[ Environment Variables ]===========================
'------------------------------------------------------------------------------
' Return the user authentication and the script is protected. If server
' supports???
'
FUNCTION Auth_Type() AS STRING
  FUNCTION = ENVIRON$("AUTH_TYPE")
END FUNCTION

'------------------------------------------------------------------------------
' Return the length of the input string from the form
'
FUNCTION Content_Length() AS LONG
  FUNCTION = VAL( ENVIRON$("CONTENT_LENGTH") )
END FUNCTION

'------------------------------------------------------------------------------
' Return the content type of data supplied from the server.
'
FUNCTION Content_Type() AS STRING
  FUNCTION = ENVIRON$("CONTENT_TYPE")
END FUNCTION

'------------------------------------------------------------------------------
' Current document file name.
'
FUNCTION Document() AS STRING
  FUNCTION = ENVIRON$("DOCUMENT")
END FUNCTION

'------------------------------------------------------------------------------
' Virtual path to the current document
'
FUNCTION Document_URI() AS STRING
  FUNCTION = ENVIRON$("DOCUMENT_URI")
END FUNCTION

'------------------------------------------------------------------------------
' Return the current date in GMT
'
FUNCTION Date_GMT() AS STRING
  FUNCTION = ENVIRON$("DATE_GMT")
END FUNCTION

'------------------------------------------------------------------------------
' Return the current local date to the server.
'
FUNCTION Date_Local() AS STRING
  FUNCTION = ENVIRON$("DATE_LOCAL")
END FUNCTION

'------------------------------------------------------------------------------
' Return the gateway interface (eg: "CGI 1.1")
'
FUNCTION Gateway_Interface() AS STRING
  FUNCTION = ENVIRON$("GATEWAY_INTERFACE")
END FUNCTION

'------------------------------------------------------------------------------
' Last edit date of the document.
'
FUNCTION Last_Modified() AS STRING
  FUNCTION = ENVIRON$("LAST_MODIFIED")
END FUNCTION

'------------------------------------------------------------------------------
' Local machine IP address
'
FUNCTION Local_Addr() AS STRING
  FUNCTION = ENVIRON$("LOCAL_ADDR")
END FUNCTION

'------------------------------------------------------------------------------
' Windows NT account details for the user.
'
FUNCTION Logon_User() AS STRING
  FUNCTION = ENVIRON$("LOGON_USER")
END FUNCTION

'------------------------------------------------------------------------------
' Return the extra path information as given by the client
'
FUNCTION Path_Info() AS STRING
  FUNCTION = ENVIRON$("PATH_INFO")
END FUNCTION

'------------------------------------------------------------------------------
' Return the server provided translated version of Path_Info.
'
FUNCTION Path_Translated() AS STRING
  FUNCTION = ENVIRON$("PATH_TRANSLATED")
END FUNCTION

'------------------------------------------------------------------------------
' Return the method used to send data from the web server to the application
'
FUNCTION Query_Method() AS STRING
  FUNCTION = ENVIRON$("QUERY_METHOD")
END FUNCTION

'------------------------------------------------------------------------------
' CGI data
'
FUNCTION Query_String() AS STRING
  FUNCTION = ENVIRON$("QUERY_STRING")
END FUNCTION
'------------------------------------------------------------------------------
' Raw CGI data
'
FUNCTION Query_String_Unescaped() AS STRING
  FUNCTION = ENVIRON$("QUERY_STRING_UNESCAPED")
END FUNCTION
'------------------------------------------------------------------------------
' Returns the remote users connection address (not email address)
'
FUNCTION Remote_Addr() AS STRING
  FUNCTION = ENVIRON$("REMOTE_ADDR")
END FUNCTION

'------------------------------------------------------------------------------
' Returns the clients reverse DNS of their IP address
'
FUNCTION Remote_Host() AS STRING
  LOCAL remote AS STRING
  LOCAL ip     AS LONG
  HOST ADDR Remote_Addr TO ip
  HOST NAME ip TO remote
  FUNCTION = remote
END FUNCTION

'------------------------------------------------------------------------------
' Return the user name retrieved from the server. If the client supports RFC931
' identification.
'
FUNCTION Remote_Ident() AS STRING
  FUNCTION = ENVIRON$("REMOTE_IDENT")
END FUNCTION

'------------------------------------------------------------------------------
' Return the username authentication and the script is protected. If server
' supports???
'
FUNCTION Remote_User() AS STRING
  FUNCTION = ENVIRON$("REMOTE_USER")
END FUNCTION

'------------------------------------------------------------------------------
' Return the method used to send data from the web server to the application
'
FUNCTION Request_Method() AS STRING
  FUNCTION = ENVIRON$("REQUEST_METHOD")
END FUNCTION

'------------------------------------------------------------------------------
' Return the name of the script which launched the CGI app
'
FUNCTION Script_Name() AS STRING
  FUNCTION = ENVIRON$("SCRIPT_NAME")
END FUNCTION

'------------------------------------------------------------------------------
' Return the server's host name
'
FUNCTION Server_Name() AS STRING
  FUNCTION = ENVIRON$("SERVER_NAME")
END FUNCTION

'------------------------------------------------------------------------------
' Return the port used to communicate with the server
'
FUNCTION Server_Port() AS LONG
  FUNCTION = VAL( ENVIRON$("SERVER_PORT") )
END FUNCTION

'------------------------------------------------------------------------------
' Return true (-1) if the connection is secure
'
FUNCTION Server_Port_Secure() AS LONG
  FUNCTION = ISFALSE ENVIRON$("SERVER_PORT_SECURE") = "0"
END FUNCTION

'------------------------------------------------------------------------------
' Return the name and revision of the information protocol from the server
'
FUNCTION Server_Protocol() AS STRING
  FUNCTION = ENVIRON$("SERVER_PROTOCOL")
END FUNCTION

'------------------------------------------------------------------------------
' Return the name and version of the server software
'
FUNCTION Server_Software() AS STRING
  FUNCTION = ENVIRON$("SERVER_SOFTWARE")
END FUNCTION

'------------------------------------------------------------------------------
' List of the MIME data types the browser can accept.  Values are seperated
' by commas.
'
FUNCTION Http_Accept() AS STRING
  FUNCTION = ENVIRON$("HTTP_ACCEPT")
END FUNCTION

'------------------------------------------------------------------------------
'
FUNCTION Http_Accept_Charset() AS STRING
  FUNCTION = ENVIRON$("HTTP_ACCEPT_CHARSET")
END FUNCTION

'------------------------------------------------------------------------------
'
FUNCTION Http_Accept_Encoding() AS STRING
  FUNCTION = ENVIRON$("HTTP_ACCEPT_ENCODING")
END FUNCTION

'------------------------------------------------------------------------------
' List of the human languages the client can accept.
'
FUNCTION Http_Accept_Language() AS STRING
  FUNCTION = ENVIRON$("HTTP_ACCEPT_LANGUAGE")
END FUNCTION

'------------------------------------------------------------------------------
'
FUNCTION Http_Connection() AS STRING
  FUNCTION = ENVIRON$("HTTP_CONNECTION")
END FUNCTION

'------------------------------------------------------------------------------
' Retrieves the Cookie string detected by the server
'
FUNCTION Http_Cookie() AS STRING
  FUNCTION = ENVIRON$("HTTP_COOKIE")
END FUNCTION

'------------------------------------------------------------------------------
' Returns the remote clients email address (if available); only works with
' Netscape
'
FUNCTION Http_From() AS STRING
  FUNCTION = ENVIRON$("HTTP_FROM")
END FUNCTION

'------------------------------------------------------------------------------
'
FUNCTION Http_Host() AS STRING
  FUNCTION = ENVIRON$("HTTP_HOST")
END FUNCTION

'------------------------------------------------------------------------------
'
FUNCTION Http_Pragma() AS STRING
  FUNCTION = ENVIRON$("HTTP_PRAGMA")
END FUNCTION

'------------------------------------------------------------------------------
' Return the URL of the document that the client points to before accessing the
' CGI application.
'
FUNCTION Http_Referer() AS STRING
  FUNCTION = ENVIRON$("HTTP_REFERER")
END FUNCTION

'------------------------------------------------------------------------------
' Product name of the clients browser software.
'
FUNCTION Http_User_Agent() AS STRING
  FUNCTION = ENVIRON$("HTTP_USER_AGENT")
END FUNCTION

'------------------------------------------------------------------------------
' Returns if secure pages are turned on or off
'
FUNCTION HttpS() AS STRING
  FUNCTION = ENVIRON$("HTTPS")
END FUNCTION
'------------------------------------------------------------------------------
' Return the physical path of the CGI application
'
$IF NOT %DEF(%WINAPI)
  DECLARE FUNCTION GetModuleFileName LIB "KERNEL32.DLL" ALIAS "GetModuleFileNameA" (BYVAL hModule AS LONG, lpFileName AS ASCIIZ, BYVAL nSize AS LONG) AS LONG
$ENDIF
FUNCTION AppPath() AS STRING
  LOCAL p AS ASCIIZ * 256
  LOCAL x AS LONG
  GetModuleFileName 0, p, SIZEOF(p)
  x = INSTR(-1, p, "\")
  FUNCTION = LEFT$(p, x)
END FUNCTION
$IF NOT %DEF(%WINAPI)
  DECLARE FUNCTION ReadFile LIB "KERNEL32.DLL" ALIAS "ReadFile" (BYVAL hFile AS LONG, lpBuffer AS ANY, BYVAL nNumberOfBytesToRead AS LONG, lpNumberOfBytesRead AS LONG, BYVAL lpOverlapped AS LONG) AS LONG
$ENDIF
'------------------------------------------------------------------------------
' Read data from the CGI script
'
FUNCTION cgiRead() AS STRING
  LOCAL Temp AS STRING
  LOCAL b    AS LONG
  SELECT CASE Request_Method
    CASE "GET", "PUT", "HEAD"
      FUNCTION = ENVIRON$("QUERY_STRING")
    CASE "POST"
      IF Content_Length THEN
        temp = SPACE$(Content_Length)
        ReadFile GETSTDIN, BYVAL STRPTR(temp), Content_Length, b, BYVAL 0&
      END IF
      FUNCTION = Temp
    CASE ELSE   'assume the command line
      FUNCTION = COMMAND$
  END SELECT
END FUNCTION

'------------------------------------------------------------------------------
' Write a string to the web server and automatically take care of the header
'
SUB cgiWrite(BYVAL x AS STRING)
  STATIC header AS LONG
  IF ISFALSE header THEN
    IF ISFALSE LEN(cgiContent) THEN
      cgiContent = "Content-type: text/html"
    END IF
    STDOUT cgiContent + CHR$(13, 10)
    header = -1
  END IF
  REPLACE "''" WITH CHR$(34) IN x
  STDOUT x
END SUB

'------------------------------------------------------------------------------
' Write a string to the web server and automatically take care of the header
'
SUB cgiWriteLn(BYVAL x AS STRING)
  cgiWrite x & "<BR>"
END SUB

'------------------------------------------------------------------------------
' Decode all of the special characters in a CGI string
'
FUNCTION cgiDecode(BYVAL t AS STRING) AS STRING
  DIM b_in  AS BYTE PTR
  DIM b_out AS BYTE PTR
  DIM h     AS STRING PTR * 2
  DIM a     AS ASCIIZ PTR
  IF LEN(t) = 0 THEN
    EXIT FUNCTION
  END IF
  b_in  = STRPTR(t)
  b_out = b_in
  DO
    IF @b_in = 43 THEN          'convert plus to space
      @b_out = 32
    ELSEIF @b_in = 37 THEN      'process special chars
      h = b_in + 1
      @b_out = VAL("&H" + @h)
      b_in = b_in + 2
    ELSE
      @b_out = @b_in
    END IF
    INCR b_in
    INCR b_out
  LOOP UNTIL @b_in = 0
  @b_out = 0
  a = STRPTR(t)
  FUNCTION = @a
END FUNCTION

'------------------------------------------------------------------------------
' For best effect, do not decode the params string first
'
FUNCTION ParseParams(BYVAL params AS STRING, Param() AS STRING) AS LONG
  LOCAL c AS LONG
  LOCAL x AS LONG
  c = PARSECOUNT(params, "&")
  REDIM Param(c) AS STRING
  FOR x = 1 TO c
    Param(x) = PARSE$(params, "&", x)
  NEXT x
  FUNCTION = c
END FUNCTION

'------------------------------------------------------------------------------
' Parse raw CGI data and return specified parameter
'
' If the data was posted as "multipart/form-data" then cgiParam
' returns the named MIME section.  You'll need to call mimeDecode
' to get the actual section data.
'
FUNCTION cgiParam(BYVAL param AS STRING, BYVAL which AS STRING) AS STRING
  LOCAL x AS LONG
  LOCAL w AS LONG
  LOCAL l AS LONG
  LOCAL p AS STRING
  LOCAL b AS STRING
  IF INSTR(Content_Type, "multipart/form-data") THEN
    which = "name=""" & which & """"
    ' Get the mime boundary seperator
    b = REMAIN$(Content_Type, "boundary=")
    x = 1
    DO
      x = INSTR(x, param, b)
      IF ISFALSE x THEN
        EXIT DO
      END IF
      x = x + LEN(b)
      IF MID$(param, x, 2) = "--" THEN
        EXIT DO
      ELSE
        x = x + 2
      END IF
      l = INSTR(x, param, b)
      IF ISFALSE l THEN
        EXIT DO
      ELSE
        l = l - x - 2
      END IF
      p = EXTRACT$(x, param, $CRLF)
      IF INSTR(p, which) THEN
        FUNCTION = MID$(param, x, l)
        EXIT FUNCTION
      END IF
      x = x + l
    LOOP
    EXIT FUNCTION
  ELSE
    which = which + "="
    FOR x = 1 TO PARSECOUNT(param, "&")
      p = PARSE$(param, "&", x)
      IF LEFT$(UCASE$(p), LEN(which)) = UCASE$(which) THEN
        FUNCTION = cgiDecode(MID$(p, LEN(which) + 1))
        EXIT FUNCTION
      END IF
    NEXT
  END IF
END FUNCTION

'------------------------------------------------------------------------------
' Parse MIME file section and return data
'
FUNCTION mimeDecode(buffer AS STRING, content AS STRING, file AS STRING) AS STRING
  LOCAL x   AS LONG
  LOCAL tmp AS STRING
  x = INSTR(buffer, $CRLF & $CRLF)
  IF ISFALSE x THEN
    EXIT FUNCTION
  END IF
  FUNCTION = MID$(buffer, x + 4)
  tmp = LCASE$(LEFT$(buffer, x - 1))
  x = INSTR(tmp, "content-type:")
  IF x THEN
    content = TRIM$(EXTRACT$(MID$(tmp, x), $CRLF))
  END IF
  x = INSTR(tmp, "filename=")
  IF x THEN
    file = TRIM$(EXTRACT$(MID$(tmp, x), $CRLF), ANY " """)
  END IF
END FUNCTION
'------------------------------------------------------------------------------
$IF NOT %DEF(%WINAPI)
TYPE SYSTEMTIME
  wYear AS INTEGER
  wMonth AS INTEGER
  wDayOfWeek AS INTEGER
  wDay AS INTEGER
  wHour AS INTEGER
  wMinute AS INTEGER
  wSecond AS INTEGER
  wMilliseconds AS INTEGER
END TYPE
DECLARE SUB GetSystemTime LIB "KERNEL32.DLL" ALIAS "GetSystemTime" (lpSystemTime AS SYSTEMTIME)
DECLARE FUNCTION VariantTimeToSystemTime LIB "OLEAUT32.DLL" ALIAS "VariantTimeToSystemTime" (BYVAL vbtime AS DOUBLE, lpSystemTime AS SYSTEMTIME) AS LONG
DECLARE FUNCTION SystemTimeToVariantTime LIB "OLEAUT32.DLL" ALIAS "SystemTimeToVariantTime" (lpSystemTime AS SYSTEMTIME, vbtime AS DOUBLE) AS LONG
DECLARE FUNCTION GetDateFormat LIB "KERNEL32.DLL" ALIAS "GetDateFormatA" (BYVAL Locale AS LONG, BYVAL dwFlags AS LONG, lpDate AS SYSTEMTIME, lpFormat AS ASCIIZ, lpDateStr AS ASCIIZ, BYVAL cchDate AS LONG) AS LONG
DECLARE FUNCTION GetTimeFormat LIB "KERNEL32.DLL" ALIAS "GetTimeFormatA" (BYVAL Locale AS LONG, BYVAL dwFlags AS LONG, lpTime AS SYSTEMTIME, lpFormat AS ASCIIZ, lpTimeStr AS ASCIIZ, BYVAL cchTime AS LONG) AS LONG
$ENDIF
'------------------------------------------------------------------------------
FUNCTION CookieDate(BYVAL days AS LONG) AS STRING
  LOCAL d  AS ASCIIZ * 64
  LOCAL t  AS ASCIIZ * 64
  LOCAL st AS SYSTEMTIME
  LOCAL v  AS DOUBLE
  GetSystemTime st
  SystemTimeToVariantTime st, v
  v = v + days
  VariantTimeToSystemTime v, st
  GetDateFormat 0, 0, st, "ddd',' dd'-'MMM'-'yyyy", d, 64
  GetTimeFormat 0, 0, st, "HH':'mm':'ss", t, 64
  FUNCTION = d & " " & t & " GMT"
END FUNCTION
'------------------------------------------------------------------------------
SUB SetCookie(BYVAL cookie AS STRING, BYVAL value AS STRING, _
              BYVAL days AS LONG, BYVAL url AS STRING)
  LOCAL s AS STRING
  LOCAL e AS STRING
  IF days = 0 THEN
    e = "expires=" & CookieDate(30) & "; "
  ELSEIF days > 0 THEN
    e = "expires=" & CookieDate(days) & "; "
  END IF
  s = cookie & "=" & value & "; " & e & "path=" & url & ";"
  STDOUT "Set-Cookie: " & s
END SUB

'------------------------------------------------------------------------------
' Send an email message
'
FUNCTION SmtpMail(BYVAL mailto AS STRING, _
                  BYVAL mailfrom AS STRING, _
                  BYVAL subject  AS STRING, _
                  BYVAL message AS STRING _
                 ) AS LONG
  LOCAL buffer    AS STRING
  LOCAL localhost AS STRING
  LOCAL hTcp      AS LONG
  LOCAL ip        AS LONG
  IF LEN(mailto) = 0 THEN
    mailto = $mailto
  END IF
' ** Get the local host name
  HOST ADDR TO hTCP
  HOST NAME hTCP TO localhost
' ** Connect to mail server
  hTCP = FREEFILE
  TCP OPEN "smtp" AT $mailhost AS hTCP
  IF ERR THEN
    buffer = "Error connecting to mailhost"
    GOTO SendError
  ELSE
    TCP LINE hTCP, buffer
    IF LEFT$(buffer, 3) <> "220" THEN
      GOTO SendError
    END IF
  END IF
' ** Greet the $mailhost
  TCP PRINT hTCP, "HELO " + localhost
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "250" THEN
    buffer = "HELO error: " + buffer
    GOTO SendError
  END IF
' ** Tell the $mailhost who we are
  TCP PRINT hTCP, "MAIL FROM: <" + mailfrom + ">"
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "250" THEN
    buffer = "MAIL FROM error: " + buffer
    GOTO SendError
  END IF
' ** Tell the $mailhost who the message is for
  TCP PRINT hTCP, "RCPT TO: <" + mailto + ">"
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "250" THEN
    buffer = "RCPT TO error: " + buffer
    GOTO SendError
  END IF
' ** Send the message
  TCP PRINT hTCP, "DATA"
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "354" THEN
    buffer = "DATA error: " + buffer
    GOTO SendError
  END IF
  TCP PRINT hTCP, "From: <" & mailfrom & ">"
  TCP PRINT hTCP, "To: " + mailto
  TCP PRINT hTCP, "Subject: " & subject
  TCP PRINT hTCP, "X-Mailer: PBCGI v2.0 (www.powerbasic.com)"
  TCP PRINT hTCP, ""
  TCP PRINT hTCP, message
  TCP PRINT hTCP, "."
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "250" THEN
    GOTO SendError
  END IF
' ** Say goodbye
  TCP PRINT hTCP, "QUIT"
  TCP LINE hTCP, buffer
  IF LEFT$(buffer, 3) <> "221" THEN
    buffer = "QUIT error: " + buffer
    GOTO SendError
  END IF
  TCP CLOSE hTCP
  FUNCTION = -1
Done:
  EXIT FUNCTION
SendError:
  TCP CLOSE hTCP
  GOTO Done
END FUNCTION