000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGM83. 00020000 000300*AUTHOR. Kenneth W. Caldwell. 00030000 000400*INSTALLATION. Train-Right. 00040000 000500*DATE-WRITTEN. December 31, 2010. 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 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-url PIC X(07) VALUE 'tr-url='. 00210000 002200 05 doc-wins PIC X(08) VALUE 'tr-wins='. 00220000 002300 05 doc-losses PIC X(10) VALUE 'tr-losses='. 00230000 002400 05 doc-msg PIC X(07) VALUE 'tr-msg='. 00240000 002500 05 doc-pgm PIC X(07) VALUE 'tr-pgm='. 00250000 002600 05 doc-symbollist PIC X(200). 00260000 002700 05 doc-symbollist-length PIC S9(8) BINARY. 00270000 002800 00280000 002900* Fields for WEB READ FORMFIELD. 00290000 003000 01. 00300000 003100 05 form-choice PIC X(11) VALUE 'form-choice'. 00310000 003200 05 form-wins PIC X(09) VALUE 'form-wins'. 00320000 003300 05 form-losses PIC X(11) VALUE 'form-losses'. 00330000 003400 05 form-action PIC X(11) VALUE 'form-action'. 00340000 003500 05 form-pgm PIC X(08) VALUE 'form-pgm'. 00350000 003600 00360000 003700 05 tr-url PIC X(80). 00370000 003800 05 tr-url-length PIC S9(8) BINARY. 00380000 003900 05 tr-wins PIC ZZ,ZZ9. 00390000 004000 05 tr-wins-length PIC S9(8) BINARY VALUE +6. 00400000 004100 05 tr-losses PIC ZZ,ZZ9. 00410000 004200 05 tr-losses-length PIC S9(8) BINARY VALUE +6. 00420000 004300 05 user-action PIC X(5) VALUE SPACES. 00430000 004400 05 user-action-length PIC S9(8) BINARY VALUE +5. 00440000 004500 05 user-choice PIC X(8) VALUE SPACES. 00450000 004600 05 user-choice-length PIC S9(8) BINARY VALUE +8. 00460000 004700 05 user-pgm PIC X(7) VALUE 'trpgm83'. 00470000 004800 05 user-pgm-length PIC S9(8) BINARY VALUE +7. 00480000 004900 00490000 005000* Fields for processing. 00500000 005100 01. 00510000 005200 05 wins PIC S9(4) BINARY. 00520000 005300 05 losses PIC S9(4) BINARY. 00530000 005400 05 pgm-choice PIC 9 PACKED-DECIMAL. 00540000 005500 05 msg PIC X(80). 00550000 005600 00560000 005700* Fields for EXTRACT TCPIP. 00570000 005800 01. 00580000 005900 05 port-number-tcpip PIC X(5). 00590000 006000 00600000 006100* Fields for WEB EXTRACT. 00610000 006200 01. 00620000 006300 05 cvda-scheme PIC S9(8) BINARY. 00630000 006400 05 scheme-char PIC X(5). 00640000 006500 05 scheme-char-length PIC S9(8) BINARY. 00650000 006600 00660000 006700 05 host PIC X(116). 00670000 006800 05 host-length PIC S9(8) BINARY. 00680000 006900 00690000 007000 05 http-path PIC X(80). 00700000 007100 05 http-path-length PIC S9(8) BINARY. 00710000 007200 00720000 007300 LINKAGE SECTION. 00730000 007400 00740000 007500 PROCEDURE DIVISION. 00750000 007600 Main. 00760000 007700 EXEC CICS HANDLE CONDITION INVREQ(No-Form) 00770001 007710 NOTFND(No-Form) END-EXEC. 00771001 007800 00780000 007900 Receive-Trans-Input. 00790000 008000 EXEC CICS WEB READ FORMFIELD(form-action) 00800000 008100 NAMELENGTH(LENGTH OF form-action) 00810000 008200 VALUE(user-action) 00820000 008300 VALUELENGTH(user-action-length) 00830000 008400 END-EXEC. 00840000 008500 00850000 008600* Determine HTML form action 00860000 008700 EVALUATE user-action(1:user-action-length) 00870000 008800 WHEN 'Play' 00880000 008900 CONTINUE 00890000 009000 WHEN 'Clear' 00900000 009100 MOVE ZERO TO wins, losses 00910000 009200 MOVE 'Scores cleared. Please play again.' TO msg 00920002 009300 GO TO Build-Form 00930000 009400 END-EVALUATE. 00940000 009500 00950000 009600* No radio buttons selected. 00960000 009700 EXEC CICS IGNORE CONDITION NOTFND END-EXEC. 00970000 009800 00980000 009900 EXEC CICS WEB READ FORMFIELD(form-choice) 00990000 010000 NAMELENGTH(LENGTH OF form-choice) 01000000 010100 VALUE(user-choice) 01010000 010200 VALUELENGTH(user-choice-length) 01020000 010300 END-EXEC. 01030000 010400 01040000 010500 EXEC CICS WEB READ FORMFIELD(form-wins) 01050000 010600 NAMELENGTH(LENGTH OF form-wins) 01060000 010700 VALUE(tr-wins) 01070000 010800 VALUELENGTH(tr-wins-length) 01080000 010900 END-EXEC. 01090000 011000 01100000 011100 EXEC CICS WEB READ FORMFIELD(form-losses) 01110000 011200 NAMELENGTH(LENGTH OF form-losses) 01120000 011300 VALUE(tr-losses) 01130000 011400 VALUELENGTH(tr-losses-length) 01140000 011500 END-EXEC. 01150000 011600 01160000 011700 EXEC CICS WEB READ FORMFIELD(form-pgm) 01170000 011800 NAMELENGTH(LENGTH OF form-pgm) 01180000 011900 VALUE(user-pgm) 01190000 012000 VALUELENGTH(user-pgm-length) 01200000 012100 END-EXEC. 01210000 012200 01220000 012300 Process-Data. 01230000 012400 MOVE tr-wins TO wins. 01240000 012500 MOVE tr-losses TO losses. 01250000 012600 01260000 012700 COMPUTE pgm-choice ROUNDED = 01270000 012800 FUNCTION RANDOM(eibtaskn + eibtime) * 2 01280000 012900 END-COMPUTE. 01290000 013000 01300000 013100 EVALUATE user-choice(1:user-choice-length) ALSO pgm-choice 01310000 013200 WHEN 'ROCK' ALSO 0 01320000 013300 MOVE 'Two Rocks is a tie.' TO msg 01330000 013400 WHEN 'PAPER' ALSO 1 01340000 013500 MOVE 'Two Papers is a tie.' TO msg 01350000 013600 WHEN 'SCISSORS' ALSO 2 01360000 013700 MOVE 'Two Scissors is a tie.' TO msg 01370000 013800 WHEN 'ROCK' ALSO 1 01380000 013900 MOVE 'Paper covers Rock - I win!' TO msg 01390000 014000 ADD +1 TO losses 01400000 014100 WHEN 'ROCK' ALSO 2 01410000 014200 MOVE 'Rock smashes Scissors - You win!' TO msg 01420000 014300 ADD +1 TO wins 01430000 014400 WHEN 'PAPER' ALSO 0 01440000 014500 MOVE 'Paper covers Rock - You win!' TO msg 01450000 014600 ADD +1 TO wins 01460000 014700 WHEN 'PAPER' ALSO 2 01470000 014800 MOVE 'Scissors cut Paper - I win!' TO msg 01480000 014900 ADD +1 TO losses 01490000 015000 WHEN 'SCISSORS' ALSO 0 01500000 015100 MOVE 'Rock smashes Scissors - I win!' TO msg 01510000 015200 ADD +1 TO losses 01520000 015300 WHEN 'SCISSORS' ALSO 1 01530000 015400 MOVE 'Scissors cut Paper - You win!' TO msg 01540000 015500 ADD +1 TO wins 01550000 015600 WHEN OTHER 01560000 015700 MOVE 'You did not select "Rock", "Paper", or "Scissors". Pl01570000 015800- 'ease try again.' TO msg 01580000 015900 END-EVALUATE. 01590000 016000 01600000 016100 Build-Form. 01610000 016200* Build the URL from client invocation. 01620000 016300 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 01630000 016400 01640000 016500 EXEC CICS EXTRACT TCPIP 01650000 016600 PORTNUMBER(port-number-tcpip) 01660000 016700 END-EXEC. 01670000 016800 01680000 016900 MOVE LENGTH OF http-path TO http-path-length. 01690000 017000 MOVE LENGTH OF host TO host-length. 01700000 017100 01710000 017200 EXEC CICS WEB EXTRACT SCHEME(cvda-scheme) 01720000 017300 HOST(host) 01730000 017400 HOSTLENGTH(host-length) 01740000 017500 PATH(http-path) 01750000 017600 PATHLENGTH(http-path-length) 01760000 017700 END-EXEC. 01770000 017800 01780000 017900 EVALUATE cvda-scheme 01790000 018000 WHEN DFHVALUE(HTTP) 01800000 018100 MOVE 'Http' TO scheme-char 01810000 018200 MOVE +4 TO scheme-char-length 01820000 018300 WHEN DFHVALUE(HTTPS) 01830000 018400 MOVE 'Https' TO scheme-char 01840000 018500 MOVE +5 TO scheme-char-length 01850000 018600 WHEN OTHER 01860000 018700 MOVE SPACES TO scheme-char 01870000 018800 END-EVALUATE. 01880000 018900 01890000 019000 MOVE +1 TO tr-url-length. 01900000 019100 STRING scheme-char(1:scheme-char-length) 01910000 019200 '://' 01920000 019300 host(1:host-length) 01930000 019400 ':' 01940000 019500 port-number-tcpip 01950000 019600 http-path(1:http-path-length) 01960000 019700 DELIMITED BY SIZE 01970000 019800 INTO tr-url 01980000 019900 WITH POINTER tr-url-length 01990000 020000 END-STRING. 02000000 020100 SUBTRACT +1 FROM tr-url-length. 02010000 020200 02020000 020300 Build-Document. 02030000 020400 INSPECT tr-url(1:tr-url-length) 02040000 020500 REPLACING FIRST 'trpgm83' BY user-pgm. 02050000 020600 02060000 020700 MOVE wins TO tr-wins. 02070000 020800 MOVE losses TO tr-losses. 02080000 020900 02090000 021000 MOVE +1 TO doc-symbollist-length. 02100000 021100 STRING doc-pgm user-pgm 02110000 021200 ', trhtml81, trhtml82 & trhtml84' 02120000 021300 DELIMITED BY SIZE 02130000 021400 INTO doc-symbollist 02140000 021500 WITH POINTER doc-symbollist-length 02150000 021600 END-STRING. 02160000 021700 SUBTRACT +1 FROM doc-symbollist-length. 02170000 021800 02180000 021900* Use a dummy delimiter - data contains & but only 1 symbol. 02190000 022000 EXEC CICS DOCUMENT CREATE DOCTOKEN(doc-token) 02200000 022100 TEMPLATE('TRHTML81') 02210000 022200 SYMBOLLIST(doc-symbollist) 02220000 022300 LISTLENGTH(doc-symbollist-length) 02230000 022400 DELIMITER('/') 02240000 022500 END-EXEC. 02250000 022600 02260000 022700 MOVE +1 TO doc-symbollist-length. 02270000 022800 STRING doc-url tr-url(1:tr-url-length) 02280000 022900 '&' doc-wins tr-wins 02290000 023000 '&' doc-losses tr-losses 02300000 023100 '&' doc-msg msg 02310000 023200 DELIMITED BY SIZE 02320000 023300 INTO doc-symbollist 02330000 023400 WITH POINTER doc-symbollist-length 02340000 023500 END-STRING. 02350000 023600 SUBTRACT +1 FROM doc-symbollist-length. 02360000 023700 02370000 023800 EXEC CICS DOCUMENT SET DOCTOKEN(doc-token) 02380000 023900 SYMBOLLIST(doc-symbollist) 02390000 024000 LENGTH(doc-symbollist-length) 02400000 024100 END-EXEC. 02410000 024200 02420000 024300 EXEC CICS DOCUMENT INSERT DOCTOKEN(doc-token) 02430000 024400 TEMPLATE('TRHTML82') 02440000 024500 END-EXEC. 02450000 024600 02460000 024700 EXEC CICS DOCUMENT INSERT DOCTOKEN(doc-token) 02470000 024800 TEMPLATE('TRHTML84') 02480000 024900 END-EXEC. 02490000 025000 02500000 025100 Send-Result. 02510000 025200* CICS converts EBCDIC to ASCII. 02520000 025300 EXEC CICS WEB SEND DOCTOKEN(doc-token) 02530000 025400 SERVERCONV(DFHVALUE(SRVCONVERT)) 02540000 025500 END-EXEC. 02550000 025600 02560000 025700 Process-Exit. 02570000 025800 EXEC CICS RETURN END-EXEC. 02580000 025900* Dummy GOBACK. 02590000 026000 GOBACK. 02600000 026100 02610000 026200 No-Form. 02620000 026300 EVALUATE eibresp ALSO eibresp2 02630001 026400 WHEN DFHRESP(INVREQ) ALSO 1 02640001 026500 WHEN DFHRESP(INVREQ) ALSO 3 02650001 026600 GO TO Not-Web 02660001 026700 WHEN DFHRESP(INVREQ) ALSO 13 02670001 026800 WHEN DFHRESP(NOTFND) ALSO 1 02680001 026900 MOVE ZERO TO wins, losses 02690001 027000 MOVE 'Let''s play Rock, Paper, Scissors!' TO msg 02700001 027100 GO TO Build-Form 02710001 027110 END-EVALUATE. 02711001 027200 02720000 027300 Not-Web. 02730000 027400 MOVE 'Client is not an HTTP Web Browser.' TO msg. 02740000 027500 EXEC CICS SEND FROM(msg) LENGTH(34) ERASE END-EXEC. 02750000 027600 EXEC CICS RETURN END-EXEC. 02760000