1.00 |
********START OF PGM : COOKIE **************************************** |
2.00 |
*================================================================ |
3.00 |
* |
4.00 |
* After compiling this module, create the program as follow: |
5.00 |
* |
6.00 |
* CRTPGM PGM(CGICBLDEV2/COOKIE) MODULE(CGICBLDEV2/COOKIE) |
7.00 |
* BNDDIR(CGICBLDEV2/CGICBLDEV2) ACTGRP(COOKIE) |
8.00 |
* |
9.00 |
*================================================================ |
10.00 |
PROCESS NOXREF APOST |
11.00 |
ID DIVISION. |
12.00 |
PROGRAM-ID. COOKIE. |
13.00 |
ENVIRONMENT DIVISION. |
14.00 |
CONFIGURATION SECTION. |
15.00 |
SPECIAL-NAMES. |
16.00 |
copy CPYSPCNAME of CGICBLDEV2-QCBLLESRC. |
17.00 |
INPUT-OUTPUT SECTION. |
18.00 |
FILE-CONTROL. |
19.00 |
*================================================================= |
20.00 |
DATA DIVISION. |
21.00 |
FILE SECTION. |
22.00 |
*================================================================= |
23.00 |
WORKING-STORAGE SECTION. |
24.00 |
*================================================================= |
25.00 |
01 HTML-DATA. |
26.00 |
* Variables to execute a command |
27.00 |
05 rc PIC S9(9) comp-4. |
28.00 |
05 cmd PIC X(2000). |
29.00 |
* Variables to parse the input string |
30.00 |
05 varnamein PIC X(50). |
31.00 |
05 xdocloc PIC X(1000). |
32.00 |
* Variables to load external HTML |
33.00 |
05 fn PIC X(10) VALUE 'HTMLEXAMPL'. |
34.00 |
05 lib PIC X(10) VALUE 'CGICBLDEV2'. |
35.00 |
05 mbr PIC X(10) VALUE 'COOKIE'. |
36.00 |
* Variable for QWrtSection procedure |
37.00 |
05 HtmlSects PIC X(1000). |
38.00 |
* Variables for QUpdHtmlVar procedure |
39.00 |
05 varnameout PIC X(30). |
40.00 |
05 varvalout PIC X(1000). |
41.00 |
* Variables for QRtvDomain procedure |
42.00 |
05 docloc PIC X(1000). |
43.00 |
05 xdomain PIC X(1000). |
44.00 |
* Variables for QAddSubDur |
45.00 |
05 baseStamp PIC X(26). |
46.00 |
05 addSub PIC X(1) value '+'. |
47.00 |
05 addSubYears PIC S9(9) comp-4 value 0. |
48.00 |
05 addSubMonths PIC S9(9) comp-4 value 0. |
49.00 |
05 addSubDays PIC S9(9) comp-4 value 2. |
50.00 |
05 addSubHours PIC S9(9) comp-4 value 0. |
51.00 |
05 addSubMins PIC S9(9) comp-4 value 0. |
52.00 |
05 addSubSecs PIC S9(9) comp-4 value 0. |
53.00 |
05 retStamp PIC X(26). |
54.00 |
* Variables for QCrtCookie procedure |
55.00 |
01 setCookHd PIC X(5000). |
56.00 |
01 retcode PIC S9(9) comp-4. |
57.00 |
01 cookName PIC X(1000). |
58.00 |
01 cookVal PIC X(4000). |
59.00 |
01 cookDom PIC X(1000). |
60.00 |
01 cookPath PIC X(1000). |
61.00 |
01 cookSecure PIC 1. |
62.00 |
01 cookExpire PIC X(26). |
63.00 |
* Variables for QRtvCookie procedure |
64.00 |
01 cookValX PIC X(5000). |
65.00 |
01 cookNameX PIC X(1000). |
66.00 |
01 cookOccurX PIC S9(9) comp-4 value 1. |
67.00 |
* Variables for QRandomString procedure |
68.00 |
01 randomString PIC X(1024). |
69.00 |
01 stringLen PIC S9(9) comp-4 value 10. |
70.00 |
01 firstchar PIC X(1000). |
71.00 |
01 remainChar PIC X(1000). |
72.00 |
* Miscellaneous variables |
73.00 |
01 MISC-DATA. |
74.00 |
05 nowDatTim FORMAT TIMESTAMP. |
75.00 |
05 nowDatTim1 redefines nowDatTim. |
76.00 |
10 nowyear PIC X(04). |
77.00 |
10 nowmonth PIC X(02). |
78.00 |
10 nowday PIC X(02). |
79.00 |
10 nowhours PIC X(02). |
80.00 |
10 nowmins PIC X(02). |
81.00 |
10 nowsecs PIC X(02). |
82.00 |
05 stampnow PIC X(26). |
83.00 |
* |
84.00 |
05 nbrmonth PIC S9(02) comp-3. |
85.00 |
05 nbryear PIC S9(04) comp-3. |
86.00 |
*================================================================= |
87.00 |
* M A I N - L I N E |
88.00 |
*================================================================= |
89.00 |
PROCEDURE DIVISION. |
90.00 |
A-start-pgm. |
91.00 |
* Load the external HTML |
92.00 |
call 'QGETHTML' using fn lib mbr. |
93.00 |
* Get input data from POST or GET |
94.00 |
call 'QZHBGETINPUT'. |
95.00 |
* Get input variable 'xdocloc' (document location, e.g. http://89.234.101. |
96.00 |
* (document location, e.g. http://89.234.101.99:1220/cgicbldev2p/cooki |
97.00 |
move 'xdocloc' to varnamein. |
98.00 |
call 'QZHBGETVAR' using |
99.00 |
by content varnamein |
100.00 |
returning into xdocloc. |
101.00 |
* Extract domain from document location |
102.00 |
* Example: |
103.00 |
* -document location http://89.234.101.99:1220/cgicbldev2p/cookie.pgm ) |
104.00 |
* -domain 89.234.101.99:1220 |
105.00 |
move xdocloc to docloc. |
106.00 |
call 'QRTVDOMAIN' using |
107.00 |
by content docloc |
108.00 |
returning into xdomain. |
109.00 |
* FIX ADDED ON JAN 19, 2012 <============================================= |
110.00 |
* Forget about the domain name previously extracted. |
111.00 |
* Set instead the domain name to blank. |
112.00 |
* In this way the WEB browser assumes as domain of the cookie |
113.00 |
* the name of the host creating the cookie. |
114.00 |
move ' ' to xdomain. |
115.00 |
* Issue the section that will create a cookie |
116.00 |
perform CrtNewCook thru z-CrtNewCook. |
117.00 |
* Retrieve cookie current value and display it |
118.00 |
perform RtvCook thru z-RtvCook. |
119.00 |
* Complete and send the output buffer |
120.00 |
move 'endhtml *fini' to HtmlSects |
121.00 |
call 'QWRTSECTION' using HtmlSects. |
122.00 |
*---------------------------------- |
123.00 |
B-end-pgm. |
124.00 |
exit program and continue run unit. |
125.00 |
*================================================================= |
126.00 |
CrtNewCook. |
127.00 |
* Issue the section that will create a cookie |
128.00 |
* Make up a random string |
129.00 |
move '*UPPERLETTER' to firstChar |
130.00 |
move '*DIGIT' to remainChar |
131.00 |
call 'QRANDOMSTRING' using |
132.00 |
stringLen |
133.00 |
firstChar |
134.00 |
remainChar |
135.00 |
returning randomString. |
136.00 |
* - Assign the name of the cookie |
137.00 |
move 'Cookie319' to cookName. |
138.00 |
* - Assign to the cookie the value of the random string |
139.00 |
move randomString to cookVal. |
140.00 |
* - Assign the domain of the cookie |
141.00 |
move xdomain to cookDom. |
142.00 |
* - Assign the path of the cookie |
143.00 |
move '/' to cookPath. |
144.00 |
* - Assign '*off' to the security flag of the cookie |
145.00 |
move '0' to cookSecure. |
146.00 |
* - Get the current time stamp |
147.00 |
call 'QCURRDATE' returning stampnow. |
148.00 |
* - Assign the expiration date of the cookie as twodays from now |
149.00 |
move stampnow to basestamp |
150.00 |
call 'QADDSUBDUR' using basestamp |
151.00 |
addSub |
152.00 |
addSubYears |
153.00 |
addSubMonths |
154.00 |
addSubDays |
155.00 |
addSubHours |
156.00 |
addSubMins |
157.00 |
addSubSecs |
158.00 |
returning retstamp. |
159.00 |
move retstamp to cookExpire. |
160.00 |
* - Use procedure "QCrtCookie" to build the Set-Cookie header "setCookHd" |
161.00 |
call 'QCRTCOOKIE' using |
162.00 |
retcode |
163.00 |
cookName |
164.00 |
cookVal |
165.00 |
cookDom |
166.00 |
cookPath |
167.00 |
cookSecure |
168.00 |
cookExpire |
169.00 |
returning setcookHd. |
170.00 |
* - Set output variable /%setmycookie%/ |
171.00 |
move 'setmycookie' to varnameout |
172.00 |
move setcookHd to varvalout |
173.00 |
call 'QUPDHTMLVAR' using varnameout varvalout. |
174.00 |
* - Send section '/$top' that will create the cookie |
175.00 |
move 'top' to HtmlSects |
176.00 |
call 'QWRTSECTION' using HtmlSects. |
177.00 |
*---------------------------------- |
178.00 |
z-CrtNewCook. |
179.00 |
EXIT. |
180.00 |
*================================================================= |
181.00 |
RtvCook. |
182.00 |
* Retrieve cookie current value and display it |
183.00 |
* - Assign the name of the cookie |
184.00 |
move 'Cookie319' to cookNameX. |
185.00 |
* - Use procedure "QRtvCookie" to retrieve the value of the cookie |
186.00 |
call 'QRTVCOOKIE' using cookNameX |
187.00 |
returning cookValX. |
188.00 |
* - Display the value retrieved for the cookie |
189.00 |
move 'cookienam' to varnameout |
190.00 |
move cookNameX to varvalout |
191.00 |
call 'QUPDHTMLVAR' using varnameout varvalout. |
192.00 |
move 'cookieval' to varnameout |
193.00 |
move cookValX to varvalout |
194.00 |
call 'QUPDHTMLVAR' using varnameout varvalout. |
195.00 |
if cookValX = ' ' |
196.00 |
move 'cookieno' to HtmlSects |
197.00 |
else |
198.00 |
move 'cookieyes' to HtmlSects |
199.00 |
end-if. |
200.00 |
call 'QWRTSECTION' using HtmlSects. |
201.00 |
*---------------------------------- |
202.00 |
z-RtvCook. |
203.00 |
EXIT. |
204.00 |
********* END OF PGM : COOKIE **************************************** |