! cgi-lib.sqh
! Copyright (C) 2000 Ray Ontko & Company
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU Lesser General Public License as published by
! the Free Software Foundation; either version 2 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; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
! http://www.gnu.org/
!
!++
! cgi-lib.sqh
! 
!  This library is designed to allow SQR to handle http requests using the
! CGI (Common Gateway Interface) Standard.
!

! CGI_PARAM_SIZE will default to 100.  If a program needs to receive 
! more than 100 parameters, CGI_PARAM_SIZE will need to be set in that
! program before this file is included.
!
!GLOBALS
!   #g_cgi_header_printed -- indicates whether the ContentType header has
!                            been sent for a cgi call.  If it has subsequent
!                            calls to PrintHeader have no effect.
!   #g_cgi_set_cookies    -- the number of cookies that have been set
!   #g_cgi_read_cookies   -- the number of cookies read
!   #g_cgi_params         -- the number of CGI parameters
!--
!
!Modification history
!WHO            When        What
! Eric Eastman   1996-02-09  Created
! EE             1996-09-05  Changed procedure read back to using a loop of
!                               Input commands
! Ray Ontko      1999-08-11  Changed procedure "read" to use READ instead
!                               of INPUT
! EE             1999-12-16  Added Cookie handling
! EE             1999-12-16  Added GetRemmoteAddress
! EE             2000-05-26  Added ShowFile, improved hex to decimal
!                               conversion

#IFNDEF CGI_PARAM_SIZE
#DEFINE CGI_PARAM_SIZE 100
#ENDIF

#IFNDEF CGI_MAX_COOKIES
#DEFINE CGI_MAX_COOKIES 100
#ENDIF

!These defines cause the procedure "read" open standard input as a file and
!read from it rather than use the "input" command.  This is done because
!certain versions of SQR don't handle large amounts well with the input
!command.
#define USE_STDIN_OPEN
#define STDIN_NO 1001
#define STDIN_MAX 32767
#define STDIN_NAME /dev/stdin

#define SHOWFILE_NO 1002
#define SHOWFILE_REC 1000

begin-setup
create-array
   NAME=CGI_Params
   SIZE={CGI_PARAM_SIZE}
   FIELD=name:char
   FIELD=value:char
create-array
   NAME=CGI_Read_Cookies
   SIZE={CGI_MAX_COOKIES}
   FIELD=name:char
   FIELD=value:char
create-array
   NAME=CGI_Set_Cookies
   SIZE={CGI_MAX_COOKIES}
   FIELD=name:char
   FIELD=value:char
   FIELD=expires:char
   FIELD=path:char
   FIELD=domain:char
   FIELD=secure:char
end-setup

! #define REQUEST_LOG tmp/logs/cgi-sqr.log
! #define REQUEST_FILENO 1005
!------------------------------ ReadParse ------------------------------
! ReadParse determines the method type used in the request and returns
! the parameters as an array of name-value pairs in the array CGI_Params
! #num_vars returns number of parameters
! successfully parsed also stores this value in the global variable
! #g_cgi_Params

