000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGM87. 00020000 000300*AUTHOR. Kenneth W. Caldwell. 00030000 000400*INSTALLATION. Train-Right. 00040000 000500*DATE-WRITTEN. February 2, 2011. 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* It process an HTML form. 00120000 001300* It uses a document template program for HTML output. 00130000 001400* The client is an HTTP Web Browser. 00140000 001500* 00150000 001600 DATA DIVISION. 00160000 001700 WORKING-STORAGE SECTION. 00170000 001800* Fields for the DOCUMENT TEMPLATE. 00180000 001900 01. 00190000 002000 05 doc-token PIC X(16). 00200000 002100 05 doc-template-name PIC X(48) VALUE 'TRPDOC00'. 00210000 002200 05 doc-url PIC X(07) VALUE 'tr-url='. 00220000 002300 05 doc-msg PIC X(07) VALUE 'tr-msg='. 00230000 002400 05 doc-pgm PIC X(07) VALUE 'tr-pgm='. 00240000 002500 05 doc-team PIC X(12) VALUE 'tr-key-team='. 00250000 002600 05 doc-record PIC X(10) VALUE 'tr-record='. 00260000 002700 05 doc-symbollist PIC X(500). 00270000 002800 05 doc-symbollist-length PIC S9(8) BINARY. 00280000 002900 00290000 003000* Fields for WEB READ FORMFIELD. 00300000 003100 01. 00310000 003200 05 form-action PIC X(11) VALUE 'form-action'. 00320000 003300 05 form-team PIC X(09) VALUE 'form-team'. 00330000 003400 05 form-num PIC X(08) VALUE 'form-num'. 00340000 003500 00350000 003600* Fields for processing. 00360000 003700 05 tr-url PIC X(80). 00370000 003800 05 tr-url-length PIC S9(8) BINARY. 00380000 003900 05 tr-pgm PIC X(8). 00390000 004000 05 tr-pgm-length PIC S9(8) BINARY VALUE +8. 00400000 004100 05 user-action PIC X(8) VALUE SPACES. 00410000 004200 05 user-action-length PIC S9(8) BINARY VALUE +8. 00420000 004300* Don't put spaces in text field. See EVALUATE. 00430000 004400 05 user-team PIC X(4) VALUE LOW-VALUES. 00440000 004500 05 user-team-length PIC S9(8) BINARY VALUE +4. 00450000 004600 05 user-num PIC X(2) VALUE SPACES. 00460000 004700 05 user-num-length PIC S9(8) BINARY VALUE +2. 00470000 004800 05 msg1 PIC X(80). 00480000 004900 00490000 005000 COPY TRRECORD. 00500000 005100 00510000 005200* Fields for EXTRACT TCPIP. 00520000 005300 01. 00530000 005400 05 port-number-tcpip PIC X(5). 00540000 005500 00550000 005600* Fields for WEB EXTRACT. 00560000 005700 01. 00570000 005800 05 cvda-scheme PIC S9(8) BINARY. 00580000 005900 05 scheme-char PIC X(5). 00590000 006000 05 scheme-char-length PIC S9(8) BINARY. 00600000 006100 00610000 006200 05 host PIC X(116). 00620000 006300 05 host-length PIC S9(8) BINARY. 00630000 006400 00640000 006500 05 http-path PIC X(80). 00650000 006600 05 http-path-length PIC S9(8) BINARY. 00660000 006700 00670000 006800 LINKAGE SECTION. 00680000 006900 00690000 007000 PROCEDURE DIVISION. 00700000 007100 Main. 00710000 007200 EXEC CICS ASSIGN PROGRAM(tr-pgm) END-EXEC. 00720000 007300 00730000 007400 Receive-Trans-Input. 00740000 007500 EXEC CICS HANDLE CONDITION INVREQ(No-Form) 00750002 007510 NOTFND(No-Form) END-EXEC. 00751001 007600 00760000 007700 EXEC CICS WEB READ FORMFIELD(form-action) 00770000 007800 NAMELENGTH(LENGTH OF form-action) 00780000 007900 VALUE(user-action) 00790000 008000 VALUELENGTH(user-action-length) 00800000 008100 END-EXEC. 00810000 008200 00820000 008300* Determine HTML form action 00830000 008400 EVALUATE user-action(1:user-action-length) 00840000 008500 WHEN 'Retrieve' 00850000 008600 CONTINUE 00860000 008700 WHEN 'Clear' 00870000 008800 MOVE LOW-VALUES TO tr-record, user-team, user-num, msg1 00880000 008900 GO TO Build-Form 00890000 009000 END-EVALUATE. 00900000 009100 00910000 009200 EXEC CICS WEB READ FORMFIELD(form-team) 00920000 009300 NAMELENGTH(LENGTH OF form-team) 00930000 009400 VALUE(user-team) 00940000 009500 VALUELENGTH(user-team-length) 00950000 009600 END-EXEC. 00960000 009700 00970000 009800 MOVE FUNCTION UPPER-CASE(user-team) TO user-team. 00980000 009900 00990000 010000 EXEC CICS WEB READ FORMFIELD(form-num) 01000000 010100 NAMELENGTH(LENGTH OF form-num) 01010000 010200 VALUE(user-num) 01020000 010300 VALUELENGTH(user-num-length) 01030000 010400 END-EXEC. 01040000 010500 01050000 010600 MOVE FUNCTION UPPER-CASE(user-num) TO user-num. 01060000 010700 01070000 010800 Process-Data. 01080000 010900 EXEC CICS HANDLE CONDITION NOTFND(No-Record) END-EXEC. 01090000 011000 01100000 011100 EVALUATE user-team ALSO user-num 01110000 011200 WHEN LOW-VALUES ALSO SPACES 01120000 011300 WHEN SPACES ALSO SPACES 01130000 011400 MOVE 'No key information entered. 1st record displayed.' 01140000 011500 TO msg1 01150000 011600* Don't put spaces in text field. 01160000 011700 MOVE LOW-VALUES TO tr-key, user-team 01170000 011800 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 01180000 011900 RIDFLD(tr-key) GTEQ 01190000 012000 END-EXEC 01200000 012100 WHEN NOT SPACES ALSO SPACES 01210000 012200 MOVE 'Teamid only entered. 1st record for team displayed.' 01220000 012300 TO msg1 01230000 012400 MOVE user-team TO tr-key-team 01240000 012500 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 01250000 012600 RIDFLD(tr-key) 01260000 012700 KEYLENGTH(LENGTH OF tr-key-team) 01270000 012800 GENERIC 01280000 012900 END-EXEC 01290000 013000 WHEN OTHER 01300000 013100 MOVE 'Teamid and number entered. Exact match required.' 01310000 013200 TO msg1 01320000 013300 MOVE user-team TO tr-key-team 01330000 013400 MOVE user-num TO tr-key-num 01340000 013500* Don't put spaces in text field. 01350000 013600 MOVE LOW-VALUES TO user-team 01360000 013700 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 01370000 013800 RIDFLD(tr-key) 01380000 013900 EQUAL 01390000 014000 END-EXEC 01400000 014100 END-EVALUATE. 01410000 014200 01420000 014300 Build-Form. 01430000 014400* Build the URL from client invocation. 01440000 014500 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 01450000 014600 01460000 014700 EXEC CICS EXTRACT TCPIP 01470000 014800 PORTNUMBER(port-number-tcpip) 01480000 014900 END-EXEC. 01490000 015000 01500000 015100 MOVE LENGTH OF http-path TO http-path-length. 01510000 015200 MOVE LENGTH OF host TO host-length. 01520000 015300 01530000 015400 EXEC CICS WEB EXTRACT SCHEME(cvda-scheme) 01540000 015500 HOST(host) 01550000 015600 HOSTLENGTH(host-length) 01560000 015700 PATH(http-path) 01570000 015800 PATHLENGTH(http-path-length) 01580000 015900 END-EXEC. 01590000 016000 01600000 016100 EVALUATE cvda-scheme 01610000 016200 WHEN DFHVALUE(HTTP) 01620000 016300 MOVE 'Http' TO scheme-char 01630000 016400 MOVE +4 TO scheme-char-length 01640000 016500 WHEN DFHVALUE(HTTPS) 01650000 016600 MOVE 'Https' TO scheme-char 01660000 016700 MOVE +5 TO scheme-char-length 01670000 016800 WHEN OTHER 01680000 016900 MOVE SPACES TO scheme-char 01690000 017000 END-EVALUATE. 01700000 017100 01710000 017200 MOVE +1 TO tr-url-length. 01720000 017300 STRING scheme-char(1:scheme-char-length) 01730000 017400 '://' 01740000 017500 host(1:host-length) 01750000 017600 ':' 01760000 017700 port-number-tcpip 01770000 017800 http-path(1:http-path-length) 01780000 017900 DELIMITED BY SIZE 01790000 018000 INTO tr-url 01800000 018100 WITH POINTER tr-url-length 01810000 018200 END-STRING. 01820000 018300 SUBTRACT +1 FROM tr-url-length. 01830000 018400 01840000 018500 Build-Document. 01850000 018600 MOVE +1 TO doc-symbollist-length. 01860000 018700 STRING doc-url tr-url(1:tr-url-length) 01870000 018800 '&' doc-pgm tr-pgm 01880000 018900 '&' doc-team user-team 01890000 019000 '&' doc-msg msg1 01900000 019100 '&' doc-record tr-record 01910000 019200 DELIMITED BY SIZE 01920000 019300 INTO doc-symbollist 01930000 019400 WITH POINTER doc-symbollist-length 01940000 019500 END-STRING. 01950000 019600 SUBTRACT +1 FROM doc-symbollist-length. 01960000 019700 01970000 019800 EXEC CICS DOCUMENT CREATE DOCTOKEN(doc-token) 01980000 019900 TEMPLATE(doc-template-name) 01990000 020000 SYMBOLLIST(doc-symbollist) 02000000 020100 LISTLENGTH(doc-symbollist-length) 02010000 020200 END-EXEC. 02020000 020300 02030000 020400 Send-Result. 02040000 020500* CICS converts EBCDIC to ASCII. 02050000 020600 EXEC CICS WEB SEND DOCTOKEN(doc-token) 02060000 020700 SERVERCONV(DFHVALUE(SRVCONVERT)) 02070000 020800 END-EXEC. 02080000 020900 02090000 021000 Process-Exit. 02100000 021100 EXEC CICS RETURN END-EXEC. 02110000 021200* Dummy GOBACK. 02120000 021300 GOBACK. 02130000 021400 02140000 021500 No-Form. 02150000 022310 EVALUATE eibresp ALSO eibresp2 02231001 022320 WHEN DFHRESP(INVREQ) ALSO 1 02232001 022330 WHEN DFHRESP(INVREQ) ALSO 3 02233001 022340 GO TO Not-Web 02234001 022350 WHEN DFHRESP(INVREQ) ALSO 13 02235001 022360 WHEN DFHRESP(NOTFND) ALSO 1 02236001 022361 MOVE LOW-VALUES TO tr-record, user-team, user-num, msg1 02236101 022390 GO TO Build-Form 02239001 022391 END-EVALUATE. 02239101 022400 02240000 022500 Not-Web. 02250000 022600 MOVE 'Client is not an HTTP Web Browser.' TO msg1. 02260000 022700 EXEC CICS SEND FROM(msg1) LENGTH(34) ERASE END-EXEC. 02270000 022800 EXEC CICS RETURN END-EXEC. 02280000 022900 02290000 023000 No-Record. 02300000 023100 MOVE 'No record found with provided information.' TO msg1. 02310000 023200 MOVE SPACES TO tr-record. 02320000 023300 GO TO Build-Form. 02330000