/* REXX - CGIDemo3.REX: Demonstrates how data is passed from a web */
/* browser to a CGI program, via both the POST and GET methods. */
/* This version does not need to be invoked from a matching HTML page;*/
/* it detects that it has been invoked with NO variables, then */
/* generates the initial form page. */
/* Like CGIDemo2.REX, it includes a signal on Error Handler, and uses */
/* the CGIParse() routine to extract form data into a stem variable. */
CALL ON ERROR NAME RXERROR /* Setup host command error handler,*/
SIGNAL ON SYNTAX NAME RXERROR /* syntax error handler, */
SIGNAL ON NOVALUE NAME RXERROR /* and misspelled variable handler*/
SAY 'Content-type: text/html' /* Construct the output web page */
SAY '' /* header. */
SAY ''
SAY ''
SAY 'Display Environment Variables'
SAY ''
SAY ''
request_method = RxGetEnv('REQUEST_METHOD') /* How were we called? */
PARSE SOURCE env . execname /* Where are we? What's our filename?*/
IF WORDPOS(env,'TSO OPS/REXX')>0 /* If on MVS, discard extra data... */
THEN PARSE VAR execname execname the_rest
SAY 'REXX exec' execname 'invoked via' request_method'
'
/* Call the CGIParse() function, which returns: */
/* 1. A stem variable CGI. with the value of each form field */
/* 2. Variable cgiVars lists all of the tails in the CGI. stem. */
/* 3. rc is either 0 or the text of an error message. */
rc = CGIParse('PREFIX(CGI.) VARLIST(CGIVars)')
IF rc <> 0 THEN
DO; SAY 'CGIParse() failed, rc='rc'
'; SIGNAL EXIT; END
IF cgivars = '' THEN /* no cgivars, create initial form */
DO i = DATA()+2 TO DATB()-2 /* First thru last data line */
line = SOURCELINE(i) /* Extract one line of data */
/* Different servers that I tested on had different cgi-bin paths. */
/* The following hack removes "/myweb" from the HTML if run on MVS. */
remove = '/myweb'
IF WORDPOS(env,'TSO OPS/REXX')>0 THEN
IF POS(remove,line) > 0
THEN line = DELSTR(line,POS(remove,line),LENGTH(remove))
SAY line /* Output this line as an HTML form*/
END i
ELSE
DO
SAY 'Current CGI variables:
'
SAY 'query_string='query_string'
' /* Display the whole input, */
SAY 'cgivars='cgivars'
' /* and the list of variables.*/
DO i = 1 TO WORDS(cgivars) /* Loop thru list of variables*/
name = WORD(cgivars,i) /* Extract one variable name */
IF RIGHT(name,1) = '.' THEN /* This one a stem variable? */
DO j = 0 TO cgi.name.0 /* Yes: loop thru the stem... */
SAY i 'cgi.'name''j'='cgi.name.j'
'
END
ELSE SAY i 'cgi.'name'='cgi.name'
'/* No: display name+value */
END i
/* Demonstrate how to process the imagemap data. Each image is 57 */
/* pixels wide, so we divide out the X coordinate to see which one */
IF SYMBOL('cgi.clickme.x') = 'VAR' THEN /* Was image clicked on? */
DO /* Yes. */
n = (cgi.clickme.x % 57) + 1 /* Calculate which one */
image = WORD('Sun Moon Star',n) /* Get image name */
SAY 'You clicked on image' n', the' image'
'
END
END
EXIT: /* Common exit point, error or not.*/
SAY '' /* Close off the body of web page */
SAY '' /* Close off the entire web page */
EXIT 0 /* Exit the program */
DATA:IF ABBREV(SOURCELINE(sigl),'DATA:') THEN RETURN sigl;RETURN DATA()
/* The following is data, referenced via SOURCELINE()
*/
DATB:IF ABBREV(SOURCELINE(sigl),'DATB:') THEN RETURN sigl;RETURN DATB()
/* Canned internal (RXCOPY) subroutines follow, in alphabetical order.*/
/*RXCOPY CGIPARSE NODUP 186 LINES COPIED ON 09-15-03 AT 10:16**********/
/*START OF CGIParse-------------------------------------Version-01.00-*/
/*:CGIParse() function - parses HTML form data passed via CGI. */
/* Parameters: */
/* PREFIX(ppp) - Optional Prefix for variable names created by this */
/* function. Can be a stem name, or just some chars. */
/* VARLIST(varname) - Optional output variable name that contains a */
/* list of all of the variables created by CGIPARSE. */
/* */
/* Returns: 0, or an error message. */
/* Note1: This function handles both HTML methods, GET and POST. */
/* Note2: If a SELECT form variable has the multiple attribute, the */
/* data will be returned as a stem variable (even if only 1 */
/* option was chosen). To help the caller determine this, the */
/* name returned in the varlist is suffixed with a '.' */
/*--------------------------------------------------------------------*/
CGIParse: /* No expose here because we create arbitrarily named */
/* variables for the caller. */
TRACE N
_cgi.0err=_CGIParse1(ARG(1)) /* Process the cgi data */
IF _cgi.0err <> 0 THEN RETURN _cgi.0err /* Return if error */
/* Create CGI form variables, user caller-provided prefix */
DO _cgi.0i = 1 TO WORDS(_cgi.0names)
_cgivarname = WORD(_cgi.0names, _cgi.0i)
IF RIGHT(_cgivarname, 1) = '.' THEN
DO _cgi.0j = 0 TO VALUE('_cgi.0data.'_cgivarname'0')
CALL VALUE _cgi.0prefix''_cgivarname'.'_cgi.0j,
,VALUE('_cgi.0data.'_cgivarname''_cgi.0j)
END _cgi.0j
ELSE CALL VALUE _cgi.0prefix''_cgivarname, _cgi.0data._cgivarname
END _cgi.0i
IF _cgi.0varlist <> '' /* Caller wants a varList? */
THEN CALL VALUE _cgi.0varlist, _cgi.0names /* Yes, create it. */
DROP _cgi. _cgivarname
RETURN 0
_CGIParse1: PROCEDURE EXPOSE gbl. __environment. query_string _cgi.
TRACE N
PARSE UPPER ARG 1 'PREFIX(' _cgi.0prefix ')',
1 'VARLIST(' _cgi.0varlist ')'
_cgi.0names = '' /* Init list of varnames to create */
PARSE SOURCE env . execname
IF WORDPOS(env,'TSO OPS/REXX') > 0
THEN PARSE VAR execname execname the_rest
request_method = RxGetEnv('REQUEST_METHOD')
SELECT
WHEN request_method = 'POST' THEN
IF SYMBOL('query_string') = 'LIT' THEN
DO /* If query string already exists, then we were called */
/* before, and we have already read from stdin. We can't */
/* re-read the same stdin data, so we use what we have saved.*/
content_length = RxGetEnv('CONTENT_LENGTH')
IF DATATYPE(content_length) = 'NUM' THEN
SELECT
WHEN env = 'TSO' THEN
INTERPRET "ADDRESS SYSCALL",
"'READ 0 query_string" content_length "'"
WHEN WORDPOS(env,'WindowsNT NT') > 0 THEN
query_string = CHARIN(,,content_length)
OTHERWISE
SAY 'CGIParse1: Unsupported environment:' src
END
END
WHEN request_method = 'GET' THEN
DO
query_string= RxGetEnv('QUERY_STRING')
END
OTHERWISE
rc='Error, invalid request_method:' request_method
RETURN rc
END
/* query_string=name=Joe+Bob&gender=Male=&text=punctuation%3A+%2C.%2F */
/* Convert any plus signs (+) in QUERY_STRING to spaces; result->Input*/
input=TRANSLATE(query_string,' ','+')
DO WHILE input <> ''
PARSE VAR input varname '=' value '&' input
varName = TRANSLATE(varName) /* Upper-case the variable name to */
/* avoid OPS/MVS case-sensitivity */
/* issues on stem variable tails. */
value = DecodeAscii(value)
SELECT
WHEN SYMBOL('_cgi.0data.'varname'.0') = 'VAR' THEN
DO /* We've seen this variable multiple times, append this */
/* value onto the end of the stem variable... */
CALL VALUE '_cgi.0data.'varname'.0',
,VALUE('_cgi.0data.'varname'.0') + 1
CALL VALUE '_cgi.0data.'varname'.'VALUE('_cgi.0data.'varname'.0'),
,value
END
WHEN WORDPOS(varname,_cgi.0names) = 0 THEN
DO /* We've never seen this variable before... */
_cgi.0names = SPACE(_cgi.0names' 'varname)
CALL VALUE '_cgi.0data.'varname, value
END
OTHERWISE
/* We've seen this variable once before, now we'll convert it */
/* into a stem variable... */
CALL VALUE '_cgi.0data.'varname'.0', 2
CALL VALUE '_cgi.0data.'varname'.1', VALUE('_cgi.0data.'varname)
CALL VALUE '_cgi.0data.'varname'.2', value
DROP _cgi.0data.varname /* no need for the original value */
/* Remove the original (scalar) name from the varname list */
_cgi.0names = DELWORD(_cgi.0names,WORDPOS(varname,_cgi.0names),1)
/* Replace original name with the stemname */
_cgi.0names = SPACE(_cgi.0names' 'varname'.')
END
END /* DO WHILE input <> '' */
RETURN 0
/*--------------------------------------------------------------------*/
/*:DecodeAscii() function - returns CGI data variable with the %nn */
/* data expanded into characters. */
/* Most browsers insert ASCII codes (preceded by a %) for some */
/* characters such as space or +. */
/*--------------------------------------------------------------------*/
DecodeAscii: PROCEDURE EXPOSE gbl.
TRACE N
input = ARG(1)
DO WHILE POS('%',input) <> 0
PARSE VAR input pre '%' +1 char +2 input
IF VERIFY(TRANSLATE(Char),'0123456789ABCDEF')=0 THEN
IF 'A' = 'C1'x
THEN input=pre''TOEBCDIC(X2C(Char))''input
ELSE input=pre''X2C(Char)''input
ELSE input=pre''X2C('27')''char''input
END
input=TRANSLATE(input, '%', X2C('27'))
RETURN input
/*END OF CGIParse-----------------------------------------------------*/
/*RXCOPY TOEBCDIC NODUP 21 LINES COPIED ON 09-15-03 AT 10:16***********/
/*-Start of TOEBCDIC function---------------------------Version-01.02-*/
/*:TOEBCDIC Function: Returns an EBCDIC string equivalent to the */
/* ASCII string passed to it. */
/* Parms: 1 positional parm, ASCII text. */
/* Returns: EBCDIC text. */
/* Example: SAY TOEBCDIC(input.i) */
/* Copyright (C) 1996,2003 ProTech. All rights reserved. */
/*--------------------------------------------------------------------*/
TOEBCDIC:
TRACE N
/* 000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F */
RETURN TRANSLATE(ARG(1),,
'00010203372D2E2F1605250B0C0D0E0F101112133C3D322618193F27221D351F'x||,
'405A7F7B5B6C507D4D5D5C4E6B604B61F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'x||,
'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D'x||,
'79818283848586878889919293949596979899A2A3A4A5A6A7A8A9C04FD0A107'x||,
'4320211C23EB249B7128384990BAECDF45292A9D722B8A9A6756644A53685946'x||,
'EADA2CDE8B5541FE5851524869DB8E8D737475FA15B0B1B3B4B56AB7B8B9CCBC'x||,
'AB3E3B0ABF8F3A14A017CBCA1A1B9C0434EF1E0608097770BEBBAC5463656662'x||,
'30424757EE33B6E1CDED3644CECF31AAFC9EAE8CDDDC39FB80AFFD7876B29FFF'x)
/*-End of TOEBCDIC function-------------------------------------------*/
/*RXCOPY RXGETENV NODUP 26 LINES COPIED ON 09-15-03 AT 10:16***********/
/*START OF RxGetEnv-------------------------------------Version-01.00-*/
/*:RxGetEnv() function - returns the value of an environment variable */
/* Example: path = RxGetEnv('PATH') */
/*--------------------------------------------------------------------*/
RxGetEnv: PROCEDURE EXPOSE gbl. __environment.
PARSE UPPER SOURCE src +3 . _type .
SELECT
WHEN src = 'NT ' THEN
RETURN VALUE(ARG(1),,'DOSENVIRONMENT')
WHEN src = 'WIN' THEN
RETURN VALUE(ARG(1),,'ENVIRONMENT')
WHEN src = 'TSO' THEN
DO
IF SYMBOL('__environment.0') = 'VAR' THEN
DO i = 1 to __environment.0
PARSE VAR __environment.i name "=" value
IF TRANSLATE(name) = TRANSLATE(ARG(1))
THEN RETURN value
END i
RETURN ''
END
OTHERWISE
SAY 'Unsupported environment 2:' src
END
RETURN ''
/*END OF RxGetEnv-----------------------------------------------------*/
/*RXCOPY RXERROR NODUP 129 LINES COPIED ON 09-15-03 AT 10:16***********/
/*START OF RXERROR--------------------------------------Version-01.07-*/
/*:RXERROR SUBROUTINE: Generic REXX error condition handler. This */
/* routine gets control when a condition is raised, and: */
/* a. Validates that the condition is ok, and returns quietly, or */
/* b. Issues diagnostic messages about the error & where it occured. */
/* */
/* To use this routine, code the following near the top of your exec: */
/* CALL ON ERROR NAME RXERROR */
/* SIGNAL ON SYNTAX NAME RXERROR */
/* SIGNAL ON NOVALUE NAME RXERROR */
/* */
/* In addition, set the variable 'ok' to any return code values */
/* that are acceptable for host commands. For example: */
/* */
/* ok=4; ADDRESS TSO 'GETVARL GLOBAL_*'; DROP ok */
/* ok='4 8';"host cmd"; DROP ok <-- return codes 4 or 8 are ok */
/* ok='all';"host cmd"; DROP ok <-- all return codes are acceptable */
/* */
/* The first example permits GETVARL to get rc 4 and not fail or */
/* issue any error messages. Note that "ok=0" is always implied */
/* because the REXX ERROR condition is not raised if rc=0. */
/*------------------------------------------------------------------- */
/*NOTES: This subroutine does not use the PROCEDURE instruction, so */
/* variable names used within it must be _hidden. */
/* */
/* If an error occurs that's not one of the 'OK' values, */
/* execution will fall thru this subroutine and any statements */
/* following it will be executed. This is a good place to put */
/* cleanup logic, or a signal to your "cleanup-and-exit" label. */
/* */
/* Variables _RXERRORMSG1 and _RXERRORMSG2 are created when */
/* RXERROR falls thru, and may be used to send error msgs to */
/* other destinations, such as a GUI MSGBOX or ADDRESS AXC WTXC.*/
/* */
/* As a side effect, RXERROR sets ISPF "CONTROL ERRORS RETURN". */
/* If your routine doesn't run this way, you'll need to restore */
/* your ISPF CONTROL ERRORS setting. */
/* Copyright (C) 1996,2003 ProTech. All rights reserved. */
/*--------------------------------------------------------------------*/
RXERROR: TRACE N /* Turn off tracing for this func. */
_sigl = sigl
RXERROR1: TRACE N /* Turn off tracing for this func. */
CALL OFF ERROR
SIGNAL OFF SYNTAX
IF SYMBOL('rc') = 'VAR' THEN _rc = rc
ELSE _rc = 'n/a'
PARSE SOURCE _EX_ENV . _EX_NAME . . . . _EX_ADDRSPC .
IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /* Error or Failure? */
/* Yes. Were we CALLed? */
IF CONDITION('I') = 'CALL' | _EX_ENV = 'OPS/REXX' THEN
IF SYMBOL('OK') = 'VAR' THEN /* Yes. Is OK a variable? */
IF WORDPOS(_rc,ok)>0 | TRANSLATE(ok)='ALL' THEN /* Is error ok? */
DO /* Yes, return */
CALL ON ERROR NAME RXERROR /* Restore the */
SIGNAL ON SYNTAX NAME RXERROR /* Error handler */
DROP ZERRLM /* Toss any ISPF error msg */
rc = _rc /* Restore orig RC for caller */
RETURN /* Return to point of error */
END
IF SYMBOL('_errtext') = 'LIT'
THEN _errtext = ''; /* Initialize error text */
IF CONDITION('C') = 'SYNTAX' THEN /* If a REXX syntax error, */
IF _rc >= 0 & _rc < 100 /* and rc is within valid range, */
THEN _errtext = ' ('ERRORTEXT(_rc)')';/* then get REXX error text. */
ELSE NOP;
ELSE
IF CONDITION('C') = 'NOVALUE' THEN /* See if undefined variable */
DO;
_errtext = ' (No value for variable 'CONDITION('D')')';
_rc = 'n/a'; /* RC not set for NOVALUE */
END
ELSE
IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /*Hostcmd problem?*/
DO /* Extract host cmd name... */
_cmd = STRIP(STRIP(WORD(CONDITION('D'),1),'B','"'),'B',"'")
_errtext = ' (Host command '_cmd')'
_addr = ADDRESS() /* Find environment of failing cmd */
IF _sigl <= SOURCELINE() THEN/* Is source code avail? */
IF TRANSLATE(WORD(SOURCELINE(_sigl),1)) = 'ADDRESS'
THEN _addr = TRANSLATE(WORD(SOURCELINE(_sigl),2))
_addr = STRIP(TRANSLATE(_addr,,'!@#$%&*()_-+=;:,./?"'"'",' '))
IF _addr = 'PPQ' & SYMBOL('PPQ.ERROR') = 'VAR'
THEN _errtext = ' (Host command PPQ, 'ppq.error')'
IF _addr = 'VOX' & SYMBOL('VOX.ERROR') = 'VAR'
THEN _errtext = ' (Host command VOX, 'vox.error')'
IF _addr = 'ASODDE' | SYMBOL('ASODDE.ERROR') = 'VAR'
THEN _errtext = ' (Host command ASODDE, 'asodde.error')'
IF SYMBOL('SQLCODE') = 'VAR'
THEN _errtext = ' ( SQLCODE=' sqlcode')'
END
ELSE IF CONDITION('C') <> '' THEN
_errtext = ' (Condition='CONDITION('C')', Description=',
CONDITION('D')')'
_rxerrormsg1 = "RXERROR Error RC "_rc""_errtext" at line "_sigl,
"in EXEC" _ex_name
IF _sigl <= SOURCELINE() /* Is source code avail? */
THEN _rxerrormsg2 = "RXERROR Line "_sigl": "STRIP(SOURCELINE(_sigl))
ELSE _rxerrormsg2 = ""
IF _ex_addrspc = 'ISPF' THEN /* Running under ISPF? */
DO /* Yes, issue short & long msgs... */
ADDRESS ISPEXEC "CONTROL ERRORS RETURN" /* Capture all ISPF RCs */
zedsmsg = '' /* Format ISPF short message */
zedlmsg = "Error RC "_rc""_errtext" at line "_sigl" in EXEC" _ex_name
IF _sigl <= SOURCELINE() /* Is source code avail? */
THEN zedlmsg = LEFT(zedlmsg': ',78)STRIP(SOURCELINE(_sigl))
IF SYMBOL('ZERRLM') = 'VAR'
THEN zedlmsg = LEFT(zedlmsg,156) 'ISPF Error: 'STRIP(ZERRLM)
ADDRESS ISPEXEC "SETMSG MSG(ISRZ001)"
IF rc = 12 THEN /* ISPMLIB MESSAGE found? */
DO /* No, use SAY instead. */
SAY 'RXERROR ISPMLIB Message ISRZ001 Not Found'
SIGNAL _SAY_ERRMSG;
END
SIGNAL _SAY_SQLMSG;
END
_SAY_ERRMSG:
SAY _rxerrormsg1; IF _rxerrormsg2 <> '' THEN SAY _rxerrormsg2; SAY ''
_SAY_SQLMSG:
IF SYMBOL('SQLCODE') = 'VAR' & QUEUED() > 0 THEN
IF WORDPOS(sqlcode,'0 100') = 0 THEN
DO _i = 1 BY 1 WHILE QUEUED() > 0
PULL _stack
SAY 'SQL STACK:'RIGHT(_i,2)':'_stack
END
/*END OF RXERROR------------------------------------------------------*/
SIGNAL EXIT
/*RXCOPY RXGETENV NODUP 0 LINES COPIED ON 09-15-03 AT 10:16************/