QUERY_TEXT = ". 043100 5 QUERYTEXT PIC X(256) VALUE SPACES. 043200 5 FILLER PIC X(5) VALUE "
". 043300 5 FILLER PIC X VALUE CR. 043400 5 FILLER PIC X VALUE LF. 043500 043600* buffers for reading env vars via getenv() from Posix C lib 043700 043800 01 env-name PIC X(80). 043900 01 env-pointer PIC S9(9) COMP. 044000 01 env-text PIC X(80). 044100 01 env-length PIC S9(9) COMP. 044200 044300* counter for the test loop writing lines back to client 044400 044500 01 loop-count PIC 9(9). 044600 044700* buffers for reading client input from stdin (Method POST) 044800 044900 01 post-length PIC s9(9) COMP. 045000 01 post-buf PIC x(256). 045100 01 post-get PIC s9(9) COMP. 045200 01 post-got PIC 9(9). 045300 01 post-pos PIC s9(9) COMP. 045400 045500* buffers for extracting "field1=value1&field2=value2..." 045600 045700 01 field-name PIC x(80). 045800 01 field-name-len PIC s9(9) COMP. 045900 01 field-value PIC x(80). 046000 01 field-value-len PIC s9(9) COMP. 046100 046200* message for the test loop (only passed WITH Method POST) 046300 046400 01 test-msg PIC x(80). 046500 01 test-msg-len PIC s9(9) COMP. 046600 046700 01 CRLF. 046800 5 FILLER PIC X VALUE CR. 046900 5 FILLER PIC X VALUE LF. 047000 047100 77 H1 PIC X(24) VALUE ''. 047200 77 HTOP PIC X(14) VALUE ''. 047300 77 H2 PIC X(41) VALUE 047400 '
' CRLF. 055900 DISPLAY HF6 CRLF. 056000 DISPLAY HF6 '
' CRLF. 056100 056200 DISPLAY HF7 CRLF. 056300 DISPLAY HF8 '
' CRLF. 056400 DISPLAY HF9 CRLF. 056500 DISPLAY HF9 CRLF. 056600 056700 DISPLAY HEFORM CRLF. 056800 056900 CALL INTRINSIC "DATELINE" USING DATELINE. 057000 DISPLAY 'Cross Reference for ' BASE-NAME ' - ' 057100 DATELINE. 057200 057300 DISPLAY "" CR LF. 057400 057500 DISPLAY HREFS. 057600 057700 CALL "DBOPEN" USING BASE, PASSWORD, MODE5, STAT. 057800 057900 IF IMAGE-STATUS NOT = 0 058000 DISPLAY "Database " BASE-NAME 058100* " pass=" PASSWORD 058200 " not opened" CRLF 058300 058400 PERFORM DBEXPLAIN 058500 058600 ELSE 058700 058800 PERFORM BASIC-PROGRAM. 058900 059000 DISPLAY "" CR LF 059100 DISPLAY "" CR LF. 059200 059300 STOP RUN. 059400 059500 TPI. 059600 INITIALIZE TPI-DATA. 059700 CALL "DBINFO" USING BASE, QUALIFIER, MODE801, STAT, 059800 TPI-DATA. 059900 060000 IF IMAGE-STATUS NOT = 0 OR TPI-PRODUCT = SPACES 060100 DISPLAY "No Third Party Indexing (TPI) on " 060200 BASE-NAME '' CRLF 060300 ELSE 060400 CALL "DBINFO" USING BASE, QUALIFIER, MODE802, STAT, 060500 SUB 060600 IF IMAGE-STATUS NOT = 0 PERFORM DBEXPLAIN 060700 ELSE 060800 IF SUB > 0 060900 DISPLAY "TPI Enabled: " TPI-PRODUCT CRLF 061000 DISPLAY " Version: " TPI-VERSION CRLF 061100 SET TPI-ON TO TRUE 061200 ELSE 061300 DISPLAY "TPI Disabled: " TPI-PRODUCT CRLF 061400 DISPLAY " Version: " TPI-VERSION CRLF. 061500 061600* IF TPI-ON 061700* MOVE 813 TO MODE103 061800* MOVE 814 TO MODE104. 061900 062000 GET-VARIABLES. 062100* Get the information from the post: 062200 062300 STRING "SERVER_SOFTWARE", NUL 062400 DELIMITED BY SIZE INTO ENV-NAME. 062500 062600 PERFORM MY-GETENV. 062700 062800 STRING "REMOTE_ADDR", NUL 062900 DELIMITED BY SIZE INTO ENV-NAME. 063000 063100 PERFORM MY-GETENV. 063200 063300 STRING ENV-TEXT DELIMITED BY NUL 063400 INTO TCPIP. 063500 063600 STRING "REQUEST_METHOD" NUL 063700 DELIMITED BY SIZE INTO env-name. 063800 063900 PERFORM my-getenv. 064000 064100 STRING "CONTENT_LENGTH" NUL 064200 DELIMITED BY SIZE INTO env-name. 064300 064400 PERFORM my-getenv. 064500 064600* DISPLAY "POST Method received CONTENT_LENGTH as " 064700* env-text (1 : env-length) "
" CR LF. 064800 064900 IF env-length = 0 then 065000 065100 DISPLAY "GET Method needs valid QUERY_STRING
" CR LF. 065200 065300* ELSE 065400 065500* DISPLAY "GET Method received QUERY_STRING as " 065600* env-text (1:env-length) "
" CR LF. 065700 065800 COMPUTE post-length = function numval (env-text) 065900 066000 IF post-length > function length (post-buf) then 066100 066200 DISPLAY "Too much DATA for my POST buffer
" CR LF 066300 066400 ELSE 066500 066600 COMPUTE post-get = - post-length 066700 066800 CALL intrinsic "readx" 066900 USING post-buf , post-get GIVING post-got. 067000 067100* DISPLAY "Received " post-got " bytes WITH " 067200* post-buf (1 : post-got) "
" CR LF. 067300 067400 MOVE POST-BUF (1 : POST-GOT) TO QUERYTEXT. 067500 067600 INSPECT QUERYTEXT REPLACING ALL "+" BY SPACES. 067700 INSPECT QUERYTEXT REPLACING ALL CR BY SPACES. 067800 INSPECT QUERYTEXT REPLACING ALL LF BY SPACES. 067900 INSPECT QUERYTEXT REPLACING ALL NUL BY SPACES. 068000 INSPECT QUERYTEXT REPLACING ALL LOW-VALUES BY SPACES. 068100 INSPECT QUERYTEXT REPLACING ALL HIGH-VALUES BY SPACES. 068200 068300* DISPLAY QUERY-TEXT. 068400 068500 UNSTRING QUERYTEXT 068600 DELIMITED BY "database=" OR "&password=" OR 068700 "&B1=" OR "&R1=" 068800 INTO UNSTRING1 DELIMITER IN UNSTRING2N 068900 UNSTRING2 DELIMITER IN UNSTRING3N 069000 UNSTRING3 DELIMITER IN UNSTRING4N 069100 UNSTRING4 DELIMITER IN UNSTRING5N 069200 UNSTRING5 DELIMITER IN UNSTRING6N 069300 ON OVERFLOW 069400 DISPLAY "Unstring Overflow Occured
" cr lf. 069500 069600* DISPLAY "UNSTRING1 =" UNSTRING1 CRLF. 069700* DISPLAY "UNSTRING2N=" UNSTRING2N CRLF. 069800 069900* DISPLAY "UNSTRING2 =" UNSTRING2 CRLF. 070000* DISPLAY "UNSTRING3N=" UNSTRING3N CRLF. 070100 070200* DISPLAY "UNSTRING3 =" UNSTRING3 CRLF. 070300* DISPLAY "UNSTRING4N=" UNSTRING4N CRLF. 070400 070500 070600* DISPLAY "UNSTRING4 =" UNSTRING4 CRLF. 070700* DISPLAY "UNSTRING5N=" UNSTRING5N CRLF. 070800 070900 071000* DISPLAY "UNSTRING5 =" UNSTRING5 CRLF. 071100* DISPLAY "UNSTRING6N=" UNSTRING6N CRLF. 071200 071300 IF UNSTRING2 NOT = SPACES MOVE UNSTRING2 TO BASE-NAME. 071400 IF UNSTRING3 NOT = SPACES MOVE UNSTRING3 TO PASSWORD. 071500 071600 071700 BASIC-PROGRAM. 071800 PERFORM TPI. 071900 DISPLAY '
'. 072000 DISPLAY 'Datasets Summary:
' CRLF. 072100 072200* Get all dataset names, store in table, sort in order: 072300 PERFORM DBINFO-CALL203. 072400 072500* Display datasets in database in summary format: 072600 072700 PERFORM DISPLAY-DATA-SETS Q0 (1) TIMES. 072800 DISPLAY HREFS. 072900 DISPLAY "
". 073000 073100* Display items in database: 073200 DISPLAY 'Items
' CRLF. 073300 PERFORM DBINFO-CALL103. 073400 DISPLAY HREFS. 073500 DISPLAY "
". 073600 DISPLAY 'Datasets:
' CRLF. 073700 DISPLAY "------- DATA SETS and Items " 073800 'for ' BASE-NAME "
" CRLF. 073900 MOVE "href_" TO NR-PREFIX1. 074000 MOVE "summ_" TO NR-PREFIX2. 074100 074200 MOVE 0 TO SS-PTR6. 074300 074400* Display datasets with items and paths: 074500 PERFORM DISPLAY-DATA-SET-ITEMS Q0 (1) TIMES. 074600 DISPLAY HREFS. 074700 DISPLAY "
". 074800 DISPLAY "
GET Method needs valid QUERY_STRING
" CR LF 145100 145200 145300 ELSE 145400 145500 DISPLAY "GET Method received QUERY_STRING as " 145600 env-text (1:env-length) "
" CR LF 145700 145800 COMPUTE loop-count = function numval (env-text) 145900 146000 IF loop-count < 1 then 146100 MOVE 1 to loop-count 146200 DISPLAY "Loop Count was less than one
" CR LF 146300 end-if 146400 146500 IF loop-count > 1000 then 146600 MOVE 1000 to loop-count 146700 DISPLAY "Loop Count was greater than 1000
" CR LF 146800 end-if 146900 147000* Now return the (loop-count) lines to the web client 147100 147200 DISPLAY "" CR LF 147300 147400 PERFORM WITH test before until loop-count < 1 147500 DISPLAY "Test message loop countdown at " loop-count CR LF 147600 SUBTRACT 1 from loop-count 147700 end-perform 147800 147900 DISPLAY "" CR LF 148000 148100 end-if. 148200 148300 148400* HANDLE-POST: Handle an http Method POST request from client 148500 148600* First retrieve the CONTENT_LENGTH Posix env var and echo it back 148700* to the client. Then read that number of bytes from stdin, unless 148800* it is more than our buffer can hold, and echo it back to the web 148900* page. Parse the input STRING for fields named MYTEXT and MYLOOP, 149000* supplying default values in case they are missing. Finally send 149100* output lines WITH MYTEXT according to the MYLOOP count. 149200 149300* Notice that the output loop does not CALL the PRINT intrinsic 149400* for every line but tries to combine as many lines as possible 149500* in the (relatively large) output buffer. This might improve the 149600* performance and reduce the resource consumption. The loops in 149700* handle-post and handle-get have been implemented differently to 149800* allow comparing them easily (try 1000 loops, for example). 149900 150000 150100 handle-post. 150200 STRING "CONTENT_LENGTH" NUL 150300 DELIMITED BY SIZE INTO env-name. 150400 150500 PERFORM my-getenv. 150600 150700 DISPLAY "
POST Method received CONTENT_LENGTH as " 150800 env-text (1 : env-length) "
" CR LF 150900 151000 COMPUTE post-length = function numval (env-text) 151100 151200 IF post-length > function length (post-buf) then 151300 151400 DISPLAY "Too much DATA for my POST buffer
" CR LF 151500 151600 ELSE 151700 151800 COMPUTE post-get = - post-length 151900 152000 CALL intrinsic "readx" 152100 USING post-buf , post-get GIVING post-got 152200 152300 DISPLAY "Received " post-got " bytes WITH " 152400 post-buf (1 : post-got) "
" CR LF 152500 152600* Use defaults IF MYLOOP and/or MYTEXT missing in HTML Form 152700 152800 MOVE 10 to loop-count 152900 MOVE "Default Test Message" to test-msg 153000 MOVE 20 to test-msg-len 153100 153200* Terminate the buffer STRING for easier parsing loop 153300 153400 MOVE "&" to post-buf (post-got + 1 : 1) 153500 153600* Begin parsing to extract MYLOOP and MYTEXT fields 153700 153800 MOVE 1 to post-pos 153900 154000 PERFORM WITH test before until post-length <= 0 154100 154200 INITIALIZE field-name 154300 INITIALIZE field-value 154400 154500 UNSTRING post-buf delimited by "=" 154600 INTO field-name count in field-name-len 154700 WITH pointer post-pos 154800 154900 UNSTRING post-buf delimited by "&" 155000 INTO field-value count in field-value-len 155100 WITH pointer post-pos 155200 155300 EVALUATE field-name 155400 WHEN "mytext" MOVE field-value to test-msg 155500 MOVE field-value-len to test-msg-len 155600 WHEN "myloop" COMPUTE loop-count 155700 = function numval (field-value) 155800 end-evaluate 155900 156000 SUBTRACT field-name-len from post-length 156100 SUBTRACT field-value-len from post-length 156200 SUBTRACT 2 from post-length 156300 156400 end-perform 156500 156600* Now return the (loop-count) lines to the web client, 156700* but utilize our buffer to use fewer calls to PRINT 156800 156900 DISPLAY "" CR LF 157000 157100 PERFORM WITH test before until loop-count <= 0 157200 157300 DISPLAY "Countdown at " loop-count 157400 " WITH message " test-msg (1 : test-msg-len) CR LF 157500 157600 157700 SUBTRACT 1 from loop-count 157800 157900 end-perform 158000 158100 DISPLAY "" CR LF 158200 158300 end-if. 158400 158500 158600* HANDLE-ERR: Return error to client for unknown REQUEST-METHOD 158700 158800 handle-err. 158900 DISPLAY "
Unknown REQUEST_METHOD " 159000 env-text (1 : env-length) " received
" CR LF. 159100 159200* MY-GETENV: retrieve Posix env var USING Posix C lib functions 159300 159400* getenv() returns pointer to C STRING, strlen() determines 159500* STRING length and strncpy() copies appropriate number of 159600* characters to a buffer var in our WORKING-STORAGE SECTION. 159700 159800* notice that this version silently clips "too long" input 159900* and returns a zero-length STRING for undefined env vars. 160000 160100 my-getenv. 160200 INITIALIZE env-text. 160300 160400 CALL "getenv" 160500 USING env-name GIVING env-pointer. 160600 160700 IF env-pointer > 0 then 160800 CALL "strlen" 160900 USING \env-pointer\ GIVING env-length 161000 161100 IF env-length > function length(env-text) then 161200 COMPUTE env-length = function length(env-text) 161300 end-if 161400 161500 CALL "strncpy" 161600 USING env-text , \env-pointer\ , \env-length\ 161700 ELSE 161800 MOVE 0 to env-length 161900 162000 end-if. 162100