MFmainframe-rea
WS carddemo · 26f629ef

Converted program · 155 lines of TypeScript from 299 lines of COBOL · 168 COBOL lines cited (56%)COUSR01C

Run it on the 3270 →Analysis →All programs

TypeScript carddemo-ts/src/programs/COUSR01C.ts

1/**
2 * COUSR01C — add a user to USRSEC (transaction CU01).
3 * Converted from app/cbl/COUSR01C.cbl; screen COUSR01/COUSR1A; file USRSEC.
4 */
5import { alnum, isBlank } from "../runtime/cobol.js";
6import { RESP, type Cics, type Program } from "../runtime/cics.js";
7import type { SymbolicMap } from "../runtime/screen.js";
8import type { SecUserData } from "../generated/records.js";
9import { CCDA_MSG_INVALID_KEY, populateHeaderInfo } from "./common.js";
10import { delimitedBySpace, dropCuInfo, returnToPrevScreen, WS_USRSEC_FILE } from "./users-lib.js";
11
12const WS_PGMNAME = "COUSR01C";
13const WS_TRANID = "CU01";
14
15/** WS-VARIABLES (COUSR01C.cbl:35-44) */
16interface Ws {
17 message: string;
18 errFlg: string;
19 respCd: number;
20}
21
22export const COUSR01C: Program = {
23 name: WS_PGMNAME,
24 source: "app/cbl/COUSR01C.cbl",
25 run(ctx: Cics) {
26 const ws: Ws = { message: "", errFlg: "N", respCd: 0 };
27 let out = ctx.map("COUSR01", "COUSR1A");
28
29 // MAIN-PARA (COUSR01C.cbl:71-110)
30 ws.errFlg = "N";
31 ws.message = "";
32 out.set("ERRMSG", "");
33
34 if (ctx.eib.calen === 0) {
35 ctx.area().toProgram = "COSGN00C";
36 returnToPrevScreen(ctx, WS_TRANID, WS_PGMNAME);
37 }
38 const area = ctx.area();
39 // CARDDEMO-COMMAREA of COUSR01C is COCOM01Y only: no CU0x-INFO trailer is kept.
40 dropCuInfo(ctx);
41 if (area.pgmContext !== 1) {
42 area.pgmContext = 1;
43 out.clear();
44 out.cursor("FNAME");
45 sendUsraddScreen(ctx, out, ws);
46 } else {
47 out = receiveUsraddScreen(ctx, ws);
48 switch (ctx.eib.aid) {
49 case "ENTER":
50 processEnterKey(ctx, out, ws);
51 break;
52 case "PF3":
53 area.toProgram = "COADM01C";
54 returnToPrevScreen(ctx, WS_TRANID, WS_PGMNAME);
55 // falls through: XCTL does not return
56 case "PF4":
57 clearCurrentScreen(ctx, out, ws);
58 break;
59 default:
60 ws.errFlg = "Y";
61 out.cursor("FNAME");
62 ws.message = CCDA_MSG_INVALID_KEY;
63 sendUsraddScreen(ctx, out, ws);
64 }
65 }
66 ctx.return(WS_TRANID, area);
67 },
68};
69
70/** PROCESS-ENTER-KEY (COUSR01C.cbl:115-160) */
71function processEnterKey(ctx: Cics, out: SymbolicMap, ws: Ws): void {
72 const required: [field: string, message: string][] = [
73 ["FNAME", "First Name can NOT be empty..."],
74 ["LNAME", "Last Name can NOT be empty..."],
75 ["USERID", "User ID can NOT be empty..."],
76 ["PASSWD", "Password can NOT be empty..."],
77 ["USRTYPE", "User Type can NOT be empty..."],
78 ];
79 // EVALUATE TRUE: only the first empty field is reported.
80 const missing = required.find(([field]) => isBlank(out.get(field)));
81 if (missing) {
82 ws.errFlg = "Y";
83 ws.message = missing[1];
84 out.cursor(missing[0]);
85 sendUsraddScreen(ctx, out, ws);
86 } else {
87 out.cursor("FNAME");
88 }
89
90 if (ws.errFlg !== "Y") {
91 const rec: SecUserData = {
92 secUsrId: alnum(out.get("USERID"), 8),
93 secUsrFname: alnum(out.get("FNAME"), 20),
94 secUsrLname: alnum(out.get("LNAME"), 20),
95 secUsrPwd: alnum(out.get("PASSWD"), 8),
96 secUsrType: alnum(out.get("USRTYPE"), 1),
97 // SEC-USR-FILLER is never moved to: WORKING-STORAGE without VALUE (taken as spaces).
98 secUsrFiller: alnum("", 23),
99 };
100 writeUserSecFile(ctx, out, ws, rec);
101 }
102}
103
104/** SEND-USRADD-SCREEN (COUSR01C.cbl:184-196) */
105function sendUsraddScreen(ctx: Cics, out: SymbolicMap, ws: Ws): void {
106 populateHeaderInfo(ctx, out, WS_TRANID, WS_PGMNAME);
107 out.set("ERRMSG", ws.message);
108 ctx.sendMap(out, { erase: true, cursor: true });
109}
110
111/** RECEIVE-USRADD-SCREEN (COUSR01C.cbl:201-209) */
112function receiveUsraddScreen(ctx: Cics, ws: Ws): SymbolicMap {
113 const { resp, map } = ctx.receiveMap("COUSR01", "COUSR1A");
114 ws.respCd = resp;
115 return map;
116}
117
118/** WRITE-USER-SEC-FILE (COUSR01C.cbl:238-274) */
119function writeUserSecFile(ctx: Cics, out: SymbolicMap, ws: Ws, rec: SecUserData): void {
120 ws.respCd = ctx.write(WS_USRSEC_FILE, rec);
121 switch (ws.respCd) {
122 case RESP.NORMAL:
123 initializeAllFields(out, ws);
124 ws.message = "";
125 out.color("ERRMSG", "GREEN");
126 ws.message = `User ${delimitedBySpace(rec.secUsrId)} has been added ...`;
127 sendUsraddScreen(ctx, out, ws);
128 break;
129 case RESP.DUPKEY:
130 case RESP.DUPREC:
131 ws.errFlg = "Y";
132 ws.message = "User ID already exist...";
133 out.cursor("USERID");
134 sendUsraddScreen(ctx, out, ws);
135 break;
136 default:
137 ws.errFlg = "Y";
138 ws.message = "Unable to Add User...";
139 out.cursor("FNAME");
140 sendUsraddScreen(ctx, out, ws);
141 }
142}
143
144/** CLEAR-CURRENT-SCREEN (COUSR01C.cbl:279-282) */
145function clearCurrentScreen(ctx: Cics, out: SymbolicMap, ws: Ws): void {
146 initializeAllFields(out, ws);
147 sendUsraddScreen(ctx, out, ws);
148}
149
150/** INITIALIZE-ALL-FIELDS (COUSR01C.cbl:287-295) */
151function initializeAllFields(out: SymbolicMap, ws: Ws): void {
152 out.cursor("FNAME");
153 for (const f of ["USERID", "FNAME", "LNAME", "PASSWD", "USRTYPE"]) out.set(f, " ".repeat(20));
154 ws.message = "";
155}

