home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 35 Internet / 35-Internet.zip / gohttp.zip / GoHTTP.v20 < prev    next >
Text File  |  1996-03-27  |  87KB  |  2,078 lines
  1. /* GoHTTP REXX Filter Script for GoServe v2.00+ for OS/2  */
  2. /* by Donald L. Meyer                    */
  3.  
  4. /* Based on the Sample GoServe filter program by Mike Cowlishaw */
  5. /* Be sure to start GoServe with the HTTP option to use this filter */
  6. /*   Notes:                            */
  7. /*  - Do you get REXX Error #41?   Check your TZ Env. variable.    */
  8. /*  - Special Thanks to Norris Couch for the pointer to how to make the    */
  9. /*    procedures' expose statements run onto additional lines.        */
  10. /*  - Plenty of credit goes out to Albert Crosby, U. of Ark., for the addition    */
  11. /*    of the dynamic directory indexing, multiple default index pages, and    */
  12. /*    the idea of chaining filters. Also for the idea of the html footer fn.    */
  13.  
  14. GoHTTPver='2.01.9Q'
  15.  
  16. parse arg source, request, sel                    /* Get arguments */
  17. parse var source myaddr port transaction who clientport .    /* Break out a bit more to be useful. */
  18.  
  19.     /* Pre-Config Initializations  */
  20. Rx. = ''
  21. Dir. = ''
  22. state. = ''
  23.     /* End Pre-Config Inits... */
  24.  
  25.     /* Configuration variables */
  26.  
  27. default =     'index.html',     /* Default document (sent if none specified) */
  28.         'index.htm',
  29.         'index.shtml',
  30.         'welcome.html'
  31.  
  32.             /* Owner IP address(es) */
  33.             /* (may send special requests - put your address(es) here) */
  34.             /* [e.g. '9.11.22.33', or 'ANY' for no checking] */
  35. owner =     '128.174.95.12',
  36.         '128.174.95.247',
  37.         '128.174.95.248',
  38.         '128.174.95.249',
  39.         '127.0.0.1'
  40.  
  41. ServerAdmin = 'dlmeyer@uiuc.edu'    /* Administrator's email address   */
  42.  
  43. CommonLogFile = 'Port'port'.log'    /* Log file name  */
  44. RefererLogFile = 'Reference.log'        /* Log File for 'Referred by:'s     '' -> No logging  */
  45. AgentLogFile = 'Agent.log'        /* Log File for tracking 'User-Agent's     '' -> No logging  */
  46. RedirectFile = 'Redirect.lst'        /* List of URLs to redirect to another site */
  47. AccessFileName = 'htaccess'        /* filename to look for in each directory to find  */
  48.                     /* access control information  */
  49. mapConf = 'conf\imagemap.cnf'        /* filename of the imagemap configuration file.  */
  50.  
  51.     /* Script Aliases, of form ALIAS:PATH  */
  52.     /*  (ALIAS must begin with "cgi-" to denote a CGI active directory...)  */
  53.     /*  (No limit to the number, each pair separated by whitespace)  */
  54. ScriptAliases =     'cgi-bin:d:\GoServe\cgi-bin',
  55.         'cgi-test:d:\Temp'
  56.  
  57. ScriptExtensions = 'exe cmd'
  58.  
  59.     /* Path Aliases, of form ALIAS:PATH  */
  60.     /*  (Each pair separated by whitespace)  */
  61.     /*  No limit to the number of aliases  --  Add additional lines as needed.  */
  62. PathAliases =     'WWW:W:\WWW',
  63.         'DLM:\\THOR\PA_DLM\Web',
  64.         'JLM:\\THOR\PA_JLM\Web',
  65.         'OS2:W:\WWW\OS2'
  66.  
  67. ReverseLookups = 'yes'        /*  Do Reverse DNS Lookups for log - 'yes' or 'no'  */
  68.                 /* Requires RXSOCK be installed if before GoServe v2.02.  */
  69. HPFS_Safe = 0        /*  If '0', keep filenames 8.3...  */
  70. IMap_HandleLocal = 0        /*  If '1', Handle local HTTP URLs from imagemaps in-house.  */
  71. CaseSensitive = 1        /*  If '1', Aliases are treated as case sensitive.  */
  72. StrongChecks = 1        /*  If '1', Always check validity of numbers read from an imagemap map file.  */
  73.                 /*  This will tend to slow imagemap processing while decreasing likelihood of */
  74.                 /*  server crash due to bad format of a map file.        */
  75.  
  76.                 /*  List of servers to forward extra load to.        */
  77.                 /*  Should maintain common document tree to handle all requests  */
  78.                 /*  server entries may contain port information, if necessary.  */
  79. BackupServerList =     'w3.ag.uiuc.edu',
  80.             'odin.ag.uiuc.edu'
  81. LoadThreshold = 0        /*  Allow this many simultaneous connections before attempting  */
  82.                 /*  any load balancing operations...  ('0' disables all balancing)   */
  83. SecureAllRmtCtl = 1        /*  Activates Security checking on all GoRemote access, pages & applies  */
  84.                 /*  0 only checks apply attempts.         */
  85.  
  86. Dir.BuildEnabled = 1        /*  If '1', build dynamic directory indexes. */
  87. /*Dir.Default = 1        *  If '1', display the default HTML file for a directory instead */
  88.                 /*  of creating a dynamic directory index. */
  89. Dir.Info = "readme"         /*  If not '', contains the name of the file that should be displayed */
  90.                 /*  at the beginning of a dynamic directory index. */
  91. Dir.Describe="descript.ion"     /*  If not '', contains the name of the file that contains descriptive */
  92.                 /*  information displayed in a dynamic directory index. */
  93.                 /*  The file should be formatted like a 4OS/2 descript.ion file with */
  94.                 /*  the name of the file followed by the description.  Long file names */
  95.                 /*  containing blanks must be in double quotes. */
  96.   /* unnecessary  - will fold functionality into htaccess   */
  97. Dir.Forbid=".forbid"        /*  If not '', contains the name of a file, that if it exists */
  98.                 /*  in a given directory, no dynamic index is returned. */
  99.     /* Dir.Exclude lists filenames that should not be included in a dynamic directory index */
  100. Dir.Exclude =     Dir.Info Dir.Forbid Dir.Describe,
  101.         'core htaccess passwd trusers',
  102.         Dir.Exclude AccessFileName
  103.  
  104.     /* GoHTTP is being extended to include Secondary Filters.  A Secondary Filter */
  105.     /* is a REXX program that receives all of the information as the primary filter */
  106.     /* and can perform all of the same functionality.  Including */
  107.     /* the ability to call Secondary Filters should not effect any of the existing */
  108.     /* functionality of GoHTTP */
  109.  
  110.     /* Rx.Bin is the directory where the secondary filters are located.  For simplicity */
  111.     /* and security, all secondary filters are located in this directory.      */
  112.     /*  --- This was supposed to be the case, I had to disable due to ---  */
  113.     /*  --- multitasking related problems with changing current directory.  ---  */
  114.  
  115.     /* Set the Rx.Bin variable to '' if you do not want to use secondary filters. */
  116.     /* Warning: Any problem in a secondary filter will probably cause GoServe to crash. */
  117. Rx.Bin = 'D:\GOSERVE\SCRIPTS'
  118.     /* Secondary REXX filter to call upon failure to resolve in this filter.    */
  119. Rx.AltFilter = 'GoFilter.80'
  120.     /* MFC's external REXX function to provide remote control functionality.    */
  121. Rx.GoRemote = 'GoRemote.Rxx'
  122.     /* external REXX function to do "special" local functions...    */
  123. Rx.Special = 'Special.Rxx'
  124.     /* external REXX function to process server-side includes.    */
  125. Rx.Includes = 'DoIncl.Rxx'
  126.     /* external REXX function to dynamically build directory indices.    */
  127. Rx.BuildDir = 'BuildDir.Rxx'
  128.  
  129.     /* Flag to enable post-processing of HTML pages.                */
  130.     /* Rx.EnablePostProcess == 0   -- no post processing                */
  131.     /* Rx.EnablePostProcess == 1   -- all post processing enabled for ".*HTM*"    */
  132.     /* Rx.EnablePostProcess == 2   -- post processing enabled only for ".SHTML"    */
  133. Rx.EnablePostProcess = 1
  134.  
  135.  
  136.     /* external REXX function to add footer info to all HTML pages.  */
  137.     /*   set to '' to disable...                        */
  138. Rx.Footer = 'footer.rxx'        /* Albert's footer is 'Footer.Rxx'    */
  139. Rx.Footer = ''
  140.  
  141.     /* Begin Installation Specific variables */
  142.     /* End Installation Specific variables */
  143.  
  144.     /* End:  Configuration variables */
  145.  
  146.  
  147.     /* Initializations & System variables */
  148. CALL ON ERROR NAME Handler
  149. env='OS2ENVIRONMENT'
  150. ServerName = servername()
  151. PMprint = 1        /* Allows echoing of log info to PMPRINTF.    */
  152.             /* If PMPRINTF is not running, can be set to 0    */
  153.             /* to improve perf. ever-so-slightly...         */
  154.  
  155. Cached = 0        /* Indicates to SendFile() whether completion command   */
  156.             /* has been sent, namely for support for 'File command cache'  */
  157.             /* in GoServe v2.11+  */
  158.  
  159. Secured = ''        /* If the requested file is protected by an authorization scheme,  */
  160.             /* then add 'NOCACHE' to 'FILE' command to avoid bypassing  */
  161.             /* authorization by others...                */
  162.  
  163. Rx.Chained = 0        /* Initialize to 0.  Set to 1 on chaining to alternative filter    */
  164.  
  165. if (stream( Rx.Bin'\*', 'C', 'query exists') == '') then     /* If Rx.Bin dir does not exist    */
  166.    Rx.Bin = directory()                    /* then use current dir.        */
  167.  
  168. _ServerVer = ServerVer()
  169. if (_ServerVer > 2.10) then do
  170.  
  171.     /* Check to see if GoServe has already sent file to client.  */
  172.     /* if so, just do logging chores and leave... */
  173.    if (_ServerVer >= 2.47) then Cached = cached()
  174.    else Cached = completed()    /* must use as proxy for cached()  */
  175.  
  176.    if (_ServerVer >= 2.27) & (Cached == 0) then do 
  177.       'EXTRACT CLIENTS'
  178.       if (LoadThreshold > 0) & (BackupServerList \= '') & (Clients > LoadThreshold) & (Cached == 0) then do
  179.          return response('redirect', 'http://'word(BackupServerList,1)'/'sel)
  180.       end
  181.    end
  182.    else CLIENTS = '?'
  183. end
  184.  
  185. dir = datadir()          /* Data directory (root of all data directories) */
  186.                          /* [must include drive and end in '/'] */
  187.  
  188. if (transaction == '1') then do
  189.    rc = RxFuncAdd("SysLoadFuncs","RexxUtil","SysLoadFuncs")
  190.    call SysLoadFuncs
  191.  
  192.    if (ReverseLookups == 'yes') & (_ServerVer < 2.02) then do
  193.       if RxFuncQuery("SockGetHostByAddr") then
  194.          rc = RxFuncAdd("SockGetHostByAddr","RxSock","SockGetHostByAddr")
  195.    end
  196. end
  197.  
  198. Dir.Build = Dir.BuildEnabled
  199.  
  200. TempDir = value( 'TMP', , env)
  201. if (TempDir == '') then do
  202.    TempDir = value( 'TEMP', , env)
  203.    if (TempDir == '') then TempDir = dir
  204. end
  205. if (right(TempDir,1) \= '\') & (right(TempDir,1) \= '/') then TempDir = TempDir'\'
  206.  
  207. if (HPFS_Safe == 0) then do
  208.    _Port = strip(right(port,3))
  209.    _Transaction = strip(right(transaction,4))
  210. end
  211. else do
  212.    _Port = port
  213.    _Transaction = transaction
  214. end
  215.  
  216. tempfile=TempDir'$'_Transaction'.'_Port                 /* Often used */
  217. CmdFile='F'_Transaction''_Port'.cmd'
  218. RequestToLog = request
  219. server = myaddr
  220. ScriptAlias = 'd:\GoServe\cgi-bin'    /* default script alias - value doesn't really matter */
  221. PassFile = 'Passwd.lst'        /* default userid : password file, mostly for demos  */
  222.  
  223.     /*  Determine the Time Zone, if possible... */
  224. _TZadj = GMTOFFSET()
  225.  
  226. if (_TZadj \= '?') then do
  227.     /* Save it, so I can tell if it changes - Daylight Savings, etc.  */
  228.    _TZoffset = value( 'GMT_OFFSET', _TZadj, env)
  229.  
  230.     /*  If initializing, or GMT offset has changed, recalulate... */
  231.    if (_TZoffset \= _TZadj) then do
  232.       TZhours = (_TZadj / 3600)
  233.       parse var TZhours TZhours'.'TZmins
  234.       TZmins = '0.'TZmins
  235.       TZmins = TZmins * 60
  236.       if (TZmins == 0) then TZmins = '00'
  237.       TZadj = left(TZhours,1)
  238.       if (length(TZhours) == 2) then TZadj = TZadj'0'
  239.       TZadj = TZadj||substr(TZhours,2)||TZmins
  240.       rc = value( 'TZ_OFFSET', TZadj, env)
  241.    end
  242.     /* otherwise, retrieve the value from the process' environment  */
  243.    else TZadj = value( 'TZ_OFFSET', , env)
  244. end
  245. else TZadj = '000'
  246.  
  247. parse var request verb uri protocol .        /* split up the request line */
  248.  
  249. /* Check request */
  250. if (left(protocol,4) \= 'HTTP') & (protocol \= '') then
  251.   return response('badreq', 'specified a protocol that was not HTTP')
  252.  
  253. /* Convert empty selector to default */
  254. if sel='' then do
  255.     /*ALC-- Albert's code to allow multiple default index files... */
  256.    do i=1 to words(default)
  257.       newsel=word(default,i)
  258.       if stream(dir||newsel,'c','query exists')="" then iterate
  259.       sel=newsel
  260.       leave
  261.    end
  262.    uri = sel
  263. end
  264.  
  265.     /* Pull info re: who referred the client to us...  */
  266. Refer = REQFIELD('Referer:')
  267. UserAgent = REQFIELD('User-Agent:')
  268.  
  269. /* Now carry out whichever verbs we support */
  270. file=dir||sel       /* full filename */
  271. select
  272.   when verb='GET' | verb='HEAD' then do
  273.     /* First see if it's a query or image click */
  274.     parse var uri type '?' words
  275.     if words='' then /* common case: do not have a search */ do
  276.  
  277.        file = ParseAliases( dir, sel)
  278.        return SendFile(file)
  279.     end
  280.  
  281.     /* Deal with WebExplorer 1.03 bug -- multiple image click parms when "BACK" is used... */
  282.     do while (pos('?', words) \= 0) 
  283.        parse var words . '?' words
  284.     end
  285.  
  286.     /* Here if a search from GET; call function to do it */
  287.     retCode = search(tempfile, type, words)
  288.  
  289.     return SendFile( retCode)
  290.  
  291.     end /* get */
  292.  
  293.   when verb='POST' then do
  294.     /* This filter only uses POSTs for queries (forms) */
  295.     words = ''
  296.     return search(tempfile, sel, words)      /* this does the search */
  297.     end /* post */
  298.  
  299.   otherwise return response('badreq', 'sent an unknown verb "'verb'"')
  300.   end /* select verb */
  301. /* [cannot reach here] */
  302.  
  303. /* ----------------------------------------------------------------------- */
  304. /* SENDFILE: do the terminal dispatch of the file, and logging */
  305. /* ----------------------------------------------------------------------- */
  306. /*    This is a terminal function -- it terminates the filter... */
  307.  
  308. SendFile: procedure expose default sel request RequestToLog CommonLogFile who name,
  309.    transaction TZadj ReverseLookups ServerName verb tempfile clientport ServerAdmin server,
  310.    port env dir CmdFile Protocol GoHTTPver ScriptAlias AccessFileName Cached Secured,
  311.    PMprint Refer UserAgent RefererLogFile AgentLogFile RedirectFile ScriptExtensions,
  312.    Dir. Rx. SendDir source AddUpdated         /*ALC--  */
  313.  
  314.       parse arg file
  315.  
  316.     /* Thanks to John Voigt for catching my forgetfulness regarding 'CONTROL'  */
  317.       if (file == '') | (word(file,1) == 'FILE') | (word(file,1) == 'STRING') | (word(file,1) == 'VAR') | (word(file,1) == 'CONTROL') then exit file
  318.  
  319.       os2rc = CheckAuth( file)
  320.  
  321.       if (pos('*', file) > 0) then return response('notfound', 'asked for "'sel'", which could not be found')
  322.       if (stream(file, 'c', 'query exists') == '') then do
  323.  
  324.          rc = SysFileTree( translate(file,'\','/'), 'srch', 'B', '*+-*-')
  325.          IsDir = (rc == 0) & (srch.0 == 1)
  326.  
  327. /*         if (stream( file || '\*', 'c', 'query exists') \= '') then    */
  328.           if (IsDir) then
  329.             return response('redirect', 'http:/'sel'/')
  330.  
  331.     /* if CheckAuth() returns a default filename for the directory,    */
  332.     /* and we are trying the global default, then we should try the returned name...  */
  333.     /*ALC--  More of Albert's mods for mult. index files... */
  334.          if (os2rc \= '') & (wordpos(translate(filespec('name',file)),translate(default)) \= 0) then do
  335.             file = filespec('drive',file)||filespec('path',file)||os2rc
  336.          end
  337.  
  338.          if (os2rc == '') | (stream(file, 'c', 'query exists') == '') then do
  339.             if (source == 'SOURCE') then return ''
  340.             return DoRedirect( RedirectFile, file)
  341.          end
  342.  
  343.       end
  344.  
  345.     /* recheck the status of the transmission before sending again... */
  346.       if (Cached == 0) & (_ServerVer > 2.10) & (_ServerVer < 2.47) then Cached = completed()
  347.       if (Cached == 0) then do
  348.          if lastpos(".",file)<2 then Extension = ""
  349.          else Extension = translate(substr(file, lastpos('.',file)+1))
  350.          PostProcess = ((Rx.EnablePostProcess == 1) & (pos('HTM', Extension) > 0)) | ((Rx.EnablePostProcess == 2) & (Extension == 'SHTML'))
  351.  
  352.          if (PostProcess) then do
  353.             rc = stream( file, 'C', 'OPEN READ')
  354.             contents=charin(file,,chars(file))
  355.             rc = stream( file, 'C', 'CLOSE')
  356. /*            ServerDir = directory()
  357.             if (Rx.Bin \= '') then call Directory Rx.Bin    */
  358.  
  359.     /*ALC--  Chain here to Albert's footer() code for appending last modified info    */
  360.         /* to bottom of ".*HTM*" files...                        */
  361.             if (Rx.Footer \= '') then if (stream( Rx.Footer, 'C', 'query exists') \= '') then do
  362.                interpret 'contents = 'Rx.Footer'(file, contents, serveradmin)'
  363.             end
  364.  
  365.     /* Do server-side includes here...                 */
  366.             if (stream( Rx.Includes, 'C', 'query exists') \= '') then do
  367.                interpret 'data = 'Rx.Includes'( contents, file, ServerAdmin)'
  368.                if (data \= '') then contents = data
  369.             end
  370.  
  371. /*            call Directory ServerDir    */
  372.  
  373.             'VAR TYPE 'mediatype(file)' AS sel NAME contents'      /* return the data */
  374.          end
  375.          else
  376.             'FILE TYPE' mediatype(file) Secured 'NAME' file
  377.          if (RC \= 0) & (RC \= (-7)) then 'AUDIT FILE returns rc = ['rc'] in SENDFILE()'
  378.       end
  379.  
  380.       rc = WriteToLog( RequestToLog, '200', stream(file, 'c', 'query size'))
  381.       exit ''        /* Terminate here!  */
  382.  
  383.  
  384. /* ----------------------------------------------------------------------- */
  385. /* HANDLER:  Do the necessary logging on errors... */
  386. /* ----------------------------------------------------------------------- */
  387. Handler:
  388.    SIGerrCode = RC
  389.    GoHTTP_ErrLog = 'GoHTTP.ERR'
  390.    if (SIGerrCode == -7) then return    /* We really don't care when GoServe shuts us down... */
  391.  
  392.    Say 'Identified error while executing line #'Sigl'   RC = ['SIGerrCode']'
  393.    Say '['SourceLine(Sigl)']'
  394.    if (Cached == 0) then do
  395.       'AUDIT Error ['SIGerrCode'] while executing line #'Sigl'    {GoHTTP v'GoHTTPver'}'
  396.       'AUDIT ['SourceLine(Sigl)']'
  397.    end
  398.    else do
  399.       rc = lineout( GoHTTP_ErrLog, '---<'transaction'>---['RequestToLog']')
  400.       rc = lineout( GoHTTP_ErrLog, 'Error ['SIGerrCode'] while executing line #'Sigl'    {GoHTTP v'GoHTTPver'}')
  401.       rc = lineout( GoHTTP_ErrLog, '['SourceLine(Sigl)']')
  402.    end
  403.    return
  404.  
  405.  
  406. /* ----------------------------------------------------------------------- */
  407. /* DOREDIRECT: do redirect for the URL if in dB, and logging */
  408. /* ----------------------------------------------------------------------- */
  409.  
  410. DoRedirect: procedure expose default sel request RequestToLog CommonLogFile who name,
  411.    transaction TZadj ReverseLookups ServerName verb tempfile clientport ServerAdmin server,
  412.    port env dir CmdFile Protocol GoHTTPver ScriptAlias AccessFileName Cached Secured,
  413.    PMprint Refer UserAgent RefererLogFile AgentLogFile,
  414.    file Dir. Rx. SendDir source AddUpdated         /*ALC--  */
  415.  
  416.       parse arg RedirFile, RequestedFile
  417.       OK = 0
  418.       Case = 1
  419.  
  420.       if (stream(RedirFile, 'c', 'query exists') \= '') then do
  421.          rc = stream( RedirFile, 'C', 'OPEN READ')
  422.          if (rc == 'READY:') then do until ((lines( RedirFile) == 0) | (OK))
  423.             WildCard = 0
  424.             do until (left(text,1) \= '!')
  425.                text = linein(RedirFile)
  426.                if (left(text,1) == '!') then do 
  427.                   if (translate( substr(text,2,14)) == 'CASE SENSITIVE') then Case = 0
  428.                end
  429.             end
  430.             parse var text old_sel':'new_sel rest
  431.             old_sel = strip(old_sel)
  432.             new_sel = strip(new_sel)
  433.             if (left(old_sel,1) == '/') then old_sel = substr( old_sel, 2)
  434.             if (pos('*', old_sel) > 0) then do
  435.                WildCard = 1
  436.                old_sel = left( old_sel, pos('*', old_sel)-1)
  437.                compare = left(sel, length(old_sel))
  438.             end
  439.             else compare = sel
  440.  
  441.             if (Case) then do
  442.                 Compare = translate( Compare)
  443.                 old_sel = translate(old_sel)
  444.             end
  445.  
  446.             if (compare == old_sel) then do
  447.                if (left(new_sel,5) == 'http:') then new_sel = substr(new_sel,6)
  448.                if (pos('*', new_sel) > 0) then do
  449.                   new_sel = left( new_sel, pos('*', new_sel)-1)
  450.                   if (WildCard) then new_sel = new_sel || substr( sel, length(old_sel)+1)
  451.                end
  452.                OK = 1
  453.             end
  454.          end
  455.          rc = stream(RedirFile, 'c', 'close')
  456.       end
  457.  
  458.       if (OK) then do
  459.          
  460.          if (pos( 'NOTIFY', translate(rest)) > 0) then do
  461.             crlf = '0d0a'x
  462.             doc =     '<h2>This Resource has been Relocated.</h2>'crlf,
  463.         '<hr size=4>The file "'sel'" has been moved to:'crlf,
  464.         '"<A HREF="http:'new_sel'">http:'new_sel'</A>".<p>'crlf,
  465.         'Please make a note of the new URI, and update any references you can.<p>'
  466.             return response('moved_p2', doc)
  467.          end
  468.          else return response('moved_p', 'http:'new_sel)
  469.       end
  470.  
  471.     /*ALC--  Call to Albert's dynamic directory indexing function...   */
  472.       if (Dir.BuildEnabled = 1) & (Dir.Build = 1) & (stream( Rx.BuildDir, 'C', 'query exists') \= '') & ((right(sel,1) == '\') | (right(sel,1) == '/') | (sel == '')) then do
  473. /*         if stream(fulldir||Dir.Forbid, 'c', 'query exists')\='' then Dir.Forbid = 1    */
  474.          if (Dir.Forbid == 1) then return response('forbid','is denied.')
  475. /*         ServerDir = directory()
  476.          if (Rx.Bin \= '') then call Directory Rx.Bin*/
  477.          interpret "message = "Rx.BuildDir"(filespec('drive',file)||filespec('path',file), sel, Dir.Describe, Dir.Info, Dir.Exclude)"
  478.  
  479. /*         call Directory ServerDir*/
  480.          'VAR TYPE text/html BINARY NAME message'
  481.          rc = WriteToLog( RequestToLog, '200', length(message))    
  482.          return  ''
  483.       end
  484.  
  485.       rc = DoAltFilter()
  486.  
  487.       return response('notfound', 'asked for "'sel'", which could not be found')
  488.       exit ''        /* Terminate here!  */
  489.  
  490.  
  491. /* ----------------------------------------------------------------------- */
  492. /* DOALTFILTER: chain to an alternate filter for unresolved requests, */
  493. /*            -- only if alt. filter exists, of course...   */
  494. /* ----------------------------------------------------------------------- */
  495. DoAltFilter: 
  496.     /*ALC-- Albert's code (modified - DLM) to chain to secondary filters.        */
  497.     /*  If we get this far, then the request has failed through the primary filter.    */
  498.     /*  So we chain to a secondary filter to see if it can do any better...        */
  499.       if (Rx.Bin \= '') & (Rx.AltFilter \= '') then do
  500. /*         ServerDir = directory()
  501.          call Directory Rx.Bin    */
  502.          os2rc = ''
  503.  
  504.          if (Rx.AltFilter == 'TEST') then say Rx.AltFilter"('"source"','"request"','"sel"')"
  505.          else
  506.          if (stream(Rx.AltFilter, 'C', 'query exists') \= '') & (source \= 'SOURCE') then do
  507.             Rx.Chained = 1
  508.             interpret "os2rc = "Rx.AltFilter"('"source"','"request"','"sel"')"
  509.          end
  510. /*         call Directory ServerDir    */
  511.          if (Rx.Chained) then do
  512.     /* Can't know what to log, if anything -- so just exit...             */
  513.             /* rc = WriteToLog( RequestToLog, '200', stream(file, 'c', 'query size'))    */
  514.             exit os2rc
  515.          end
  516.       end
  517.       return ''
  518.  
  519. /* ----------------------------------------------------------------------- */
  520. /* PARSEALIASES: return a filename substituted for aliases, scan for 'cgi-bin' */
  521. /* ----------------------------------------------------------------------- */
  522. ParseAliases: procedure expose verb default tempfile CommonLogFile request RequestToLog,
  523.    who name transaction clientport TZadj ReverseLookups ServerAdmin server port,
  524.    ServerName env dir CmdFile Protocol GoHTTPver ScriptAlias ScriptAliases PathAliases,
  525.    PassFile AccessFileName IMap_HandleLocal CaseSensitive Cached  Secured PMprint,
  526.    Refer UserAgent RefererLogFile AgentLogFile RedirectFile StrongChecks mapConf,
  527.    ScriptExtensions owner state. SecureAllRmtCtl,
  528.    Dir. Rx.
  529.  
  530.       parse arg dir, sel, SuppressCGI
  531.       sel = translate(sel, '/', '\')
  532.  
  533.       if (Rx.ParseLevel == '') then Rx.ParseLevel=1
  534.       else 
  535.           if (Rx.ParseLevel > 10) then return sel
  536.          elseRx.ParseLevel = Rx.ParseLevel + 1
  537.  
  538.       parse var sel key '/' rest
  539.       parse var rest ScriptName'?'Words
  540.       parse var ScriptName ScriptName'/'PathParms
  541.       
  542.       if (CaseSensitive) then _key = key
  543.       else do 
  544.          lo = 'abcdefghijklmnopqrstuvwxyz'
  545.          hi = translate(lo)
  546.          _key = translate(key, lo, hi)
  547.       end
  548.  
  549.       CgiScript = 0
  550.       RexxScript = 0
  551.       if (left( _key,4) == 'cgi-') then do
  552.          do i = 1 to words(ScriptAliases)
  553.             CgiAlias = word(ScriptAliases, i)
  554.             parse var CgiAlias CgiKey':'CgiPath
  555.             if (CaseSensitive == 0) then CgiKey = translate(CgiKey, lo, hi)
  556.             if (CgiKey = _key) then do 
  557.                if  (SuppressCGI \= 'NO_EXEC') then ScriptAlias = CgiPath
  558.                CgiScript = 1
  559.                leave
  560.             end
  561.          end
  562.       end
  563.  
  564.       if (left( _key,5) == 'rexx-') then do
  565.          do i = 1 to words(ScriptAliases)
  566.             RexxAlias = word(ScriptAliases, i)
  567.             parse var RexxAlias RexxKey':'RexxPath
  568.             if (CaseSensitive == 0) then RexxKey = translate(RexxKey, lo, hi)
  569.             if (RexxKey = _key) then do 
  570.                if  (SuppressCGI \= 'NO_EXEC') then ScriptAlias = RexxPath
  571.                RexxScript = 1
  572.                leave
  573.             end
  574.          end
  575.       end
  576.  
  577.       file =  dir||sel
  578.       select
  579.           when ( CgiScript) then 
  580.                if (SuppressCGI \= 'NO_EXEC') then do
  581.                   rc = CheckAuth( ScriptAlias'\'ScriptName)
  582.                   rc = DoCGI( tempfile, ScriptName, PathParms, Words)
  583.                   return rc
  584.                end
  585.                else return sel
  586.  
  587.     /* Allow some special 'control' requests.  For these, the verb is */
  588.     /* ignored (though would usually be GET) */
  589.           when left(sel,1) = '!' then do
  590.             crlf = '0d0a'x
  591.             /* Special request -- only accept from allowed places. */
  592.             if (pos(who, owner) == 0) & (owner \= 'ANY') then
  593.               return response('forbid', 'tried to use a special control')
  594.             select
  595.               when sel='!ping'       then return 'STRING Ping!'
  596.               when sel='!statistics' then do
  597.                  'CONTROL VAR Message STATISTICS'
  598.                  Message =     '<head><title>Server Statistics</title></head>'crlf,
  599.             '<body><h1>Server Statistics</h1>'crlf,
  600.                       '<hr><pre>'Message'</pre>'
  601.                  return response('control', Message)
  602.               end
  603.               when sel='!save'       then return 'CONTROL MOVEAUDIT'
  604.               when sel='!reset'      then return 'CONTROL RESET ALL'
  605.               when sel='!dopush'     then return dopush()   /* server push example */
  606.  
  607.               when (left(sel,6)=='!reset')      then do
  608.                  'CONTROL VAR Message RESET' substr(sel,7)
  609.                   Message = "<head><title>Server's Response</title></head><body><h1>Server's Response:</h1><hr><pre>"Message"</pre>"
  610.                 return response( 'control', Message)
  611.               end
  612.  
  613.               when sel='!special'    then do      /* protected command */
  614.                 call authorize 'Demo'             /* will Exit if not authorized */
  615.                 return 'STRING You got the right password'
  616.                 end
  617.               otherwise return response('badreq', 'asked for unknown control "'sel'"')
  618.             end
  619.           end
  620.  
  621.           when (left(sel,1) == '~') & (Rx.Bin \= '') & (stream( Rx.Special, 'C', 'query exists') \= '') then do
  622. /*             ServerDir = directory()
  623.              call Directory Rx.Bin    */
  624.              interpret 'os2rc = 'Rx.Special'( substr(sel, 2), tempfile, who)'
  625. /*             call Directory ServerDir    */
  626.              if (os2rc == '') then os2rc = response('notfound',',"'sel'", could not be found')
  627.              rc = WriteToLog( RequestToLog, '200', length(os2rc))
  628.              return os2rc
  629.           end
  630.  
  631.  
  632.     /* Provide access to the remote control forms.  Authorization can */
  633.     /* be applied to seeing the forms, or only if Apply is pressed.   */
  634.     /* This assumes the pages are in the DataDir directory.           */
  635.     /* You might want to change the 'keyword' in the next line, too.  */
  636.           when (left(translate(sel),8) == 'GOREMOTE') & (stream( Rx.GoRemote, 'C', 'query exists') \= '') then do
  637.              if pos('/',sel)=0 then return response( 'redirect', sel'/')
  638.              /* [remove next line (only) to protect both forms and Apply] */
  639.              if (verb == 'POST') | (SecureAllRmtCtl) then
  640.                 rc = CheckAuth( dir'GoRemote/auth')         /* direct exit if fails */
  641.              parse var sel '/' action            /* action follows the '/' */
  642.              if (action == '') | (action == default) then action='goremote' /* add top form name */
  643. /*             ServerDir = directory()
  644.              if (Rx.Bin \= '') then call Directory Rx.Bin        / * change to script directory...   */
  645.              interpret 'rc = 'Rx.GoRemote'(verb, action)'       /* invoke forms handler */
  646. /*             call Directory ServerDir    */
  647.              if (rc == '') then rc0 = WriteToLog( request, '200', '0')
  648.              return rc
  649.           end /* remote control request */
  650.  
  651.           otherwise do
  652.                if (CaseSensitive) then do
  653.                   _key = key
  654.                end
  655.                else PathAliases = translate(PathAliases, lo, hi) 
  656.  
  657.                do i = 1 to words(PathAliases)
  658.                   Alias = translate(word(PathAliases, i), '\', '/')
  659.                   parse var Alias CKey':'CPath
  660.                   if (CKey == _key) then do
  661.                      if (right(CPath, 1) \= '\') then CPath = CPath'\'
  662.                      file = CPath||rest
  663.                      if (substr(file, 2, 1) \= ':') & (left(file, 2) \= '\\') then do
  664.                         return ParseAliases(dir, file, SuppressCGI)
  665.                      end
  666.                      leave
  667.                   end
  668.                end
  669.  
  670.     /*ALC--   Albert's code for multiple index files.    */
  671.                if ((sel == '') | (right(sel,1) == '/') | (right(sel,1) == '\')) & (pos('?', sel) == 0) then do
  672.                   if (default == '') then default = 'welcome.html'
  673.                   do i=1 to words(default)
  674.                      newsel=word(default,i)
  675.                      if (stream(file||newsel,'c','query exists') == '') then iterate
  676.                      sel=sel||newsel
  677.                      file=file||newsel
  678.                      leave
  679.                   end
  680.                   if (i > words(default)) then file = file || word(default, 1)
  681.                end
  682.  
  683.                Rx.ParseLevel = Rx.ParseLevel - 1
  684.                return file    /* if search above fails, fall through to this... */
  685.              end
  686.       end  /* select */
  687.    return file
  688.  
  689.  
  690. /* ----------------------------------------------------------------------- */
  691. /* RESPONSE: Standard [mostly error] responses.                            */
  692. /* ----------------------------------------------------------------------- */
  693. /* This routine should stay in the main filter program.                    */
  694. /* Arguments are: response type and extended message information.          */
  695. /* It returns the GoServe command to handle the result file.               */
  696.  
  697. response: procedure expose tempfile CommonLogFile RequestToLog who name transaction,
  698.    TZadj ReverseLookups ServerName port GoHTTPver Cached  Secured PMprint Refer,
  699.    UserAgent RefererLogFile AgentLogFile,
  700.    Dir. Rx.
  701.  
  702.   parse arg request, message
  703.   crlf = '0d0a'x
  704.   select
  705.     when (request=='maptest')  then use='200 OK'
  706.     when (request=='control')  then use='200 OK'
  707.     when (request=='noresp')  then use='204 No response'
  708.     when (request=='moved_p')  then use='301 Moved'
  709.     when (request=='moved_p2')  then use='200 OK'
  710.     when (request=='redirect')  then use='302 Moved Temporarily'
  711.     when (request=='badreq')   then use='400 Bad Request Syntax'
  712.     when (request=='unauth')   then use='401 Unauthorized [list]'
  713.     when (request=='forbid')   then use='403 Forbidden'
  714.     when (request=='notfound') then use='404 Not found'
  715.     when (request=='nomap')   then use='404 Not found'
  716.     when (request=='servererr')   then use='500 Server error'
  717.     when (request=='notimpl')   then use='501 Not implemented'
  718.     otherwise do
  719.           request='notimpl'
  720.           use='501 Not implemented'
  721.        end
  722.     end  /* Add others to this list as needed */
  723.   /* Now set the response and build the response file */
  724.   'RESPONSE HTTP/1.0' use     /* Set HTTP response line */
  725.   parse var use code text
  726.   doc = ''
  727.   select
  728.  /*    when (request=='noresp') then call lineout tempfile, ''    */
  729.  
  730.      when (request='redirect') | (request='moved_p') then do
  731.           parse var message method ':' rest
  732.           method = method':'
  733.           if (rest == '') | (pos('/', method) > 0) | (pos('\', method) > 0)then do
  734.              method = 'http:'
  735.           end
  736.           else message = rest
  737.  
  738.           if (left(message,2) \= '//') then do
  739.              saddr = '//'ServerName
  740.              if (port \= 80) then saddr = saddr':'port
  741.           end
  742.           else saddr = ''
  743.           if (left(message,1) \= '/') then message = '/'message
  744.           message = method || saddr || message
  745.  
  746.           'HEADER ADD URI: 'message
  747.           'HEADER ADD Location: 'message
  748.           doc = '<!doctype html public "-//IETF//DTD HTML 2.0//EN">'
  749.         end
  750.      when (request='moved_p2') then do
  751.           doc =      '<!doctype html public "-//IETF//DTD HTML 2.0//EN">'crlf,
  752.         "<html><head><title>URI has moved</title></head>"crlf,
  753.         "<body>"crlf,
  754.         message||crlf,
  755.         "<hr><em>HTTP response code:</em>" code crlf,
  756.         "<br><em>From server at:</em>" servername() crlf,
  757.         "<br><em>Running:</em>" server('H')' (GoHTTP/'GoHTTPver')'crlf,
  758.         "</body></html>"
  759.         end
  760.      when (request='nomap') | (request='control') | (request='maptest') then do
  761.           doc =      '<!doctype html public "-//IETF//DTD HTML 2.0//EN">'crlf,
  762.         "<html>"crlf,
  763.         message||crlf,
  764.         "<hr><em>HTTP response code:</em>" code crlf,
  765.         "<br><em>From server at:</em>" servername() crlf,
  766.         "<br><em>Running:</em>" server('H')' (GoHTTP/'GoHTTPver')'crlf,
  767.         "</body></html>"
  768.         end
  769.      otherwise do
  770.           doc =     '<!doctype html public "-//IETF//DTD HTML 2.0//EN">'crlf,
  771.         "<html><head><title>"text"</title></head>"crlf,
  772.         "<body><h2>Sorry...</h2>"crlf,
  773.         "<p>The request from your Web client" message"."crlf,
  774.         "<hr><em>HTTP response code:</em>" code crlf,
  775.         "<br><em>From server at:</em>" servername() crlf,
  776.         "<br><em>Running:</em>" server('H')' (GoHTTP/'GoHTTPver')'crlf,
  777.         "</body></html>"
  778.         end
  779.      end   /* select */
  780.  
  781.      if (ServerVer() < 2.27) then do
  782.         if (doc \= '') then rc = lineout(tempfile, doc)
  783.         rc = stream( tempfile, 'c', 'close')
  784.         'FILE ERASE TYPE text/html NAME' tempfile
  785.      end
  786.      else do
  787.         'VAR TYPE text/html BINARY NAME doc'
  788.      end
  789.      rc = WriteToLog( RequestToLog, code, '0')
  790.      exit         /* GoServe v2.00 records error if return here... ? */
  791.  
  792.  
  793. /* ----------------------------------------------------------------------- */
  794. /* SEARCH: Sample search function that builds a response file dynamically. */
  795. /* ----------------------------------------------------------------------- */
  796. /* We'd probably make it a separate Rexx program normally, for ease of     */
  797. /* maintenance.                                                            */
  798. /* Arguments are: the unique file name, search to do, and words [UR form]. */
  799. /* It returns the GoServe command to handle the result file.               */
  800.  
  801. search: procedure expose verb default tempfile uri sel CommonLogFile request RequestToLog,
  802.    who name transaction clientport TZadj ReverseLookups ServerAdmin server port ServerName,
  803.    dir env ScriptAlias ScriptAliases PathAliases CmdFile Protocol GoHTTPver PassFile,
  804.    AccessFileName IMap_HandleLocal CaseSensitive Cached  Secured PMprint Refer,
  805.    UserAgent RefererLogFile AgentLogFile RedirectFile StrongChecks mapConf,
  806.    ScriptExtensions owner state. SecureAllRmtCtl,
  807.    Dir. Rx. source
  808.  
  809.   parse arg file, type, list       /* could easily be uppercased */
  810.  
  811.   if (left( type,1) == '/') then type = substr( type,2)
  812.  
  813.    _data = type
  814.    if (list \= '') then _data = _data'?'list
  815.    rc = ParseAliases( dir, _data) 
  816.  
  817.    if (rc == '') | (pos(word(rc,1), 'FILE VAR STRING') > 0) then return rc
  818.    else rc = DoAltFilter()   
  819.  
  820.  
  821.     /* If we get this far, just do MFC's sample search routine.    */
  822.     /*  I'll probably just replace Mike's code with error messages to    */
  823.     /*  save "weight"...                        */
  824.    return DoMFC_Search()
  825.  
  826.  
  827. DoMFC_Search:
  828.    do
  829.       parse var rc type_translated'?'list
  830.     /* type_translated is the fully qualified filename returned by ParseAliases... */
  831.       if (list == '') & (verb == 'POST') then do
  832.          'read body var words'                    /* get the incoming data */
  833.          if rc=-4 then                            /* body too large */
  834.            return response('badreq', 'sent too much data')
  835.          if rc<>0 then                            /* e.g., invalid HTTP header */
  836.            return response('badreq', 'sent data that could not be read')
  837.       end
  838.    end
  839.  
  840.   /* list = PACKUR( list)  */
  841.   parse var list list '&' checks   /* split off all checkboxes etc. */
  842.   /* If this came with our name, use the value                           */
  843.   /* If came from an old form, with an ISINDEX tag, can handle that, too */
  844.   /* If this came from an old form and old client, use list as-is        */
  845.   /* But if the name isn't the one we put in the form, use empty list.   */
  846.   parse var list name '=' value
  847.  select
  848.     when name='searchText' then list=value   /* usual case */
  849.     when name='isindex'    then list=value   /* for very simple forms */
  850.     when pos('=', list)=0  then nop          /* as-is case */
  851.     otherwise list=''                        /* invalid name */
  852.     end
  853.   list=packur(list)                /* pack escape sequences in list */
  854.  
  855.   /* This sample function ignores TYPE except as information */
  856.   call lineout file, '<!doctype html public "-//IETF//DTD HTML 2.0//EN">'
  857.   call lineout file, "<html><head><title>Response</title></head>"
  858.   call lineout file, "<body>"
  859.   call lineout file, "<h2>Response to '"type"' request</h2>"
  860.  
  861.   /* Here would be a customized search.  We just build a simple list. */
  862.   list=translate(list, ' ', '+'||'090a0d'x)  /* Whitespace, etc. */
  863.   if list='' then call lineout file, "<p>You chose no words."
  864.    else do
  865.     call lineout file, "<p>The words you chose were:<ol>"
  866.     do while list<>''
  867.       parse var list word list               /* get first */
  868.       call lineout file, "<li>"word
  869.       end
  870.     call lineout file, "</ol>"
  871.     end /* have words */
  872.   if checks<>'' then
  873.     call lineout file, "<p>Checkbox data was:" checks
  874.   call lineout file, "<hr></body></html>"
  875.   rc = stream( file, 'c', 'close')                         /* close */
  876.   'FILE ERASE TYPE text/html NAME' file
  877.   rc = WriteToLog( RequestToLog, '200', stream(file, 'c', 'query size'))
  878.   return ''
  879.  
  880.  
  881. /* ----------------------------------------------------------------------- */
  882. /* DoCGI: Handle branching of CGI scripts / subroutines.            */
  883. /* ----------------------------------------------------------------------- */
  884. DoCGI: procedure expose verb default tempfile uri CommonLogFile request RequestToLog,
  885.    who name transaction clientport TZadj ReverseLookups ServerAdmin server port Protocol,
  886.    ServerName dir env ScriptAlias ScriptAliases PathAliases CmdFile GoHTTPver PassFile,
  887.    AccessFileName IMap_HandleLocal CaseSensitive Cached  Secured PMprint Refer,
  888.    UserAgent RefererLogFile AgentLogFile RedirectFile StrongChecks mapConf,
  889.    ScriptExtensions owner state. SecureAllRmtCtl,
  890.    Dir. Rx.
  891.  
  892.   parse arg file, ScriptName, MapName, list       /* could easily be uppercased */
  893.  
  894.       if (verb == 'POST') then do
  895.          'read body var postedlist'                    /* get the incoming data */
  896.          if rc=-4 then                            /* body too large */
  897.            return response('badreq', 'sent too much data')
  898.          if rc<>0 then                            /* e.g., invalid HTTP header */
  899.            return response('badreq', 'sent data that could not be read')
  900.       end
  901.  
  902.   ScriptName = translate(ScriptName)
  903.  
  904.   select
  905.      when ( left(ScriptName,8) == 'IMAGEMAP') then do
  906.            parse var MapName _MapName'/'PathParms
  907.            rc = ImageMap( file, list, MapName, PathParms)
  908.            return rc
  909.         end
  910.  
  911.      otherwise do
  912.          Found = (stream( ScriptAlias'/'ScriptName, 'c', 'query exists') \= '')
  913.          if (Found == 0) & (pos('.', ScriptName) == 0) then do
  914.             i = 1
  915.             do while (i <= words(ScriptExtensions)) & (Found == 0)
  916.                Found = (stream( ScriptAlias'/'ScriptName'.'word(ScriptExtensions,i), 'c', 'query exists') \= '')
  917.                if (Found) then ScriptName = ScriptName'.'word(ScriptExtensions,i)
  918.                i = i + 1
  919.             end
  920.          end
  921.          if (Found) then do 
  922.             PathParms = MapName
  923.             parse var ScriptAlias Drive':'Rest
  924.             if (Drive == ScriptAlias) then Drive = ''    /* means no drive info to parse off... */
  925.  
  926.             i = 1
  927.             _acc = REQFIELD("accept")
  928.             acc = '%'
  929.             ClientAccepts = ''
  930.             do while (acc \= _acc)
  931.                acc = REQFIELD("accept", i)
  932.                if (ClientAccepts \= '') then ClientAccepts = ClientAccepts','acc
  933.                else ClientAccepts = acc
  934.                i = i+1
  935.             end
  936.  
  937.             rc = 0
  938.  
  939.             name = GetClientName( who)
  940.  
  941.             rc = stream(tempfile, 'c', 'close')    /* Close the file to avoid preventing process from access. */
  942.  
  943.     /* This is pretty touchy stuff below, be very careful if you edit any of this... */
  944.             InputFile = translate( tempfile, '#', '$')
  945.             ReturnCode = '200'        /* default return code  */
  946.             call lineout CmdFile, "/**/"
  947.             call lineout CmdFile, "'@ECHO OFF'"
  948.             if (Drive \= '') then call lineout CmdFile, "'"Drive":'"
  949.             call lineout CmdFile, "'CD "ScriptAlias"'"
  950.             call lineout CmdFile, "env  = '"env"'"
  951.  
  952.             SrvVersionText = server('H')' (GoHTTP/'GoHTTPver')'
  953.             rc = value('SERVER_SOFTWARE', SrvVersionText, env)
  954. /*            if (rc \= 'CGI/1.1') then do  */
  955.             if (rc \= SrvVersionText) then do
  956.                rc = value('GATEWAY_INTERFACE','CGI/1.1',env)
  957.                rc = value('SERVER_NAME',ServerName,env)
  958.                rc = value('SERVER_PORT',port,env)
  959.             end
  960.  
  961.             i =1
  962.             l =1
  963.             ClientAccepts = ''
  964.             HeaderFile = translate( tempfile, '~', '$')
  965.             'READ HEADER FILE NAME 'HeaderFile                    /* get the incoming header data */
  966.             hd = linein( HeaderFile, 1)
  967.             do while (hd \= '')
  968.                hd = linein( HeaderFile)
  969.                parse var hd Hkey': 'content
  970.                Hkey = translate(Hkey, '_', '-')
  971.                Hkey = translate(Hkey)
  972.                select
  973.                   when (Hkey == 'ACCEPT') then do
  974.                     parse var content content'; 'q
  975.                     if (i > 1) then ClientAccepts = ClientAccepts', 'content
  976.                     else ClientAccepts = content
  977.                     if (l == 5) then do
  978.                        call lineout CmdFile, "'SET HTTP_ACCEPT=%HTTP_ACCEPT%"ClientAccepts"'"
  979.                        ClientAccepts = ''
  980.                        l = 1
  981.                     end
  982.                     l = l+1
  983.                     i = i+1
  984.                   end
  985.  
  986.     /* Handle other, unrecognized headers to conform to CGI/1.1 spec.  */
  987.                   otherwise do
  988.                      if (Hkey \= '') then rc = lineout(CmdFile, "rc = value('HTTP_"Hkey"','"content"',env)")
  989.                   end
  990.                end
  991.             end
  992.             rc = lineout( HeaderFile)
  993.             if (ClientAccepts \= '') then call lineout CmdFile, "'SET HTTP_ACCEPT=%HTTP_ACCEPT%"ClientAccepts"'"
  994.  
  995.             crlf = '0d0a'x
  996.             output_text =     "rc = value('SCRIPT_NAME','"ScriptName"',env)"crlf,
  997.             "rc = value('REQUEST_METHOD','"verb"',env)"crlf,
  998.             "rc = value('REMOTE_ADDR','"who"',env)"crlf,
  999.             "rc = value('SERVER_PROTOCOL','"protocol"',env)"crlf,
  1000.             "rc = value('PATH_INFO','/"PathParms"',env)"crlf,
  1001.             "rc = value('PATH_TRANSLATED','"dir||PathParms"',env)"crlf,
  1002.             "rc = value('REMOTE_USER','"REQFIELD("from")"',env)"crlf,
  1003.             "rc = value('AUTH_TYPE','"REQFIELD("auth-type")"',env)"crlf,
  1004.             "rc = value('CONTENT_TYPE','"REQFIELD("Content-type")"',env)"crlf,
  1005.             "rc = value('CONTENT_LENGTH','"REQFIELD("Content-length")"',env)"crlf,
  1006.             "rc = value('REMOTE_HOST','"name"',env)"crlf,
  1007.                        "rc = value('QUERY_STRING','"list"',env)"
  1008.  
  1009.     /* if state.ID defined, then pass value to any CGI script...  */
  1010.             if ( state.ID \= 'STATE.ID') then output_text = output_text || crlf || "rc = value('STATE_ID','"state.ID"',env)"
  1011.  
  1012.             call lineout CmdFile, output_text
  1013.  
  1014.     /* Change suggested by someone (lost the email) to allow 4OS2 to be used as shell.   */
  1015.             ScriptAlias = translate( ScriptAlias, '\', '/')
  1016.  
  1017.             plist=packur(list)                /* pack escape sequences in list */
  1018.  
  1019.             if (plist \= '') then
  1020.                if (pos('&', plist) > 0) | (pos('=', plist) > 0) | (pos("'", plist) > 0) then 
  1021.                  /* plist = '"'plist'"'      / *  This line "quotes" the parameter list.  Actual HTTPDs  */ 
  1022.                   plist = ''        /*  simply omit the parameter list in this case.        */
  1023.  
  1024.                else do            /* Process the parameter list back to original ascii format */
  1025.                   plist = translate( plist, ' ', '+')
  1026.                end
  1027.  
  1028.             if (verb == 'POST') then do 
  1029.                rc = charout( InputFile, postedlist, 1)
  1030.                rc = stream( InputFile, 'C', 'close')        /* Close file */
  1031.                
  1032.                call lineout CmdFile, "'CALL "ScriptAlias"\"ScriptName" "plist" <"InputFile" >>"tempfile"'"
  1033.             end
  1034.             else do 
  1035.                call lineout CmdFile, "'CALL "ScriptAlias"\"ScriptName" "plist" >>"tempfile"'"
  1036.             end
  1037.  
  1038.             call lineout CmdFile        /* Close file */
  1039.  
  1040.             do 
  1041.                address cmd
  1042.                CmdFile
  1043.                rcode=RC
  1044.                address
  1045.  
  1046.                if (rcode == 0) then do
  1047.                   Hder = '%'
  1048.                   ContentType = 'text/html'
  1049.                   ContentLength = 0
  1050.                   do while (Hder \= '')
  1051.                      Hder = linein( tempfile) 
  1052.                      parse var Hder Hkey': 'content
  1053.                      _Hkey = Hkey
  1054.                      _Hkey = translate( _Hkey)
  1055.  
  1056.         /* This should handle the special header case of nph-* scripts... */
  1057.                      if (word(_Hkey,1) == 'HTTP/1.0') then do 
  1058.                         parse var Hder Hkey content
  1059.                         _Hkey = 'STATUS'
  1060.                         'HEADER NOAUTO'
  1061.                      end
  1062.  
  1063.                      select 
  1064.                         when (_Hkey == 'CONTENT-LENGTH') then ContentLength = content
  1065.                         when (_Hkey == 'CONTENT-TYPE') then ContentType = content
  1066.                         when (_Hkey == 'LOCATION') | (_Hkey == 'URI') then do
  1067.  
  1068.            /*  It is not 'spec' to assume a redirect if URI is included, 
  1069.             but 'LOCATION' isn't really even 'spec'... */
  1070.                            if (_Hkey == 'LOCATION') then do
  1071.                               ReturnCode = '302'
  1072.                               'RESPONSE HTTP/1.0 'ReturnCode' Found'     /* Set HTTP response line */
  1073.                            end
  1074.  
  1075.                            'HEADER ADD 'Hkey': 'content
  1076.                         end
  1077.                         when (_Hkey == 'STATUS') then do
  1078.                            parse var content ReturnCode rest
  1079.                            'RESPONSE HTTP/1.0 'content     /* Set HTTP response line */
  1080.                         end
  1081.                         otherwise 'HEADER ADD 'Hkey': 'content
  1082.                      end
  1083.                   end
  1084.                   _ContentLength = Chars(tempfile)
  1085.                   if ( _ContentLength < ContentLength) | (ContentLength == 0) then ContentLength = _ContentLength
  1086.                   'HEADER ADD Content-length: 'ContentLength
  1087.                   Content = charin( tempfile,, ContentLength)
  1088.                   Call Lineout tempfile            /* Close file before delete */
  1089.                end
  1090.                rc = SysFileDelete( tempfile)        /* delete tempfile because we're shortening it.  */
  1091.                rc = SysFileDelete( CmdFile)        /* delete CmdFile, we're done with it.  */
  1092.                if (verb == 'POST') then rc = SysFileDelete( InputFile)    /* delete InputFile, we're done with it.  */
  1093.                rc = SysFileDelete( HeaderFile)    /* delete HeaderFile, we're done with it.  */
  1094.  
  1095.                if (rcode \= 0) then return response('servererr', 'could not be completed.<p><pre>    Form Error: 'rcode'</pre>')
  1096.  
  1097.                rc = charout( tempfile, Content, 1)    /* Write contents back to tempfile  */
  1098.  
  1099.                rc = stream( tempfile, 'c', 'close')
  1100.                'FILE ERASE TYPE 'ContentType' NAME' tempfile
  1101.                rc = WriteToLog( request, ReturnCode, ContentLength)
  1102.                return ''  
  1103.             end
  1104.          end
  1105.          else return response( 'notfound', 'cannot be honored.  <p>This server does not currently support any CGI service called "'ScriptName'".')
  1106.  
  1107.        end
  1108.   end
  1109.     /*  Should never get this far..  */
  1110.   return response( 'servererr', 'cannot be honored.')
  1111.  
  1112.  
  1113. /* ----------------------------------------------------------------------- */
  1114. /* GETCLIENTNAME: Internal function to  handle client name resolution requests.   */
  1115. /* ----------------------------------------------------------------------- */
  1116. GetClientName: procedure expose ReverseLookups
  1117.    parse arg addr .
  1118.    name = addr
  1119.    if (ReverseLookups == 'yes') then do 
  1120.       if (ServerVer() >= 2.02) then do
  1121.          name = ClientName()
  1122.          if (name == '') then name = addr
  1123.       end
  1124.       else do
  1125.          rc = SockGetHostByAddr( addr,"host.!")
  1126.          if (rc == 1) then name = host.!name
  1127.       end
  1128.    end
  1129.  
  1130.    return name
  1131.  
  1132.  
  1133. /* ----------------------------------------------------------------------- */
  1134. /* DOPUSH: Sample 'server push' routine                                    */
  1135. /* ----------------------------------------------------------------------- */
  1136. /* This sends a (very simple) "Server push" data stream.  It requires a    */
  1137. /* browser that accepts the internet type  'multipart/x-mixed-replace'     */
  1138. dopush: procedure
  1139.   /* This simple example does a full-document countdown */
  1140.   crlf='0d0a'x                /* useful */
  1141.   bound=copies("x",11)        /* boundary data for part [could be random] */
  1142.   mimestart='--'bound''crlf   /* starts a MIME multipart section */
  1143.   mimeend  ='--'bound'--'crlf /* ends a MIME multipart section */
  1144.  
  1145.   /* Send the header and first boundary */
  1146.   'set netbuffer off'         /* turn off buffering */
  1147.   'send type multipart/x-mixed-replace;boundary="'bound'" as Countdown'
  1148.   'string' mimestart          /* Or could be: 'var name mimestart' */
  1149.  
  1150.   do num=10 to 0 by -1
  1151.     /* Build document to send, with leading (mixed) Type header and    */
  1152.     /* terminating MIME boundary.  It could be sent in smaller pieces. */
  1153.     out=''
  1154.     out=out||'Content-type: text/html'crlf
  1155.     out=out||crlf
  1156.     out=out||'<!doctype html public "-//IETF//DTD HTML 2.0//EN">'crlf
  1157.     out=out||"<html><head><title>Counting...</title></head>"crlf
  1158.     out=out||"<body><h2>"
  1159.     if num>0 then out=out||num||'...'
  1160.              else out=out||'<hr>Zero!!<hr>'
  1161.     out=out||"</h2>"crlf
  1162.     out=out||"</body></html>"crlf
  1163.     if num=0 then out=out||mimeend           /* Mime 'last data' indicator */
  1164.              else out=out||mimestart         /* Mime 'start data' indicator */
  1165.     'VAR NAME out'                           /* send it */
  1166.     if num>0 then 'wait seconds 0.7'         /* pause */
  1167.     end
  1168.  
  1169.   'SEND Complete'                            /* and complete the send */
  1170.   return ''                                  /* [called as function] */
  1171.  
  1172. /* ----------------------------------------------------------------------- */
  1173. /* WRITETOLOG: Write info to logfile - use Common Log Format.     */
  1174. /* ----------------------------------------------------------------------- */
  1175. WriteToLog: procedure expose CommonLogFile RequestToLog who name transaction TZadj,
  1176.    ReverseLookups ServerName Cached  Secured PMprint Refer UserAgent RefererLogFile AgentLogFile
  1177.  
  1178.    parse arg Text, ECode, FSize   /* parse out passed variables. */
  1179.  
  1180.    rc = 0
  1181.  
  1182.    if (RequestToLog == 'REQUESTTOLOG') then return 0
  1183.  
  1184.    name = GetClientName( who)
  1185.  
  1186. /*   if (ReverseLookups == 'yes') then do 
  1187.       if (ServerVer() >= 2.02) then do
  1188.          name = ClientName()
  1189.          rc = (name \= '')
  1190.       end
  1191.       else do
  1192.          rc = SockGetHostByAddr(who,"host.!")
  1193.          if (rc == 1) then name = host.!name
  1194.       end
  1195.    end
  1196.    if (rc \= 1) then name = who    */
  1197.  
  1198.    dt = date('S')
  1199.    mo = substr(dt,5,2)
  1200.  
  1201.    select
  1202.       when mo == '01' then M = 'Jan'
  1203.       when mo == '02' then M='Feb'
  1204.       when mo == '03' then M='Mar'
  1205.       when mo == '04' then M='Apr'
  1206.       when mo == '05' then M='May'
  1207.       when mo == '06' then M='Jun'
  1208.       when mo == '07' then M='Jul'
  1209.       when mo == '08' then M='Aug'
  1210.       when mo == '09' then M='Sep'
  1211.       when mo == '10' then M='Oct'
  1212.       when mo == '11' then M='Nov'
  1213.       when mo == '12' then M='Dec'
  1214.       otherwise M='???'
  1215.    end
  1216.  
  1217.    TimeStamp = substr(dt,7,2)'/'M'/'substr(dt,1,4)':'time()' 'TZadj
  1218.  
  1219.    count = 0
  1220.    do until ((os2rc == 0) | (count >= 5))
  1221.       os2rc = lineout(CommonLogFile, name' - - ['TimeStamp'] "'Text'" 'ECode' 'FSize)
  1222.       if (os2rc \= 0) then do
  1223.          count = count + 1
  1224.          call SysSleep 1
  1225.       end
  1226.    end
  1227.    rc = stream(CommonLogFile, 'c', 'close')
  1228.  
  1229.     /* Code to log Referred by: goes here...  */
  1230.    if (Refer == 'REFER') then Refer = ''
  1231.    if (RefererLogFile \= '') & (Refer \= '') then do 
  1232.       count = 0
  1233.       do until ((os2rc == 0) | (count >= 5))
  1234.          os2rc = lineout(RefererLogFile, '['TimeStamp'] "'word(Text,2)'" 'Refer)
  1235.          if (os2rc \= 0) then do
  1236.             count = count + 1
  1237.             call SysSleep 1
  1238.          end
  1239.       end
  1240.       rc = stream(RefererLogFile, 'c', 'close')
  1241.    end
  1242.  
  1243.     /* Code to log User-Agent: goes here...  */
  1244.    if (AgentLogFile \= '') then do 
  1245.       count = 0
  1246.       do until ((os2rc == 0) | (count >= 5))
  1247.          os2rc = lineout(AgentLogFile, '['TimeStamp'] 'who' : 'UserAgent)
  1248.          if (os2rc > 0) then do
  1249.             count = count + 1
  1250.             call SysSleep 1
  1251.          end
  1252.       end
  1253.       rc = stream(AgentLogFile, 'c', 'close')
  1254.    end
  1255.  
  1256.        /*  if (Text == 'REQUEST') then check procedure EXPOSE's     */
  1257.    if (PMprint) then do
  1258.       say time() transaction '['name'] "'Text'" 'ECode'  'FSize
  1259.       if (Refer \= '') then Say '  Referred by: ['Refer']  ('UserAgent')'
  1260.    end
  1261.   return 1
  1262.  
  1263.  
  1264. /* ----------------------------------------------------------------------- */
  1265. /* MEDIATYPE: Return the media type of a file, based on its extension.     */
  1266. /* ----------------------------------------------------------------------- */
  1267. /* Empirical tests show that the method used below is approximately 50%   */
  1268. /* faster than the method used in the sample filter included with GoServe.  */
  1269.  
  1270. mediatype: procedure
  1271.   /* First get the extension; this assumes filenames have at least one '.' */
  1272.   ???=translate(substr(arg(1), lastpos('.',arg(1))+1))
  1273.  
  1274.   /* list of types that we are interested in */
  1275.   select
  1276.     when (??? == 'HTML') then return 'text/html'
  1277.     when (??? == 'HTM') then return 'text/html'
  1278.     when (??? == 'SHTML') then return 'text/html'
  1279.     when (??? == 'TXT') then return 'text/plain'
  1280.     when (??? == 'TEXT') then return 'text/plain'
  1281.     when (??? == 'CMD') then return 'text/plain'
  1282.     when (??? == 'DOC') then return 'text/plain'
  1283.     when (??? == 'FAQ') then return 'text/plain'
  1284.     when (??? == 'GIF') then return 'image/gif'
  1285.     when (??? == 'JPG') then return 'image/jpeg'
  1286.     when (??? == 'JPEG') then return 'image/jpeg'
  1287.     when (??? == 'JPE') then return 'image/jpeg'
  1288.     when (??? == 'TIF') then return 'image/tiff'
  1289.     when (??? == 'TIFF') then return 'image/tiff'
  1290.     when (??? == 'BMP') then return 'image/bmp'
  1291.     when (??? == 'AU') then return 'audio/basic'
  1292.     when (??? == 'WAV') then return 'audio/x-wav'
  1293.     when (??? == 'WAVE') then return 'audio/x-wav'
  1294.     when (??? == 'SND') then return 'audio/basic'
  1295.     when (??? == 'MID') then return 'audio/x-midi'
  1296.     when (??? == 'MIDI') then return 'audio/x-midi'
  1297.     when (??? == 'AVI') then return 'video/avi'
  1298.     when (??? == 'MPG') then return 'video/mpeg'
  1299.     when (??? == 'MPE') then return 'video/mpeg'
  1300.     when (??? == 'MPEG') then return 'video/mpeg'
  1301.     when (??? == 'INF') then return 'application/x-inf'
  1302.     when (??? == 'PDF') then return 'application/x-pdf'
  1303.     when (??? == 'PS') then return 'application/postscript'
  1304.     when (??? == 'ZIP') then return 'application/zip'
  1305.     when (??? == 'DVI') then return 'application/x-dvi'
  1306.     when (??? == '') then return 'application/octet-stream' /* default type */
  1307.  
  1308.     when (??? == '80') then return 'text/plain'
  1309.     when (??? == arg(1)) then return 'text/plain'
  1310.   /* Now it's trivial... */
  1311.     otherwise return 'application/octet-stream' /* default type */
  1312.   end
  1313.  
  1314.  
  1315.  
  1316. /* ----------------------------------------------------------------------- */
  1317. /* CHECKAUTH:  */
  1318. /* ----------------------------------------------------------------------- */
  1319. CheckAuth: procedure expose verb default tempfile CommonLogFile request RequestToLog,
  1320.    who name transaction clientport TZadj ReverseLookups ServerAdmin server port ServerName,
  1321.    env dir CmdFile Protocol GoHTTPver ScriptAlias AccessFileName Cached  Secured PMprint,
  1322.    Refer UserAgent RefererLogFile AgentLogFile RedirectFile,
  1323.    Dir. Rx.
  1324.  
  1325.   parse arg file
  1326.   file = translate( file, '/', '\')
  1327.   PathTo = ''
  1328.   rest = file
  1329.   retCode = ''
  1330.   do while (rest \= '')
  1331.     parse var rest _dir'/'rest
  1332.     if (right( _dir,1) == ':') then PathTo = _dir
  1333.     else PathTo = PathTo'/'_dir
  1334.     if (left(PathTo,3) == '///') then PathTo = substr(PathTo,2)
  1335.     else if (rest \= '') & (right( _dir,1) \= ':') then do
  1336.       ACLfile = stream( PathTo'/'AccessFileName, 'c', 'query exists')
  1337.       if (ACLfile \= '') then do
  1338.          Auth.Name = ''
  1339.          Auth.Type = ''
  1340.          Auth.UserFile = ''
  1341.          Auth.GroupFile = ''
  1342.          Auth.Limit = ''
  1343.          Auth.Index = ''
  1344.          rc = stream( ACLfile, 'c', 'OPEN READ')
  1345.          line = linein( ACLfile, 1)
  1346.          do while (line \= '')
  1347.             do while( pos(left(line,1), "2009"x) > 0); line = substr(line, 2); end
  1348.             if ( pos(left(line,1), "#") > 0) then line = substr(line, 2)
  1349.             if ( left(line,1) == ';') then line = ';COMMENT'
  1350.  
  1351.             parse var line key ':' val
  1352.             val = strip(val)
  1353.             key = translate(key)
  1354.             if (key = 'AUTHUSERFILE') | (key = 'AUTHGROUPFILE') | (key = 'REDIRLIST') then do
  1355.                if (pos(':', val ) == 0) then do
  1356.                   val = translate(val, '\', '/')
  1357.                   if (left(val,1) == '\') then val = substr( val, 2)
  1358.                   val = dir || val
  1359.                end
  1360.             end
  1361.             select
  1362.                when (key = 'AUTHNAME') then Auth.Name = val
  1363.                when (key = 'AUTHTYPE') then Auth.Type = translate( strip(val))
  1364.                when (key = 'AUTHUSERFILE') then Auth.UserFile = val
  1365.                when (key = 'AUTHGROUPFILE') then Auth.GroupFile = val
  1366.                when (key = 'DEFAULTINDEX') then Auth.Index = val
  1367.                when (key = 'REDIRLIST') then RedirectFile = val
  1368.                when (key = 'LIMIT') then Auth.Limit = val
  1369.                when (key = 'BUILDDIR') then Dir.Build = (val \= '0')
  1370.                when (key = 'DIR.EXCLUDE') then Dir.Exclude = Dir.Exclude val
  1371.                when (key = '_DIR.EXCLUDE') then Dir.Exclude = val
  1372.                when (key = 'DIR.INFO') then Dir.Info = val
  1373.                when (key = 'DIR.DESCRIBE') then Dir.Describe = val
  1374.                when (key = 'DIR.FORBID') then Dir.Forbid = (val \= '0')
  1375.                when (key = 'DIR.BUILDER') then Rx.BuildDir = val
  1376.                when (key = 'ENABLEPOSTPROCESS') then do
  1377.                      v = left(strip(val),1)
  1378.                      if (pos(v, '012') > 0) then Rx.EnablePostProcess = v
  1379.                   end
  1380.                otherwise 
  1381.             end
  1382.             
  1383.             line = linein( ACLfile)
  1384.          end
  1385.          rc = stream( ACLfile, 'c', 'close')
  1386.  
  1387.          retCode = Auth.Index
  1388.          if ((Auth.Name \= '') | (Auth.Type == 'IDENT')) & (Auth.Limit \= '') then do
  1389.  
  1390.     /* Do not allow access to user password file, if requested.  */
  1391.             parse upper var rest filename
  1392.             parse upper var Auth.UserFile PassFile
  1393.             if ( PassFile == Filename) then exit response('forbid', 'is not allowed')
  1394.  
  1395.             parse var Auth.Limit AuthLimitKey _rest
  1396.             AuthLimitKey = translate( AuthLimitKey)
  1397.             select
  1398.               when (AuthLimitKey == 'REQUIRE') then do 
  1399.                    Set = strip(_rest)
  1400.                    if (Auth.GroupFile \= '') then do
  1401.  
  1402.         /* Do not allow access to group file, if requested.  */
  1403.                       parse upper var rest filename
  1404.                       parse upper var Auth.GroupFile AuthGroupFile
  1405.                       if ( AuthGroupFile == Filename) then exit response('forbid', 'is not allowed')
  1406.  
  1407.                       Set = CompleteSet( Set, Auth.GroupFile)
  1408.                    end
  1409.                 end
  1410.               when (AuthLimitKey == '') then Set = ''
  1411.               otherwise exit Response('notimpl', 'Auth Limit command ['AuthLimitKey'] not recognized.')
  1412.             end
  1413.  
  1414.             Auth_Type = Auth.Type
  1415.             select
  1416.               when (Auth_Type == 'BASIC') then do
  1417.  
  1418.                  call authorize Auth.Name, Set
  1419.  
  1420.         /* Signal to GoServe not to cache this request         */
  1421.         /* otherwise, the caching would bypass authorization for next request..     */
  1422.                  if (ServerVer() > 2.10) then Secured = 'NOCACHE'    
  1423.  
  1424.               end
  1425.  
  1426.         /*  Code to allow restriction to a specific account or machine, */
  1427.         /*    without any challenge.      */
  1428.               when (Auth_Type == 'IDENT') then do
  1429.         /* Version check - not supportable under GoServe v2.00  */
  1430.                  if (ServerVer() < 2.02) | (clientport == '') then exit response('notimpl', 'referenced an unsupported authentication method')
  1431.  
  1432.         /* Signal to GoServe not to cache this request         */
  1433.         /* otherwise, the caching would bypass authorization for next request..     */
  1434.                  if (ServerVer() > 2.10) then Secured = 'NOCACHE'    
  1435.  
  1436.     /* IDENT client code  */
  1437.                  name = ClientName()
  1438.  
  1439.     /* Create a short list of possible machine identity matches... */
  1440.                  _Set = ' '
  1441.                  do i = 1 to words(Set)
  1442.                     if (pos(name, word(Set,i)) > 0) then _Set = _Set' 'Word(Set,i)
  1443.                     else do
  1444.                        rest = word(Set,i)
  1445.                        parse var rest id'@'rest
  1446.                        if ( left(rest,1) == '*') then do
  1447.                           cp = translate(substr(rest,2))
  1448.                           if ( cp == translate(right( name, length(cp)))) then _Set = _Set' 'Word(Set,i)
  1449.                        end
  1450.                     end
  1451.                  end
  1452.  
  1453.     /*  If short list is empty, then we can bypass, as request will be failed..  */
  1454.                  if (words(_Set) == 0) then Set = ''
  1455.  
  1456.     /* else, if no wildcard userids in short list to eliminate the need to do user identity check.... */
  1457.                  else if (pos('*@', _Set) == 0) then do
  1458.                     if (RxFuncQuery("SockSocket")) then do 
  1459.                        rc = RxFuncAdd("SockLoadFuncs","RxSock","SockLoadFuncs")
  1460.                        rc = SockLoadFuncs()
  1461.                     end
  1462.  
  1463.                     Ident = SockSocket('AF_INET','SOCK_STREAM',0)
  1464.                     addr.family = 'AF_INET'
  1465.                     addr.addr = who
  1466.                     addr.port = 113
  1467.                     rc = SockConnect(Ident,'addr.')
  1468.                     if rc = 0 Then do
  1469.                        len = SockSend(Ident,clientport','port'0d0a'x)
  1470.                        len = SockRecv(Ident,'data',256)
  1471.                        rc = SockClose(Ident)
  1472.                        parse var data port1 ',' port2 ':' 'USERID:' OS ':' data
  1473.                        data = translate(data,'','0d0a'x)
  1474.                        data = strip(data)
  1475.                        data = translate(data,'_',' ')
  1476.                     end
  1477.                     else do
  1478.                        rc = SockClose(Ident)
  1479.                        data = ''
  1480.                     end
  1481.                  end
  1482.                  else data = ''
  1483.  
  1484.                  username = data'@'name
  1485.  
  1486.                  Set = strip(_Set)
  1487.  
  1488.                  do i = 1 to words(Set)
  1489.                     _check = word(Set, i)
  1490.                     parse var _check first'@'rest
  1491.  
  1492.         /* check user identity info... */
  1493.                     if (first == '*') then first = data
  1494.  
  1495.         /* Check machine identity part... */
  1496.                     if (rest == '*') then rest = name
  1497.                     else if ( left(rest,1) == '*') then do
  1498.                        cp = translate(substr(rest,2))
  1499.                        if ( cp == translate(right( name, length(cp)))) then rest = name
  1500.                     end
  1501.  
  1502.                     _check = first'@'rest
  1503.                     if (username == _check) then return retCode
  1504.                  end
  1505.                  exit Response('forbid', 'could not be honored...')
  1506.               end
  1507.               when (Auth_Type == '') then do
  1508.               end
  1509.               otherwise exit response('notimpl', 'referenced an unsupported authentication method')
  1510.             end
  1511.          end
  1512.       end
  1513.     end
  1514.  
  1515.     /* Do not allow client to access the Access Control Files  */
  1516.     else if (rest == '') & (right( dir,1) \= ':') then do
  1517.        parse upper var dir filename
  1518.        parse upper var AccessFileName _AccessFileName
  1519.        if ( _AccessFileName == Filename) then exit response('forbid', 'is not allowed')
  1520.     end
  1521.   end 
  1522.   
  1523.   return retCode
  1524.  
  1525.  
  1526. /* ----------------------------------------------------------------------- */
  1527. /* AUTHORIZE -- check access to data is authorized                         */
  1528. /* ----------------------------------------------------------------------- */
  1529. /* This routine exits directly if it needs to challenge the client, so it  */
  1530. /* must be internal.  If authorization is valid, it returns to caller.     */
  1531. /* Argument is the Realm to which the data belongs (this tells the user    */
  1532. /* which userid/password pair to use.                                      */
  1533. /* In this sample filter, the password must be the userid; in a real       */
  1534. /* application, it would probably be held in a file (such as a .INI file). */
  1535. authorize: procedure expose tempfile CommonLogFile RequestToLog who name transaction,
  1536.    clientport TZadj ReverseLookups ServerName GoHTTPver PassFile PMprint
  1537.  
  1538.   Set=strip(arg(2))
  1539.  
  1540.   afield=reqfield('Authorization')      /* see if incoming authorization */
  1541.   parse var afield . m64 .              /* get the encoded cookie */
  1542.   dec=pack64(m64)                       /* and decode it */
  1543.   parse var dec user ':' pw             /* split to userid and password */
  1544.   /* [password checking code] */
  1545.   if (CheckPW( user, pw, PassFile, Set)) then return
  1546.   /* [End of password checking code] */
  1547.   realm=strip(arg(1))
  1548.   'header add WWW-Authenticate: Basic Realm=<'realm'>'  /* challenge */
  1549.   exit response('unauth', "for realm '"realm"' was not authorized")
  1550.  
  1551.  
  1552. /* ----------------------------------------------------------------------- */
  1553. /* CHECKPW -- Check if Password is correct for specified user.     */
  1554. /* ----------------------------------------------------------------------- */
  1555. CheckPW: procedure expose clientport
  1556.    parse arg user, pw, PassFile, Set
  1557.    rc = (Set == '')        /* set the default - if no SET defined, assume user OK.  */
  1558.    do i = 1 to words(Set) 
  1559.       if (word(Set,i) == user) then rc = 1
  1560.    end
  1561.    if (rc) then do
  1562.       rc = stream( PassFile, 'C', 'OPEN READ')
  1563.       line = linein( PassFile, 1)
  1564.       parse var line _user':'_pw
  1565.       do while (user \= '') & (user \= _user) & (line \= '')
  1566.          line = linein( PassFile)
  1567.          parse var line _user':'_pw
  1568.       end
  1569.       rc = stream( PassFile, 'c', 'close')
  1570.       if (line \= '') & (user == _user) then return ( pw == _pw)
  1571.    end
  1572.    return (0)
  1573.  
  1574.  
  1575. /* ----------------------------------------------------------------------- */
  1576. /* COMPLETESET: Fill out the set of users with names from any included groups. */
  1577. /* ----------------------------------------------------------------------- */
  1578. CompleteSet: procedure
  1579.   NewSet = ''
  1580.   parse arg Set, AuthGroupFile
  1581.   if (AuthGroupFile == '') | (stream( AuthGroupFile, 'c', 'query exists') == '') then return Set
  1582.   rc = stream( AuthGroupFile, 'C', 'OPEN READ')
  1583.   do i = 1 to Words(Set)
  1584.     rc =0
  1585.     key = word(set,i)
  1586.     line = linein(AuthGroupFile,1)
  1587.     do while (rc == 0) & (line \= '')
  1588.        parse var line GroupName':'Group
  1589.        Group = strip(Group)
  1590.        if (GroupName == key) then do
  1591.           rc = 1
  1592.           NewSet = Newset Group
  1593.        end
  1594.        line = linein(AuthGroupFile)
  1595.     end
  1596.     if (rc ==0) then NewSet = NewSet key
  1597.   end
  1598.   rc = stream( AuthGroupFile, 'c', 'close')
  1599.   return strip(NewSet)
  1600.  
  1601.  
  1602. /* ----------------------------------------------------------------------- */
  1603. /* SERVERVER: return numeric server version.     */
  1604. /* ----------------------------------------------------------------------- */
  1605.  
  1606. ServerVer: procedure 
  1607.    ver = Server('H');
  1608.    parse var ver 'GoServe/'ver
  1609.    return ver
  1610.  
  1611.  
  1612. /* ----------------------------------------------------------------------- */
  1613. /* IMAGEMAP: handle imagemap processing.     */
  1614. /* ----------------------------------------------------------------------- */
  1615.  
  1616. ImageMap: procedure expose default tempfile ServerAdmin server port CommonLogFile,
  1617.    RequestToLog who name transaction TZadj ReverseLookups ServerName dir GoHTTPver,
  1618.    IMap_HandleLocal ScriptAliases PathAliases CaseSensitive Cached  Secured PMprint Refer,
  1619.    UserAgent RefererLogFile AgentLogFile StrongChecks mapConf ScriptExtensions,
  1620.    owner state. SecureAllRmtCtl Rx.
  1621.  
  1622.     /*  Initialize variables  */
  1623. ImageMapVersion='2.10'
  1624. if (mapConf == '') | (mapConf == 'MAPCONF') then mapConf = 'conf\imagemap.cnf'
  1625. Default_URL = ''
  1626. TestMode = 0
  1627. MapID = 0
  1628. crlf = '0d0a'x
  1629.  
  1630.     /*  Parse command arguments into variables to use here. */
  1631. Parse arg outfile, Parms, MapName, pathparms
  1632. Parse var Parms iX ',' iY
  1633.  
  1634. if (left(MapName,1) == '/') then MapName = substr(MapName,2)
  1635.  
  1636.     /* Begin the Main process: */
  1637.  
  1638.     /* Can I locate the MAP file directly?  */
  1639.  
  1640. file = ParseAliases(dir,MapName, 'NO_EXEC')
  1641. Found = (stream(file, 'c', 'query exists') \= '')
  1642. if (Found == 0) then do 
  1643.    Found = (stream(file'.map', 'c', 'query exists') \= '')
  1644.    if (Found) then file = file'.map'
  1645. end
  1646.  
  1647.     /* If I can locate the MAP file directly, then use it without accessing imagemap.cnf. */
  1648.  
  1649. if (Found) then do
  1650.    MapID = 1
  1651.    Map.name.MapID = MapName
  1652.    Map.filename.MapID = file
  1653. end  
  1654. else do
  1655.    parse var MapName MapName'/'PathParms
  1656.    MapName = translate( MapName)        /* ensure uppercase  */
  1657.  
  1658.     /* Read the Map List into a stem variable. */
  1659.    i = 0
  1660.    Text = '%'
  1661.    rc = stream(mapConf, 'C', 'OPEN READ')
  1662.    do while (Text \= '')
  1663.      i = i + 1
  1664.      Text = linein(mapConf)
  1665.      parse var Text N ' : ' Map.filename.i
  1666.      parse upper var N Map.name.i
  1667.    end
  1668.    rc = stream(mapConf, 'C', 'CLOSE')
  1669.  
  1670.     /* Set 'NumMaps' to the number of maps located.  */
  1671.    NumMaps = i - 1
  1672.  
  1673.     /* Set MapID to index of the first matching defined MapName; to 0 if no match */
  1674.    i = 1
  1675.    do while ((i <= NumMaps) & (MapName \= Map.name.i))
  1676.      i = i + 1
  1677.    end
  1678.    if (i > NumMaps) then MapID = 0
  1679.    else MapID = i
  1680. end
  1681.     /* If a valid Map, then process the passed parameters & determine URL to return. */
  1682. if  (MapID > 0) then do
  1683.     i = ReadMap(MapID)
  1684.     _URL = GetURLfromMap( iX iY)
  1685.   end
  1686. else _URL = Default_URL
  1687.  
  1688.    if (_URL \= '') then do
  1689.     /* Check URL to verify complete - relative URLs choke several clients... */
  1690.       parse var _URL _http_mode ':' _local_URL
  1691.       if (left( _local_URL,2) \= '//') then do 
  1692.     /* split and parse in SERVER_NAME:SERVER_PORT  */
  1693.           if (_local_URL = '') then  do
  1694.              _local_URL = _http_mode
  1695.              _http_mode = 'http'
  1696.           end
  1697.  
  1698.     /* if mode = HTTP, then let's process the relative URL internally... */
  1699.     /* Run through the alias parser and return the result.   */
  1700.           if ( translate(_http_mode) == 'HTTP') & (IMap_HandleLocal) then do 
  1701.              __local_URL = _local_URL
  1702.              _RTL = RequestToLog
  1703.              _local_URL = translate(_local_URL, '/', '\')
  1704.              RequestToLog = 'GET '_local_URL' HTTP/1.0'
  1705.              if (left(_local_URL,1) == '/') then _local_URL = substr(_local_URL, 2)
  1706.  
  1707.       /* Ensure that GoServe doesn't cache Imagemap requests */
  1708.              if (ServerVer() >= 2.10) then Secured = 'NOCACHE'
  1709.  
  1710.              rc = ParseAliases(dir, _local_URL)
  1711.              if (rc \= '') then rc = SendFile( rc)
  1712.  
  1713.     /* if got this far, then SendFile() failed.  Restore and allow redirect to resume...  */
  1714.              _local_URL = __local_URL
  1715.              RequestToLog = _RTL
  1716.           end
  1717.           SRVURL= '//'ServerName':'port
  1718.           _URL = _http_mode':'SRVURL || _local_URL
  1719.        end
  1720.    end
  1721.  
  1722. Select
  1723.     /* If a URL is available, and TESTMODE is not on, then redirect client */
  1724.   When ((_URL \= '') & (TestMode == 0)) then  do
  1725.  
  1726.       return response('redirect', _URL)
  1727.     end
  1728.  
  1729.     /* MapID = -1 shouldn't happen; reserved for later use..  */
  1730.     /* 400 Bad Request forces client to report error - no HTML is displayed on client.  */
  1731.   When (MapID = -1) then  return response('badreq', 'could not be handled')
  1732.  
  1733.     /* Undefined MapName -- send appropriate Error HTML... */
  1734.   When (MapID = 0) then  do
  1735.       msg =     "<!--Output from IMAGEMAP.CMD v"ImageMapVersion", "server('H')" (GoHTTP/"GoHTTPver")-->"crlf,
  1736.         "<head><title>REXX Script Processor Output</title></head><body>"crlf,
  1737.         "<h1>ERROR: Undefined Map</h1>"crlf,
  1738.         "<hr>MapName=["Mapname"]<br>"crlf,
  1739.         'MapID='MapID'<hr>'crlf,
  1740.         "Click Coordinates:<p><pre>   X=["iX"]<br>   Y=["iY"]</pre>"crlf,
  1741.         '<hr><i>To define a new map, you must place your <em>'MapName'.MAP</em> 'crlf,
  1742.         'file onto the server, and send email to 'ServerAdmin' requesting that your map'crlf,
  1743.         ' be added to the configuration file.  [Your email message should tell of the mapname: "<em>'MapName'</em>" and the location of the <em>'MapName'.MAP</em> file.]</i>'crlf,
  1744.         '<hr><address>Please report server-related problems to 'ServerAdmin'</address>'crlf,
  1745.         '</body></html>'
  1746.  
  1747.       return response('nomap', msg)
  1748.     end
  1749.  
  1750.     /* Must have fallen through because of no 'Default' defined in .MAP file, */
  1751.   When ((_URL == '') & (TestMode \= 0)) then  do
  1752.       return response('noresp', '')
  1753.     end
  1754.  
  1755.     /*  or TESTMODE is on.  Send debugging info via HTML.*/
  1756.   Otherwise do
  1757.       msg =     "<!--Output from IMAGEMAP.CMD v"ImageMapVersion", "server('H')" (GoHTTP/"GoHTTPver")-->"crlf,
  1758.         "<head><title>REXX Script Processor Output</title></head><body>"crlf,
  1759.         "<h1>ImageMap Input</h1>"crlf,
  1760.         "<hr>MapName=["Mapname"]<br>"crlf,
  1761.         'MapID='MapID'<hr>'crlf,
  1762.         "Click Coordinates:<p><pre>   X=["iX"]<br>   Y=["iY"]</pre>"crlf,
  1763.         '<p>TestMode='TestMode'<br>'crlf,
  1764.         'NRegions='Region.NRegions'<br>'crlf,
  1765.         '<hr>Default = "<A HREF="'Default_URL'">'Default_URL'</A>" <br>'crlf,
  1766.         'Redirect to URL = "<A HREF="'_URL'">'_URL'</A>"'crlf,
  1767.         '</body></html>'
  1768.  
  1769.       return response('maptest', msg)
  1770.     end
  1771.   End   /* Select */
  1772. return response('badreq', 'cannot be honored.')
  1773.  
  1774.  
  1775.  
  1776. /* ----------------------------------------------------------------------- */
  1777. /* READMAP: Read in the .MAP file into a stem variable.  [Region]  */
  1778. /* ----------------------------------------------------------------------- */
  1779.  
  1780. ReadMap: procedure expose Region. Default_URL Map. TestMode ServerName Port StrongChecks
  1781.  
  1782.    parse arg ID        /* parse out passed variable. (represents MapID) */
  1783.  
  1784.     /* Initilizations */
  1785.    i = 0
  1786.    nR = 0
  1787.    Text = '%'
  1788.    Default_URL = ''
  1789.    TestMode = 0
  1790.  
  1791.     /* read in the region definitions from the .MAP file.  */
  1792.    rc = stream(Map.filename.ID, 'C', 'OPEN READ')
  1793.    do while (lines(Map.filename.ID))  
  1794.      i = i + 1
  1795.      do until (left(Text,1) \= '#')
  1796.         Text = strip(linein(Map.filename.ID))
  1797.      end
  1798.      parse var Text Text '#' comments    /* trim any comments   */
  1799.      r = right(Text,1)
  1800.      l = left(comments,1)
  1801.      if (((r \= ' ') & (r \= '') & (r \= '09'x)) & ((l \= ' ') & (l \= '') & (l \= '09'x))) then do
  1802.         parse var comments comments'#'rest    /* trim any comments, again   */
  1803.         Text = Text'#'comments
  1804.      end
  1805.  
  1806.      parse var Text T  Region.URL.i  Cs
  1807.      parse var Cs C1 C2
  1808.      parse upper var T Region.Type.i
  1809.  
  1810.      if (Region.URL.i \= '') then do
  1811.     /* Check URL to verify complete - relative URLs choke several clients... */
  1812.         parse var Region.URL.i _http_mode ':' _local_URL
  1813.         if (left( _local_URL,2) \= '//') & (0) then do 
  1814.     /* split and parse in SERVER_NAME:SERVER_PORT  */
  1815.             if (_local_URL = '') then  do
  1816.                _local_URL = _http_mode
  1817.                _http_mode = 'http'
  1818.              end
  1819.             SRVURL= '//'ServerName':'port
  1820.             Region.URL.i = _http_mode':'SRVURL || _local_URL
  1821.          end
  1822.      end
  1823.  
  1824.      Err = 0
  1825.      Select
  1826.  
  1827.     /* If the TESTMODE keyword is present, set TestMode to on.  */
  1828.        When (Region.Type.i == 'TESTMODE') then do
  1829.           i = i - 1
  1830.           TestMode = 1
  1831.         end
  1832.  
  1833.     /* DEFAULT keyword sets the default URL to redirect to in case of no region matches. */
  1834.        When (Region.Type.i = 'DEFAULT') then do 
  1835.            Default_URL = Region.URL.i
  1836.            i = i - 1
  1837.          end
  1838.  
  1839.     /* Parse out coordinates for the Rectangular region.  */
  1840.        When (Region.Type.i = 'RECT') then do 
  1841.            parse var C1 Region.X1.i ',' Region.Y1.i
  1842.            parse var C2 Region.X2.i ',' Region.Y2.i
  1843.            if (StrongChecks) then do 
  1844.               if ((Datatype(Region.X1.i) \= 'NUM') | (Datatype(Region.Y1.i) \= 'NUM') | (Datatype(Region.X2.i) \= 'NUM') | (Datatype(Region.Y2.i) \= 'NUM')) then Err = 1
  1845.            end
  1846.  
  1847.            if (Err == 0) then do
  1848.               nR = nR + 1
  1849.     /* ensure that X1,Y1 is upper left, and X2,Y2 is lower right... */
  1850.               if (Region.X2.i < Region.X1.i) then     /* Swap... */
  1851.                do 1
  1852.                  a = Region.X2.i
  1853.                  Region.X2.i = Region.X1.i
  1854.                  Region.X1.i = a
  1855.                end
  1856.               if (Region.Y2.i < Region.Y1.i) then     /* Swap... */
  1857.                do
  1858.                  a = Region.Y2.i
  1859.                  Region.Y2.i = Region.Y1.i
  1860.                  Region.Y1.i = a
  1861.                end
  1862.             end
  1863.          end
  1864.  
  1865.     /* Parse out coordinates for the Circle region.  */
  1866.        When (Region.Type.i = 'CIRC') then do 
  1867.            parse var C1 Region.X1.i ',' Region.Y1.i
  1868.         /* radius... */
  1869.            Region.X2.i = C2
  1870.            if (StrongChecks) then do 
  1871.               if ((Datatype(Region.X1.i) \= 'NUM') | (Datatype(Region.Y1.i) \= 'NUM') | (Datatype(Region.X2.i) \= 'NUM')) then Err = 1
  1872.            end
  1873.            if (Err == 0) then do
  1874.               Region.radius2.i = (Region.X2.i**2)
  1875.               nR = nR + 1
  1876.            end
  1877.          end
  1878.  
  1879.     /* Parse out coordinates for the Circle region.  */
  1880.        When (Region.Type.i = 'CIRCLE') then do 
  1881.            parse var C1 Region.X1.i ',' Region.Y1.i
  1882.            parse var C2 Region.X2.i ',' Region.Y2.i
  1883.  
  1884.            if (StrongChecks) then do 
  1885.               if ((Datatype(Region.X1.i) \= 'NUM') | (Datatype(Region.Y1.i) \= 'NUM') | (Datatype(Region.X2.i) \= 'NUM') | (Datatype(Region.Y2.i) \= 'NUM')) then Err = 1
  1886.            end
  1887.  
  1888.            if (Err == 0) then do 
  1889.         /* radius... */
  1890.               qX = (Region.X1.i - Region.X2.i)
  1891.               qY = (Region.Y1.i - Region.Y2.i)
  1892.               Region.radius2.i = (qX*qX) + (qY*qY)
  1893.               nR = nR + 1
  1894.            end
  1895.          end
  1896.  
  1897.     /* handle the Poly region.  */
  1898.        When (Region.Type.i = 'POLY') then do 
  1899.            k=1
  1900.            do while (strip(Cs) \= '') & (Err == 0)
  1901.               parse var Cs Region.X.i.k ',' Region.Y.i.k Cs
  1902.               if (StrongChecks) then if ((Datatype(Region.X.i.k) \= 'NUM') | (Datatype(Region.Y.i.k) \= 'NUM')) then Err = 1
  1903.               k = k + 1
  1904.            end
  1905.  
  1906.            if (Err == 0) then do
  1907.               Region.NVerts.i = (k - 1)
  1908.               Region.X.i.k = -1
  1909.               nR = nR + 1
  1910.            end
  1911.  
  1912.          end
  1913.  
  1914.     /* handle the Point region.  */
  1915.        When (Region.Type.i = 'POINT') then do 
  1916.            parse var C1 Region.X1.i ',' Region.Y1.i
  1917.            if (StrongChecks) then do 
  1918.               if ((Datatype(Region.X1.i) \= 'NUM') | (Datatype(Region.Y1.i) \= 'NUM')) then Err = 1
  1919.            end
  1920.            if (Err == 0) then nR = nR + 1
  1921.          end
  1922.  
  1923.     /* handle the standard blank line between 'Default' line and other regions... */
  1924.        When (Region.Type.i = '') then do 
  1925.            if ((i = 1) & (Default_URL \= '')) then do
  1926.               Text = '%'
  1927.               i = i - 1
  1928.             end
  1929.          end
  1930.  
  1931.     /* Must be an unknown region type... */
  1932.        Otherwise do 
  1933.            if (Text \= '') then 
  1934.               say 'Unknown RegionType=['Region.Type.i']  URL=<'Region.URL.i'>  [C1='C1'  C2='C2']'
  1935.            i = i - 1
  1936.          end
  1937.      end /* Select */     
  1938.      if (Err == 1) then say 'error:  region #'i
  1939.      if (Err == 1) then i = i - 1
  1940.    end
  1941.    rc = stream(Map.filename.ID, 'C', 'CLOSE')
  1942.    Region.NRegions = nR
  1943.    return nR
  1944.  
  1945.  
  1946. /* ----------------------------------------------------------------------- */
  1947. /* GetURLfromMap: Identify the region of the map, & return the associated URL */
  1948. /* ----------------------------------------------------------------------- */
  1949.  
  1950. GetURLfromMap: procedure expose Region. Default_URL Map.
  1951.  
  1952.     /* Parse out mouse click coordinates */
  1953.    parse arg tX tY
  1954.    i = 1;   Hit = 0;  sawpoint = 0
  1955.  
  1956.     /* Set URL to the default, in case no regions are hit... */
  1957.    _URL = Default_URL
  1958.  
  1959.     /* if tX & tY = '', then assume web client not imagemap capable - bypass region search. */
  1960.    if (tX='') then Hit = -1
  1961.  
  1962.     /* Loop through the defined regions to find first hit. */
  1963.    do while ((i <= Region.NRegions) & (Hit = 0))
  1964.      Select
  1965.  
  1966.     /* Determine if coordinates lie within the rectangular area.  */
  1967.        When Region.Type.i = 'RECT' then do
  1968.           Hit = ((tX >= Region.X1.i) & (tY >= Region.Y1.i) & (tX <= Region.X2.i) & (tY <= Region.Y2.i))
  1969.         end
  1970.  
  1971.     /* Calc distance to coordinates from Circle center, and compare to radius.*/
  1972.     /*   If less than radius, then it's a hit... */
  1973.        When (Region.Type.i = 'CIRC') | (Region.Type.i = 'CIRCLE') then do
  1974.           a = tX - Region.X1.i
  1975.           b = tY - Region.Y1.i
  1976.           R = a**2 + b**2
  1977.           Hit = (R <= Region.radius2.i)
  1978.         end
  1979.  
  1980.     /* Determine if coordinates lie within the polygon.  */
  1981.        When Region.Type.i = 'POLY' then do
  1982.            Hit = CrossingsMultiplyTest(i, tX, tY)
  1983.         end
  1984.  
  1985.        When Region.Type.i = 'POINT' then do
  1986.           a = tX - Region.X1.i
  1987.           b = tY - Region.Y1.i
  1988.           R = (a * a) + (b * b)
  1989.     /* If a direct hit, then don't bother with nearest determinations... */
  1990.           if (R == 0) then Hit = 1
  1991.     /* otherwise, track to find which point is nearest the click coordinates... */
  1992.           else if (sawpoint) then do
  1993.              if (R < PointDistance) then do 
  1994.                 PointDistance = R
  1995.                 ClosestPoint = i
  1996.              end
  1997.           end
  1998.           else do
  1999.              sawpoint = 1
  2000.              PointDistance = R
  2001.              ClosestPoint = i
  2002.           end
  2003.         end
  2004.  
  2005.  
  2006.     /* The required 'Otherwise'... */
  2007.        Otherwise  do
  2008.         end
  2009.      End /* Select */
  2010.  
  2011.     /* If a hit, then set '_URL' to stem URL value.  */
  2012.      if (Hit = 1) then _URL = Region.URL.i
  2013.      i = i + 1
  2014.    end
  2015.  
  2016.    if (Hit == 0) & (sawpoint) then do
  2017.       _URL = Region.URL.ClosestPoint
  2018.    end
  2019.  
  2020.    return _URL        /* return the identified URL */
  2021.  
  2022.  
  2023. /* ======= Crossings Multiply algorithm =================================== */
  2024. /* point in polygon inside/outside code.                   */
  2025. /* Original C code by Eric Haines, 3D/Eye Inc, erich@eye.com        */
  2026. /* based on work by Joseph Samosky and Mark Haigh-Hutchinson.    */
  2027. /* Ported to REXX for this filter by D.L. Meyer, meyer@larch.ag.uiuc.edu    */
  2028.  
  2029. CrossingsMultiplyTest: Procedure expose Region. 
  2030.     parse arg pgon, pointX, pointY
  2031.  
  2032.     numverts = Region.NVerts.pgon
  2033.     vtx0X = Region.X.pgon.numverts
  2034.     vtx0Y = Region.Y.pgon.numverts
  2035.     /* get test bit for above/below X axis */
  2036.     yflag0 = ( vtx0Y >= pointY ) 
  2037.  
  2038.     inside_flag = 0 
  2039.     do j = 1 to numverts
  2040.               vtx1X = Region.X.pgon.j
  2041.               vtx1Y = Region.Y.pgon.j
  2042.  
  2043.     yflag1 = ( vtx1Y >= pointY ) 
  2044.     /* Check if endpoints straddle (are on opposite sides) of X axis
  2045.      * (i.e. the Y's differ); if so, +X ray could intersect this edge.
  2046.      * The old test also checked whether the endpoints are both to the
  2047.      * right or to the left of the test point.  However, given the faster
  2048.      * intersection point computation used below, this test was found to
  2049.      * be a break-even proposition for most polygons and a loser for
  2050.      * triangles (where 50% or more of the edges which survive this test
  2051.      * will cross quadrants and so have to have the X intersection computed
  2052.      * anyway).  I credit Joseph Samosky with inspiring me to try dropping
  2053.      * the "both left or both right" part of my code.
  2054.      */
  2055.     if ( yflag0 \= yflag1 ) then do
  2056.         /* Check intersection of pgon segment with +X ray.
  2057.          * Note if >= point's X; if so, the ray hits it.
  2058.          * The division operation is avoided for the ">=" test by checking
  2059.          * the sign of the first vertex wrto the test point; idea inspired
  2060.          * by Joseph Samosky's and Mark Haigh-Hutchinson's different
  2061.          * polygon inclusion tests.
  2062.          */
  2063.         if ( (((vtx1Y-pointY) * (vtx0X-vtx1X)) >= ((vtx1X-pointX) * (vtx0Y-vtx1Y))) == yflag1 ) then do
  2064.         inside_flag = (inside_flag  == 0)
  2065.         end
  2066.     end
  2067.  
  2068.     /* Move to the next pair of vertices, retaining info as possible. */
  2069.     yflag0 = yflag1 
  2070.     vtx0X = vtx1X 
  2071.     vtx0Y = vtx1Y 
  2072.  
  2073.     end
  2074.  
  2075.     return  inside_flag 
  2076.  
  2077.  
  2078.