begin-procedure ReadParse (:#num_vars)

  do  GetMethod($method)
! Read in text
  if $method = 'GET'
    let $in = getenv('QUERY_STRING')
  else
    if $method = 'POST'
      let #length =to_number(getenv('CONTENT_LENGTH'))
      do read($in,#length)
    end-if
  end-if

#IFDEF DEBUG
  show $in '<P>' #length
#ENDIF

#ifdef REQUEST_LOG
  open {REQUEST_LOG} as {REQUEST_FILENO} for-append record=20000:vary
  write {REQUEST_FILENO} from $method
  write {REQUEST_FILENO} from $in
  close {REQUEST_FILENO}
#endif

  let #num_vars = 0
  if $in != ''
    let $cr_lf = chr(13) || chr(11)
    let #last_index = 1
    let #index = instr($in, '&', 1)
    let #flag = 1
    while #flag != 0
      if #index = 0
!if we don't find a & take the whole rest of the line and quit
        let #flag = 0
        let #index = 99999
      end-if
      if #index != #last_index
!take everything between where a & and the one we found last time.
        let $tmp = substr($in, #last_index, #index - #last_index)
!find the first '=' to split into name, value pairs
        let #tmp_ndx = instr($tmp, '=', 1)
        let $name = substr($tmp, 1, #tmp_ndx - 1)
        let $value = substr($tmp, #tmp_ndx +1, 99999) 
!Convert %XX from hex numbers to alphanumeric
        do URL_decode($name)
        let $name = rtrim($name, $cr_lf)
        do URL_decode($value)
        let $value = rtrim($value, $cr_lf)
        put $name $value into CGI_Params(#num_vars) name value
        let #num_vars = #num_vars + 1
      end-if
      let #last_index = #index + 1
      let #index = instr($in, '&', #last_index)
    end-while
  end-if
  let #_g_cgi_Params = #num_vars
end-procedure !ReadParse

!---------------------------------- URL_decode ------------------------
!Certain characters have a special meaning in URLs (eg. +, =, &, ;, ?, %)
!These are replaced with '%xx' where xx is the two digit hex ascii code for
!the character.  For example "=" is ASCII 61 and so is replaced with "%3D"
begin-procedure URL_decode(:$str)
!replace +'s with spaces
   let $str = translate($str,'+',' ')
   let #hex_ndx = instr($str,'%',1)
   let #last_ndx = 1
   while #hex_ndx
      let $temp = substr($str,#hex_ndx + 1,2)
      do hex2num($temp, #num_val)
      if #num_val != -1
         let $str = substr($str, 1,#hex_ndx -1) || chr(#num_val) ||
                    substr($str, #hex_ndx +3 ,9999)
      end-if
      let #hex_ndx = instr($str,'%',#hex_ndx + 1)
   end-while
end-procedure URL_decode

!---------------------------------- URL_encode ------------------------
!This is the inverse of URL_decode
!Here is the list of characters to be replaced:
!  ASCII Hex
! +   43  2B
! ;   59  3B
! &   38  26
! =   61  3D
! ?   63  3F
! %   37  25
begin-procedure URL_encode(:$str)
   move 0 to #ndx
   while #ndx < length($str)
      add 1 to #ndx
      let $chr = substr($str, #ndx, 1)
      evaluate $chr
         when = '+'
            let $str = substr($str, 1, #ndx - 1) || '%2B' ||
                  substr($str, #ndx + 1, 9999)
         when = ''
            let $str = substr($str, 1, #ndx - 1) || '%3B' ||
                  substr($str, #ndx + 1, 9999)
         when = '&'
            let $str = substr($str, 1, #ndx - 1) || '%26' ||
                  substr($str, #ndx + 1, 9999)
         when = '='
            let $str = substr($str, 1, #ndx - 1) || '%3D' ||
                  substr($str, #ndx + 1, 9999)
         when = '?'
            let $str = substr($str, 1, #ndx - 1) || '%3F' ||
                  substr($str, #ndx + 1, 9999)
         when = '%'
            let $str = substr($str, 1, #ndx - 1) || '%25' ||
                  substr($str, #ndx + 1, 9999)
      end-evaluate
      add 1 to #ndx
   end-while
!replace spaces with +'s
   let $str = translate($str,' ','+')
end-procedure URL_encode

!-------------------------------------- hex2num ------------------------
begin-procedure hex2num($hex, :#num)
  let #count = 0
  let #length = length($hex)
  let #num = 0
  while #count < #length and #num != -1
    let #num = #num * 16
    let #count = #count + 1
    let $tmp = substr($hex, #count, 1)
    uppercase $tmp
    let #tmp = instr('0123456789ABCDEF', $tmp, 1) - 1
    if #tmp = -1
      move -1 to #num
    else
      add #tmp to #num
    end-if
  end-while
end-procedure !hex

!-------------------------------------- read ---------------------------
! SQR can't really read a given number of bytes from stdin, so we have to
! fake it.  Ordinarily, CGI scripts just need to read one line, but in
! case #length is greater than the MAXLEN used here, we loop until
! we have enough characters, and assume that we will reach 
! that point before the input runs out and SQR aborts....
! (Note that if we leave off MAXLEN then it defaults to 256 or so, at least
! in SQR v.3.0.8.)
!
! I have modified this to use READ on stdin instead of 
! using the INPUT statement.  It seems to work for input lines
! of up to 32767 bytes.
! -- Ray

begin-procedure read (:$text, #length)
#ifdef USE_STDIN_OPEN
  open '{STDIN_NAME}' as {STDIN_NO} for-reading record={STDIN_MAX}:vary
  while length($text) < #length
     read {STDIN_NO} into $line:{STDIN_MAX}
     if #_end-file
        break
     end-if
     concat $line with $text
  end-while
  close {STDIN_NO}
#else
  move '' to $text
  while length($text) < #length
     input $line MAXLEN=99999 TYPE=CHAR NOPROMPT
     concat $line with $text
  end-while
#end-if
#debug let #len = length($text)
#debug show '#length = ' #length edit 999,999
#debug show '#len = ' #len edit 999,999
#debug show '$text = ' $text
end-procedure !read

!----------------------------------- PrintHeader -----------------------
! PrintHeader
! writes to STDOUT the magic line which tells WWW that we're an HTML
! document
! 1999-12-16 EE Also writes the headers for any cookies set.

begin-procedure PrintHeader
  if not #g_cgi_header_printed
    do ShowCookieHeaders
    show 'Content-type: text/html'
    show ''
    show ''
    move 1 to #g_cgi_header_printed
  end-if
end-procedure

!----------------------------------- Redirect -------------------------
! This should be called instead of PrintHeader.  It will re-direct the 
! browser to the new URL.  This simple procedure is here because
! these headers are VERY picky about format.
! 1999-12-16 EE Added ShowCookieHeaders
!
! Note:  At least with the apache webserver some relative redirections appear
!        To be handled by the server with the result that cookies are not
!        set and the browser location bar will show the original location.
!        To ensure that the HTTP headers are actually sent to the browser,
!        use a full URL (eg. http://www.ontko.com/cgi-bin/feeback.pl )
!
begin-procedure Redirect($URL)
show 'Location: ' $URL
do ShowCookieHeaders
show ''
show ''
end-procedure Redirect

!----------------------------------- GetMethod -------------------------
! Returns the method used in the CGI request

begin-procedure GetMethod (:$Method)
  let $Method = getenv('REQUEST_METHOD')
end-procedure GetMethod

!----------------------------------- GetRemoteAddress -------------------------
! Returns the IP address of the client

begin-procedure GetRemoteAddress (:$address)
  let $address = getenv('REMOTE_ADDR')
end-procedure GetRemoteAddress

!-------------------------------------- MyURL --------------------------
! Returns a URL to the script
begin-procedure MyURL (:$URL)
  let $temp  = getenv('SERVER_NAME')
  let $temp2 = getenv('SCRIPT_NAME')
  string 'http://' $temp $temp2 by '' into $URL
end-procedure MyURL

!------------------------------------- GetField ------------------------
!searches through the CGI_Params array and returns the value field where
!the name field equals $key
begin-procedure GetField ($key, :$value)
  let $value = ''
  move 0 to #count
  move 0 to #notfirst
  let $separator = chr(1)
  while #count < #_g_cgi_Params
    get $tmp_name $tmp_value from CGI_Params(#count) name value
    if $tmp_name = $key
      if #notfirst
         concat $separator with $value
      end-if
      move 1 to #notfirst
      concat $tmp_value with $value
    end-if
    ADD 1 to #count
  end-while
end-procedure GetField

!------------------------------------ PopValue -------------------------
begin-procedure PopValue(:$field, :$new_value)
  let $separator = chr(1)
  let #index = instr($field, $separator, 1)
  if #index = 0
    move $field to $new_value
    move '' to $field
  else
    let $new_value = substr($field, 1, #index -1)
    let $field = substr($field, #index + 1, 99999)
  end-if
end-procedure PopValue

!------------------------------------ GetUser --------------------------
begin-procedure GetUser(:$username)
  let  $username = getenv('REMOTE_USER')
end-procedure GetUser

!------------------------------------ GetReferer -----------------------
begin-procedure GetReferer(:$url)
  let  $url = getenv('HTTP_REFERER')
end-procedure GetUser

!------------------------------------ PrintVariables -------------------
! Nicely formats variables in the array CGI_Params
! And prints the HTML string.
begin-procedure PrintVariables LOCAL
  show '<DL COMPACT>'
  let #count = 0
  while #count < #_g_cgi_Params
    get $tmp_name $tmp_value from CGI_Params(#count) name value
    show '<DT><B>' $tmp_name '</B><DD><I>' $tmp_value '</I><BR>'
    let #count = #count + 1
  end-while
  show '</DL>'
end-procedure !PrintVariables

!------------------------------------ ReadCookies ----------------------
! The cookies come in the environment variable "HTTP_COOKIE"  They are
! separated by a semicolon and a space, "; ".
!
begin-procedure ReadCookies(:#num_cookies)
move 0 to #num_cookies

let $cookies = getenv('HTTP_COOKIE')

while $cookies != ''
   let #ndx = instr($cookies, '; ', 1)
   if #ndx = 0
      move $cookies to $this_cookie
      move '' to $cookies
   else
      let $this_cookie = substr($cookies, 1, #ndx - 1)
      let $cookies = substr($cookies, #ndx + 2, 9999)
   end-if
   let #ndx = instr($this_cookie, '=', 1)
   if #ndx = 0
      move $this_cookie to $name
      move '' to $value
   else
      let $name = substr($this_cookie, 1, #ndx -1)
      let $value = substr($this_cookie, #ndx + 1, 9999)
   end-if
   do URL_decode($name)
   do URL_decode($value)
   put $name $value into CGI_Read_Cookies(#num_cookies) name value
   add 1 to #num_cookies
end-while

move #num_cookies to #_g_cgi_read_cookies
end-procedure ReadCookies

!------------------------------------ GetCookie ----------------------
!searches through the CGI_Read_cookies array and returns the value
!cookie where the name field equals $key
begin-procedure GetCookie($key, :$value)
  let $value = ''
  move 0 to #count
  while #count < #_g_cgi_read_cookies
    get $tmp_name $tmp_value from CGI_Read_Cookies(#count) name value
    if $tmp_name = $key
      move $tmp_value to $value
      break
    end-if
    ADD 1 to #count
  end-while
end-procedure GetCookie

!------------------------------------ SetCookie ----------------------
!$name and $value are required; the rest are optioal.
!$expires is a date in the form [wdy, ]DD-Mon-YYYY HH:MM:SS GMT (in
!  Greenwich Mean Time).  If omitted the cookie will last for the current
!  session of the browser.
!$path is the start of the path within the webserver that will be sent
!  the cookie A path of "/foo" will be sent when the URL
!  "http://some.server.com/foobar.html" is requested.  The default is to
!  send the cookie to those URL's with the same path as the current one.
!$domain matches the end of the domain name (i.e. ".server.com" matches
!  some.server.com and another.server.com)  The default is to only send
!  the cookie back to the host it came from.
!$secure if this = "secure" this cookie will only be sent over SSL
begin-procedure SetCookie($name, $value, $expires, $path, $domain, $secure)
do URL_encode($name)
do URL_encode($value)
put $name $value $expires $path $domain $secure
      into CGI_Set_Cookies(#_g_cgi_set_cookies)
      name value expires path domain secure
add 1 to #_g_cgi_set_cookies
end-procedure SetCookie

!--------------------------------- ShowCookieHeaders -------------------
! Sets any cookies in CGI_Set_Cookies
begin-procedure ShowCookieHeaders LOCAL
  move 0 to #count
  while #count < #_g_cgi_set_cookies
    get $name $value $expires $path $domain $secure
          from CGI_Set_Cookies(#count)
          name value expires path domain secure
    if $expires != ''
       string ' expires=' $expires ';' by '' into $options
    end-if
    if $path != ''
       string $options ' path=' $path ';' by '' into $tmp
       move $tmp to $options
    end-if
    if $domain != ''
       string $options ' domain=' $domain ';' by '' into $tmp
       move $tmp to $options
    end-if
    if upper($secure) = 'SECURE'
       string $options ' secure' by '' into $tmp
       move $tmp to $options
    end-if
    show 'Set-cookie: ' $name '=' $value ';' $options
    add 1 to #count
  end-while
end-procedure ShowCookieHeaders

!------------------------------------ PrintCookies -------------------
! Nicely formats cookies in the array CGI_Read_Cookies
! And prints the HTML string.
begin-procedure PrintCookies LOCAL
  show 'Cookies:'
  show '<DL COMPACT>'
  let #count = 0
  while #count < #_g_cgi_read_cookies
    get $tmp_name $tmp_value from CGI_Read_Cookies(#count) name value
    show '<DT><B>' $tmp_name '</B><DD><I>' $tmp_value '</I><BR>'
    let #count = #count + 1
  end-while
  show '</DL>'
end-procedure PrintCookies

!------------------------------------ num2hex ------------------------
begin-procedure num2hex(#num,:$hex)
move '' to $hex
move #num to #temp
while #temp > 0
   let #mod = mod(#temp, 16)
   let #temp = floor(#temp / 16)
   let $hex = substr('0123456789ABCDEF', #mod +1, 1) || $hex
end-while
end-procedure num2hex

!--------------------------------- ShowFile --------------------------
begin-procedure ShowFile($filename)
open $filename as {SHOWFILE_NO} for-reading record={SHOWFILE_REC}
read {SHOWFILE_NO} into $line:{SHOWFILE_REC}
while not #_end-file
   show $line
   read {SHOWFILE_NO} into $line:{SHOWFILE_REC}
end-while
end-procedure ShowFile