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