000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGMxx. 00020000 000300*AUTHOR. 00030000 000400*INSTALLATION. 00040000 000500*DATE-WRITTEN. 00050000 000600*DATE-COMPILED. 00060000 000700* 00070000 000800*SECURITY. This program is for students of Train-Right 00080000 000900* courses ONLY!. 00090000 001000* 00100000 001100*REMARKS. This is a TCP/IP Web based program. 00110000 001200* The client is an HTTP Web Browser. 00120000 001300* 00130000 001400 DATA DIVISION. 00140000 001500 WORKING-STORAGE SECTION. 00150000 001600* Fields for the DOCUMENT TEMPLATE. 00160000 001700 01. 00170000 001800 05 doc-token PIC X(16). 00180000 001900 05 doc-template-name PIC X(48) VALUE 00190000 002000 05 doc-url PIC X(07) VALUE 'tr-url='. 00200000 002100 05 doc-msg PIC X(07) VALUE 'tr-msg='. 00210000 002200 05 doc-symbollist PIC X(500). 00220000 002300 05 doc-symbollist-length PIC S9(8) BINARY. 00230000 002400 00240000 002500* Fields for WEB READ FORMFIELD. 00250000 002600 01. 00260000 002700 05 form-action PIC X(11) VALUE 'form-action'. 00270000 002800 00280000 002900* Fields for processing. 00290000 003000 05 tr-url PIC X(80). 00300000 003100 05 tr-url-length PIC S9(8) BINARY. 00310000 003200 05 user-action PIC X(8) VALUE SPACES. 00320000 003300 05 user-action-length PIC S9(8) BINARY VALUE +8. 00330000 003400 05 msg1 PIC X(80). 00340000 003500 00350000 003600* Fields for EXTRACT TCPIP. 00360000 003700 01. 00370000 003800 05 port-number-tcpip PIC X(5). 00380000 003900 00390000 004000* Fields for WEB EXTRACT. 00400000 004100 01. 00410000 004200 05 cvda-scheme PIC S9(8) BINARY. 00420000 004300 05 scheme-char PIC X(5). 00430000 004400 05 scheme-char-length PIC S9(8) BINARY. 00440000 004500 00450000 004600 05 host PIC X(116). 00460000 004700 05 host-length PIC S9(8) BINARY. 00470000 004800 00480000 004900 05 http-path PIC X(80). 00490000 005000 05 http-path-length PIC S9(8) BINARY. 00500000 005100 00510000 005200 LINKAGE SECTION. 00520000 005300 00530000 005400 PROCEDURE DIVISION. 00540000 005500 Main. 00550000 005600 00560000 005700 Receive-Trans-Input. 00570000 005800 EXEC CICS HANDLE CONDITION INVREQ(No-Form) END-EXEC. 00580000 005810 NOTFND(No-Form) END-EXEC. 00581001 005900 00590000 006000 EXEC CICS WEB READ FORMFIELD(form-action) 00600000 006100 NAMELENGTH(LENGTH OF form-action) 00610000 006200 VALUE(user-action) 00620000 006300 VALUELENGTH(user-action-length) 00630000 006400 END-EXEC. 00640000 006500 00650000 006600 Determine HTML form action 00660000 006700 EVALUATE user-action(1:user-action-length) 00670000 006800 WHEN 00680000 006900 CONTINUE 00690000 007000 WHEN 'Clear' 00700000 007100 MOVE LOW-VALUES TO msg1 00710000 007200 GO TO Build-Form 00720000 007300 END-EVALUATE. 00730000 007400 00740000 007500 Process-Data. 00750000 007600 00760000 007700 Build-Form. 00770000 007800* Build the URL from client invocation. 00780000 007900 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00790000 008000 00800000 008100 EXEC CICS EXTRACT TCPIP 00810000 008200 PORTNUMBER(port-number-tcpip) 00820000 008300 END-EXEC. 00830000 008400 00840000 008500 MOVE LENGTH OF http-path TO http-path-length. 00850000 008600 MOVE LENGTH OF host TO host-length. 00860000 008700 00870000 008800 EXEC CICS WEB EXTRACT SCHEME(cvda-scheme) 00880000 008900 HOST(host) 00890000 009000 HOSTLENGTH(host-length) 00900000 009100 PATH(http-path) 00910000 009200 PATHLENGTH(http-path-length) 00920000 009300 END-EXEC. 00930000 009400 00940000 009500 EVALUATE cvda-scheme 00950000 009600 WHEN DFHVALUE(HTTP) 00960000 009700 MOVE 'Http' TO scheme-char 00970000 009800 MOVE +4 TO scheme-char-length 00980000 009900 WHEN DFHVALUE(HTTPS) 00990000 010000 MOVE 'Https' TO scheme-char 01000000 010100 MOVE +5 TO scheme-char-length 01010000 010200 WHEN OTHER 01020000 010300 MOVE SPACES TO scheme-char 01030000 010400 END-EVALUATE. 01040000 010500 01050000 010600 MOVE +1 TO tr-url-length. 01060000 010700 STRING scheme-char(1:scheme-char-length) 01070000 010800 '://' 01080000 010900 host(1:host-length) 01090000 011000 ':' 01100000 011100 port-number-tcpip 01110000 011200 http-path(1:http-path-length) 01120000 011300 DELIMITED BY SIZE 01130000 011400 INTO tr-url 01140000 011500 WITH POINTER tr-url-length 01150000 011600 END-STRING. 01160000 011700 SUBTRACT +1 FROM tr-url-length. 01170000 011800 01180000 011900 Build-Document. 01190000 012000 MOVE +1 TO doc-symbollist-length. 01200000 012100 STRING doc-url tr-url(1:tr-url-length) 01210000 012200 '&' doc-msg msg1 01220000 012300 DELIMITED BY SIZE 01230000 012400 INTO doc-symbollist 01240000 012500 WITH POINTER doc-symbollist-length 01250000 012600 END-STRING. 01260000 012700 SUBTRACT +1 FROM doc-symbollist-length. 01270000 012800 01280000 012900 EXEC CICS DOCUMENT CREATE DOCTOKEN(doc-token) 01290000 013000 TEMPLATE(doc-template-name) 01300000 013100 SYMBOLLIST(doc-symbollist) 01310000 013200 LISTLENGTH(doc-symbollist-length) 01320000 013300 END-EXEC. 01330000 013400 01340000 013500 Send-Result. 01350000 013600* CICS converts EBCDIC to ASCII. 01360000 013700 EXEC CICS WEB SEND DOCTOKEN(doc-token) 01370000 013800 SERVERCONV(DFHVALUE(SRVCONVERT)) 01380000 013900 END-EXEC. 01390000 014000 01400000 014100 Process-Exit. 01410000 014200 EXEC CICS RETURN END-EXEC. 01420000 014300* Dummy GOBACK. 01430000 014400 GOBACK. 01440000 014500 01450000 014600 No-Form. 01460000 015410 EVALUATE eibresp ALSO eibresp2 01541002 015420 WHEN DFHRESP(INVREQ) ALSO 1 01542002 015430 WHEN DFHRESP(INVREQ) ALSO 3 01543002 015440 GO TO Not-Web 01544002 015450 WHEN DFHRESP(INVREQ) ALSO 13 01545002 015460 WHEN DFHRESP(NOTFND) ALSO 1 01546002 015470 MOVE LOW-VALUES TO msg1 01547002 015480 GO TO Build-Form 01548002 015490 END-EVALUATE. 01549002 015500 01550000 015600 Not-Web. 01560000 015700 MOVE 'Client is not an HTTP Web Browser.' TO msg1. 01570000 015800 EXEC CICS SEND FROM(msg1) LENGTH(34) ERASE END-EXEC. 01580000 015900 EXEC CICS RETURN END-EXEC. 01590000