COBOL app/cbl/COUSR01C.cbl

1 ******************************************************************
2 * Program : COUSR01C.CBL
3 * Application : CardDemo
4 * Type : CICS COBOL Program
5 * Function : Add a new Regular/Admin user to USRSEC file
6 ******************************************************************
7 * Copyright Amazon.com, Inc. or its affiliates.
8 * All Rights Reserved.
9 *
10 * Licensed under the Apache License, Version 2.0 (the "License").
11 * You may not use this file except in compliance with the License.
12 * You may obtain a copy of the License at
13 *
14 * http://www.apache.org/licenses/LICENSE-2.0
15 *
16 * Unless required by applicable law or agreed to in writing,
17 * software distributed under the License is distributed on an
18 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
19 * either express or implied. See the License for the specific
20 * language governing permissions and limitations under the License
21 ******************************************************************
22 IDENTIFICATION DIVISION.
23 PROGRAM-ID. COUSR01C.
24 AUTHOR. AWS.
25
26 ENVIRONMENT DIVISION.
27 CONFIGURATION SECTION.
28
29 DATA DIVISION.
30 *----------------------------------------------------------------*
31 * WORKING STORAGE SECTION
32 *----------------------------------------------------------------*
33 WORKING-STORAGE SECTION.
34
35 01 WS-VARIABLES.
36 05 WS-PGMNAME PIC X(08) VALUE 'COUSR01C'.
37 05 WS-TRANID PIC X(04) VALUE 'CU01'.
38 05 WS-MESSAGE PIC X(80) VALUE SPACES.
39 05 WS-USRSEC-FILE PIC X(08) VALUE 'USRSEC '.
40 05 WS-ERR-FLG PIC X(01) VALUE 'N'.
41 88 ERR-FLG-ON VALUE 'Y'.
42 88 ERR-FLG-OFF VALUE 'N'.
43 05 WS-RESP-CD PIC S9(09) COMP VALUE ZEROS.
44 05 WS-REAS-CD PIC S9(09) COMP VALUE ZEROS.
45
46 COPY COCOM01Y.
47
48 COPY COUSR01.
49
50 COPY COTTL01Y.
51 COPY CSDAT01Y.
52 COPY CSMSG01Y.
53 COPY CSUSR01Y.
54
55 COPY DFHAID.
56 COPY DFHBMSCA.
57 *COPY DFHATTR.
58
59 *----------------------------------------------------------------*
60 * LINKAGE SECTION
61 *----------------------------------------------------------------*
62 LINKAGE SECTION.
63 01 DFHCOMMAREA.
64 05 LK-COMMAREA PIC X(01)
65 OCCURS 1 TO 32767 TIMES DEPENDING ON EIBCALEN.
66
67 *----------------------------------------------------------------*
68 * PROCEDURE DIVISION
69 *----------------------------------------------------------------*
70 PROCEDURE DIVISION.
71 MAIN-PARA.
72
73 SET ERR-FLG-OFF TO TRUE
74
75 MOVE SPACES TO WS-MESSAGE
76 ERRMSGO OF COUSR1AO
77
78 IF EIBCALEN = 0
79 MOVE 'COSGN00C' TO CDEMO-TO-PROGRAM
80 PERFORM RETURN-TO-PREV-SCREEN
81 ELSE
82 MOVE DFHCOMMAREA(1:EIBCALEN) TO CARDDEMO-COMMAREA
83 IF NOT CDEMO-PGM-REENTER
84 SET CDEMO-PGM-REENTER TO TRUE
85 MOVE LOW-VALUES TO COUSR1AO
86 MOVE -1 TO FNAMEL OF COUSR1AI
87 PERFORM SEND-USRADD-SCREEN
88 ELSE
89 PERFORM RECEIVE-USRADD-SCREEN
90 EVALUATE EIBAID
91 WHEN DFHENTER
92 PERFORM PROCESS-ENTER-KEY
93 WHEN DFHPF3
94 MOVE 'COADM01C' TO CDEMO-TO-PROGRAM
95 PERFORM RETURN-TO-PREV-SCREEN
96 WHEN DFHPF4
97 PERFORM CLEAR-CURRENT-SCREEN
98 WHEN OTHER
99 MOVE 'Y' TO WS-ERR-FLG
100 MOVE -1 TO FNAMEL OF COUSR1AI
101 MOVE CCDA-MSG-INVALID-KEY TO WS-MESSAGE
102 PERFORM SEND-USRADD-SCREEN
103 END-EVALUATE
104 END-IF
105 END-IF
106
107 EXEC CICS RETURN
108 TRANSID (WS-TRANID)
109 COMMAREA (CARDDEMO-COMMAREA)
110 END-EXEC.
111
112 *----------------------------------------------------------------*
113 * PROCESS-ENTER-KEY
114 *----------------------------------------------------------------*
115 PROCESS-ENTER-KEY.
116
117 EVALUATE TRUE
118 WHEN FNAMEI OF COUSR1AI = SPACES OR LOW-VALUES
119 MOVE 'Y' TO WS-ERR-FLG
120 MOVE 'First Name can NOT be empty...' TO
121 WS-MESSAGE
122 MOVE -1 TO FNAMEL OF COUSR1AI
123 PERFORM SEND-USRADD-SCREEN
124 WHEN LNAMEI OF COUSR1AI = SPACES OR LOW-VALUES
125 MOVE 'Y' TO WS-ERR-FLG
126 MOVE 'Last Name can NOT be empty...' TO
127 WS-MESSAGE
128 MOVE -1 TO LNAMEL OF COUSR1AI
129 PERFORM SEND-USRADD-SCREEN
130 WHEN USERIDI OF COUSR1AI = SPACES OR LOW-VALUES
131 MOVE 'Y' TO WS-ERR-FLG
132 MOVE 'User ID can NOT be empty...' TO
133 WS-MESSAGE
134 MOVE -1 TO USERIDL OF COUSR1AI
135 PERFORM SEND-USRADD-SCREEN
136 WHEN PASSWDI OF COUSR1AI = SPACES OR LOW-VALUES
137 MOVE 'Y' TO WS-ERR-FLG
138 MOVE 'Password can NOT be empty...' TO
139 WS-MESSAGE
140 MOVE -1 TO PASSWDL OF COUSR1AI
141 PERFORM SEND-USRADD-SCREEN
142 WHEN USRTYPEI OF COUSR1AI = SPACES OR LOW-VALUES
143 MOVE 'Y' TO WS-ERR-FLG
144 MOVE 'User Type can NOT be empty...' TO
145 WS-MESSAGE
146 MOVE -1 TO USRTYPEL OF COUSR1AI
147 PERFORM SEND-USRADD-SCREEN
148 WHEN OTHER
149 MOVE -1 TO FNAMEL OF COUSR1AI
150 CONTINUE
151 END-EVALUATE
152
153 IF NOT ERR-FLG-ON
154 MOVE USERIDI OF COUSR1AI TO SEC-USR-ID
155 MOVE FNAMEI OF COUSR1AI TO SEC-USR-FNAME
156 MOVE LNAMEI OF COUSR1AI TO SEC-USR-LNAME
157 MOVE PASSWDI OF COUSR1AI TO SEC-USR-PWD
158 MOVE USRTYPEI OF COUSR1AI TO SEC-USR-TYPE
159 PERFORM WRITE-USER-SEC-FILE
160 END-IF.
161
162 *----------------------------------------------------------------*
163 * RETURN-TO-PREV-SCREEN
164 *----------------------------------------------------------------*
165 RETURN-TO-PREV-SCREEN.
166
167 IF CDEMO-TO-PROGRAM = LOW-VALUES OR SPACES
168 MOVE 'COSGN00C' TO CDEMO-TO-PROGRAM
169 END-IF
170 MOVE WS-TRANID TO CDEMO-FROM-TRANID
171 MOVE WS-PGMNAME TO CDEMO-FROM-PROGRAM
172 * MOVE WS-USER-ID TO CDEMO-USER-ID
173 * MOVE SEC-USR-TYPE TO CDEMO-USER-TYPE
174 MOVE ZEROS TO CDEMO-PGM-CONTEXT
175 EXEC CICS
176 XCTL PROGRAM(CDEMO-TO-PROGRAM)
177 COMMAREA(CARDDEMO-COMMAREA)
178 END-EXEC.
179
180
181 *----------------------------------------------------------------*
182 * SEND-USRADD-SCREEN
183 *----------------------------------------------------------------*
184 SEND-USRADD-SCREEN.
185
186 PERFORM POPULATE-HEADER-INFO
187
188 MOVE WS-MESSAGE TO ERRMSGO OF COUSR1AO
189
190 EXEC CICS SEND
191 MAP('COUSR1A')
192 MAPSET('COUSR01')
193 FROM(COUSR1AO)
194 ERASE
195 CURSOR
196 END-EXEC.
197
198 *----------------------------------------------------------------*
199 * RECEIVE-USRADD-SCREEN
200 *----------------------------------------------------------------*
201 RECEIVE-USRADD-SCREEN.
202
203 EXEC CICS RECEIVE
204 MAP('COUSR1A')
205 MAPSET('COUSR01')
206 INTO(COUSR1AI)
207 RESP(WS-RESP-CD)
208 RESP2(WS-REAS-CD)
209 END-EXEC.
210
211 *----------------------------------------------------------------*
212 * POPULATE-HEADER-INFO
213 *----------------------------------------------------------------*
214 POPULATE-HEADER-INFO.
215
216 MOVE FUNCTION CURRENT-DATE TO WS-CURDATE-DATA
217
218 MOVE CCDA-TITLE01 TO TITLE01O OF COUSR1AO
219 MOVE CCDA-TITLE02 TO TITLE02O OF COUSR1AO
220 MOVE WS-TRANID TO TRNNAMEO OF COUSR1AO
221 MOVE WS-PGMNAME TO PGMNAMEO OF COUSR1AO
222
223 MOVE WS-CURDATE-MONTH TO WS-CURDATE-MM
224 MOVE WS-CURDATE-DAY TO WS-CURDATE-DD
225 MOVE WS-CURDATE-YEAR(3:2) TO WS-CURDATE-YY
226
227 MOVE WS-CURDATE-MM-DD-YY TO CURDATEO OF COUSR1AO
228
229 MOVE WS-CURTIME-HOURS TO WS-CURTIME-HH
230 MOVE WS-CURTIME-MINUTE TO WS-CURTIME-MM
231 MOVE WS-CURTIME-SECOND TO WS-CURTIME-SS
232
233 MOVE WS-CURTIME-HH-MM-SS TO CURTIMEO OF COUSR1AO.
234
235 *----------------------------------------------------------------*
236 * WRITE-USER-SEC-FILE
237 *----------------------------------------------------------------*
238 WRITE-USER-SEC-FILE.
239
240 EXEC CICS WRITE
241 DATASET (WS-USRSEC-FILE)
242 FROM (SEC-USER-DATA)
243 LENGTH (LENGTH OF SEC-USER-DATA)
244 RIDFLD (SEC-USR-ID)
245 KEYLENGTH (LENGTH OF SEC-USR-ID)
246 RESP (WS-RESP-CD)
247 RESP2 (WS-REAS-CD)
248 END-EXEC.
249
250 EVALUATE WS-RESP-CD
251 WHEN DFHRESP(NORMAL)
252 PERFORM INITIALIZE-ALL-FIELDS
253 MOVE SPACES TO WS-MESSAGE
254 MOVE DFHGREEN TO ERRMSGC OF COUSR1AO
255 STRING 'User ' DELIMITED BY SIZE
256 SEC-USR-ID DELIMITED BY SPACE
257 ' has been added ...' DELIMITED BY SIZE
258 INTO WS-MESSAGE
259 PERFORM SEND-USRADD-SCREEN
260 WHEN DFHRESP(DUPKEY)
261 WHEN DFHRESP(DUPREC)
262 MOVE 'Y' TO WS-ERR-FLG
263 MOVE 'User ID already exist...' TO
264 WS-MESSAGE
265 MOVE -1 TO USERIDL OF COUSR1AI
266 PERFORM SEND-USRADD-SCREEN
267 WHEN OTHER
268 * DISPLAY 'RESP:' WS-RESP-CD 'REAS:' WS-REAS-CD
269 MOVE 'Y' TO WS-ERR-FLG
270 MOVE 'Unable to Add User...' TO
271 WS-MESSAGE
272 MOVE -1 TO FNAMEL OF COUSR1AI
273 PERFORM SEND-USRADD-SCREEN
274 END-EVALUATE.
275
276 *----------------------------------------------------------------*
277 * CLEAR-CURRENT-SCREEN
278 *----------------------------------------------------------------*
279 CLEAR-CURRENT-SCREEN.
280
281 PERFORM INITIALIZE-ALL-FIELDS.
282 PERFORM SEND-USRADD-SCREEN.
283
284 *----------------------------------------------------------------*
285 * INITIALIZE-ALL-FIELDS
286 *----------------------------------------------------------------*
287 INITIALIZE-ALL-FIELDS.
288
289 MOVE -1 TO FNAMEL OF COUSR1AI
290 MOVE SPACES TO USERIDI OF COUSR1AI
291 FNAMEI OF COUSR1AI
292 LNAMEI OF COUSR1AI
293 PASSWDI OF COUSR1AI
294 USRTYPEI OF COUSR1AI
295 WS-MESSAGE.
296
297 *
298 * Ver: CardDemo_v1.0-15-g27d6c6f-68 Date: 2022-07-19 23:12:34 CDT
299 *