Nonstop Database, HiRDB Version 9 UAP Development Guide
This section provides an example of an embedded SQL UAP written in COBOL. For details about the SQL syntax, see the HiRDB Version 9 SQL Reference manual.
Figures 7-11 through 7-13 show a PAD flowchart of example 4.
Figure 7-11 Flowchart of program example 4 (1/3)
Figure 7-12 Flowchart of program example 4 (2/3)
Figure 7-13 Flowchart of program example 4 (3/3)
00010*STOCK MANAGEMENT PROG. 00020* 00030* 00040* ALL RIGHTS RESERVED,COPYRIGHT (C)1997 HITACHI,LTD. 00050* LICENSED MATERIAL OF HITACHI,LTD. 00060* 00070 IDENTIFICATION DIVISION. 00080 PROGRAM-ID. ECOBUAP. 00090* 00100 ENVIRONMENT DIVISION. 00110 CONFIGURATION SECTION. 00120 SOURCE-COMPUTER. HITAC. 00130 OBJECT-COMPUTER. HITAC. 00140 INPUT-OUTPUT SECTION. 00150 FILE-CONTROL. 00160 SELECT INPUT-CARD-FILE 00170 ASSIGN TO DISK 00180 ORGANIZATION IS LINE SEQUENTIAL. 00190 SELECT PRINT-STOCK-FILE 00200 ASSIGN TO LP. 00210* 00220 DATA DIVISION. 00230 FILE SECTION. 00240 FD INPUT-CARD-FILE 00250 DATA RECORD USER-CARD-REC I-STOCK-REC. 00260* 00270 01 USER-CARD-REC. 00280 02 IUSERID PIC X(20). 00290 02 IPSWD PIC X(20). 00300 02 FILLER PIC X(40). 00310* 00320 01 I-STOCK-REC. 00330 02 ITYPE PIC X(1). 00340 02 FILLER PIC X(2). 00350 02 IPCODE PIC X(4). 00360 02 FILLER PIC X(2). 00370 02 IPNAME PIC N(8). 00380 02 ICOLOR PIC N(1). 00390 02 IPRICE PIC X(9). 00400 02 ISTOCK PIC X(9). 00410 02 IFLUX PIC X(1). 00420 02 FILLER PIC X(34). 00430* 00440 FD PRINT-STOCK-FILE RECORDING MODE IS F 00450 LABEL RECORD IS OMITTED 00460 DATA RECORD PRINT-STOCK-REC. 00470 01 PRINT-STOCK-REC PIC X(132). 00480* 00490 WORKING-STORAGE SECTION. 00500* 00510 EXEC SQL 1 00520 BEGIN DECLARE SECTION 1 00530 END-EXEC. 1 00540 77 XUSERID PIC X(30). 1 00550 77 XPSWD PIC X(30). 1 00560 77 XPCODE PIC X(4) VALUE '0000'. 1 00570 77 XPNAME PIC N(8). 1 00580 77 XCOLOR PIC N(1). 1 00590 77 XPRICE PIC S9(9) COMP. 1 00600 77 XSTOCK PIC S9(9) COMP. 1 00610* INDICATOR VARIABLE 1 00620 77 XIPCODE PIC S9(4) COMP VALUE 1040. 1 00630 77 XIPNAME PIC S9(4) COMP VALUE 1050. 1 00640 77 XICOLOR PIC S9(4) COMP VALUE 1060. 1 00650 77 XIPRICE PIC S9(4) COMP VALUE 1070. 1 00660 77 XISTOCK PIC S9(4) COMP VALUE 1080. 1 00670* 1 00680* 1 00690 EXEC SQL 1 00700 END DECLARE SECTION 1 00710 END-EXEC. 1 00720* 00730 01 HEADING-REC. 00740 02 FILLER PIC X(13) VALUE SPACE. 00750 02 FILLER PIC X(32) 00760 VALUE '****** STOCK TABLE LIST ******'. 00770 02 FILLER PIC X(87) VALUE SPACE. 00780* 00790 01 COLUMN-NAME-REC. 00800 02 FILLER PIC X(14) VALUE SPACE. 00810 02 FILLER PIC X(9) VALUE 'PCODE'. 00820 02 FILLER PIC X(16) VALUE 'PNAME'. 00830 02 FILLER PIC X(8) VALUE 'COLOR'. 00840 02 FILLER PIC X(8) VALUE 'PRICE'. 00850 02 FILLER PIC X(8) VALUE 'QUANTITY'. 00860 02 FILLER PIC X(69) VALUE SPACE. 00870* 00880 01 LINE-REC. 00890 02 FILLER PIC X(14) VALUE SPACE. 00900 02 FILLER PIC X(9) VALUE '----- '. 00910 02 FILLER PIC X(16) VALUE '-------- '. 00920 02 FILLER PIC X(8) VALUE '------- '. 00930 02 FILLER PIC X(8) VALUE '------- '. 00940 02 FILLER PIC X(8) VALUE '------- '. 00950 02 FILLER PIC X(69) VALUE SPACE. 00960* 00970 01 SELECT-OUT-REC. 00980 02 FILLER PIC X(14) VALUE SPACE. 00990 02 O-PCODE PIC X(5). 01000 02 FILLER PIC X(2) VALUE SPACE. 01010 02 O-KANJI CHARACTER TYPE KEIS. 01020 03 O-PNAME PIC N(8). 01030 03 FILLER PIC X(2) VALUE SPACE. 01040 03 O-COLOR PIC N(5). 01050 03 FILLER PIC X(6) VALUE SPACE. 01060 03 O-PRICE PIC X(8) JUST RIGHT. 01070 03 FILLER PIC X(2) VALUE SPACE. 01080 03 O-STOCK PIC X(8) JUST RIGHT. 01090 03 FILLER PIC X(69) VALUE SPACE. 01100 77 O-PCODE-NULL PIC X(5) VALUE '*****'. 01110 77 O-PNAME-NULL PIC N(10) VALUE NC'----------'. 01120 77 O-COLOR-NULL PIC N(5) VALUE NC'-----'. 01130 77 O-PRICE-NULL PIC X(8) VALUE '********'. 01140 77 O-STOCK-NULL PIC X(8) VALUE '********'. 01150* 01160 01 I-CARD-ERROR-REC. 01170 02 FILLER PIC X(14) VALUE SPACE. 01180 02 FILLER PIC X(41) 01190 VALUE '*** ERROR *** NO CARD FOR CONNECT ***'. 01200 02 FILLER PIC X(77) VALUE SPACE. 01210* 01220 01 CONNECT-ERROR-REC. 01230 02 FILLER PIC X(14) VALUE SPACE. 01240 02 FILLER PIC X(45) 01250 VALUE '*** ERROR *** CANNOT CONNECT *** CODE = '. 01260 02 CNCT-EC PIC X(5). 01270 02 FILLER PIC X(68) VALUE SPACE. 01280* 01290 01 NORMAL-END-REC. 01300 02 FILLER PIC X(14) VALUE SPACE. 01310 02 FILLER PIC X(22) 01320 VALUE '*** NORMAL ENDED ***'. 01330 02 FILLER PIC X(96) VALUE SPACE. 01340* 01350 01 SQLERR-PRINT-REC. 01360 02 FILLER PIC X(14) VALUE SPACE. 01370 02 FILLER PIC X(34) 01380 VALUE '*** HiRDB SQL ERROR MESSAGE-ID = '. 01390 02 RC-MSGID PIC X(8). 01400 02 FILLER PIC X(14) VALUE ' SQLERRORMC ='. 01500 02 RC-SQLERRMC PIC X(62). 01510* 01520 01 WSQLCODE PIC -(10)9. 01530* 01540 01 WMSGID. 01550 02 FILLER PIC X(8). 01560 02 MSGID PIC X(3). 01570* 01580 01 ERRORMSGID. 01590 02 FILLER PIC X(5) VALUE 'KFPA1'. 01600 02 E-MSGID PIC X(4). 01610 02 FILLER PIC X(2) VALUE '-E'. 01620* 01630 01 EOF PIC X(1) VALUE '0'. 01640 01 ERR-FLG PIC X(1) VALUE '0'. 01650* 01660* 01670 PROCEDURE DIVISION. 01680 MAIN SECTION. 01690 M-1. 01700 OPEN INPUT INPUT-CARD-FILE 01710 OUTPUT PRINT-STOCK-FILE. 01720 READ INPUT-CARD-FILE 01730 AT END 01740 MOVE '1' TO ERR-FLG 01750 GO TO M-3 01760 END-READ. 01770 MOVE IUSERID TO XUSERID. 01780 MOVE IPSWD TO XPSWD. 01790* 01800 EXEC SQL (a) 2 01810 WHENEVER SQLERROR (a) 2 01820 GO TO M-2 (a) 2 01830 END-EXEC. (a) 2 01840 EXEC SQL (b) 2 01850 CONNECT USER :XUSERID USING :XPSWD (b) 2 01860 END-EXEC. (b) 2 01870 PERFORM CHANGE. 01880 GO TO M-3. 01890 M-2. 01900 MOVE '2' TO ERR-FLG. 01910* 01920 M-3. 01930 EVALUATE ERR-FLG 01940 WHEN '0' 01950 PERFORM NORMAL 01960 WHEN '1' 01970 WRITE PRINT-STOCK-REC 01980 FROM I-CARD-ERROR-REC 01990 AFTER ADVANCING 2 LINES 02000 WHEN '2' 02010 MOVE SQLCODE TO CNCT-EC 02020 WRITE PRINT-STOCK-REC 02030 FROM CONNECT-ERROR-REC 02040 AFTER ADVANCING 2 LINES 02050 WHEN '3' 02060 PERFORM ERROR 02070 END-EVALUATE. 02080 M-4. 02090 CLOSE INPUT-CARD-FILE 02100 PRINT-STOCK-FILE. 02110 M-EX. 02120 EXEC SQL 02130 WHENEVER SQLERROR CONTINUE 02140 END-EXEC. 02150 EXEC SQL 02160 WHENEVER NOT FOUND CONTINUE 02170 END-EXEC 02180 EXEC SQL 02190 WHENEVER SQLWARNING CONTINUE 02200 END-EXEC. 02210 EXEC SQL 02220 DISCONNECT 02230 END-EXEC. 02240 GOBACK. 02250 CHANGE SECTION. 02260 H-1. 02270 READ INPUT-CARD-FILE 02280 AT END 02290 MOVE '1' TO ERR-FLG 02300 END-READ. 02310 EXEC SQL 02320 WHENEVER SQLERROR 02330 GO TO H-2 02340 END-EXEC. 02350 PERFORM UNTIL EOF = '1' OR ERR-FLG NOT = '0' 02360 EVALUATE ITYPE 02370 WHEN 'I' 02380 PERFORM ADDITION 02390 WHEN 'U' 02400 PERFORM UPDATE 02410 WHEN 'D' 02420 PERFORM DELETION 02430 END-EVALUATE 02440 READ INPUT-CARD-FILE 02450 AT END 02460 MOVE '1' TO EOF 02470 END-READ 02480 END-PERFORM. 02490 GO TO H-EX. 02500 H-2. 02510 MOVE '3' TO ERR-FLG. 02520 H-EX. 02530 EXIT. 02540* 02550 ADDITION SECTION. 02560 T-1. 02570 MOVE IPCODE TO XPCODE. 02580 MOVE IPNAME TO XPNAME. 02590 MOVE ICOLOR TO XCOLOR. 02600 MOVE IPRICE TO XPRICE. 02610 MOVE ISTOCK TO XSTOCK. 02620 EXEC SQL 02610 WHENEVER SQLERROR GO TO T-2 02620 END-EXEC. 02630 EXEC SQL 3 02640 INSERT INTO STOCK(PCODE, PNAME, COLOR, PRICE, SQUANTITY) 3 02650 VALUES(:XPCODE, :XPNAME, :XCOLOR, :XPRICE, :XSTOCK) 3 02660 END-EXEC. 3 02670 GO TO T-EX. 02680 T-2. 02690 MOVE '3' TO ERR-FLG. 02700 T-EX. 02710 EXIT. 02720 UPDATE SECTION. 02730 K-1. 02740 MOVE IPCODE TO XPCODE. 02750 MOVE ISTOCK TO XSTOCK. 02760 EXEC SQL 02770 WHENEVER SQLERROR GO TO K-2 02780 END-EXEC. 02790 EVALUATE IFLUX 02800 WHEN '1' 4 02810 EXEC SQL (a) 4 02820 UPDATE STOCK SET SQUANTITY = SQUANTITY + :XSTOCK (a) 4 02830 WHERE PCODE=:XPCODE (a) 4 02840 END-EXEC (a) 4 02850 WHEN '2' 4 02860 EXEC SQL (b) 4 02870 UPDATE STOCK SET SQUANTITY = SQUANTITY - :XSTOCK (b) 4 02880 WHERE PCODE=:XPCODE (b) 4 02890 END-EXEC (b) 4 02900 END-EVALUATE. 02910 GO TO K-EX. 02920 K-2. 02930 MOVE '3' TO ERR-FLG. 02940 K-EX. 02950 EXIT. 02960* 02970 DELETION SECTION. 02980 S-1. 02990 MOVE IPCODE TO XPCODE. 03010 EXEC SQL 03020 WHENEVER SQLERROR GO TO S-2 03030 END-EXEC. 03040 EXEC SQL 5 03050 DELETE FROM STOCK 5 03060 WHERE PCODE=:XPCODE 5 03070 END-EXEC. 5 03080 GO TO S-EX. 03090 S-2. 03100 MOVE '3' TO ERR-FLG. 03110 S-EX. 03120 EXIT. 03130* 03140 NORMAL SECTION. 03150 F-0. 03160 WRITE PRINT-STOCK-REC 03170 FROM HEADING-REC 03180 AFTER ADVANCING 4 LINES. 03190 WRITE PRINT-STOCK-REC 03200 FROM COLUMN-NAME-REC 03210 AFTER ADVANCING 2 LINES. 03220 WRITE PRINT-STOCK-REC 03230 FROM LINE-REC 03240 AFTER ADVANCING 2 LINES. 03250 F-1. 03260 EXEC SQL 03270 WHENEVER SQLERROR GO TO F-4 03280 END-EXEC. 03290 EXEC SQL (a) 6 03300 DECLARE CR1 CURSOR FOR (a) 6 03310 SELECT PCODE,PNAME,COLOR,PRICE,SQUANTITY FROM STOCK (a) 6 03320 END-EXEC. (a) 6 03330 EXEC SQL (b) 6 03340 OPEN CR1 (b) 6 03350 END-EXEC. (b) 6 03360 F-2. 03370 EXEC SQL (a) 7 03380 WHENEVER NOT FOUND (a) 7 03390 GO TO F-3 (a) 7 03400 END-EXEC. (a) 7 03410 EXEC SQL (b) 7 03420 FETCH CR1 (b) 7 03430 INTO :XPCODE:XIPCODE, :XPNAME:XIPNAME, (b) 7 03440 :XCOLOR:XICOLOR, :XPRICE:XIPRICE, :XSTOCK:XISTOCK (b) 7 03450 END-EXEC. (b) 7 03460 EXEC SQL 03470 WHENEVER NOT FOUND 03480 CONTINUE 03490 END-EXEC. 03500 IF XIPCODE IS >= 0 THEN 03510 MOVE XPCODE TO O-PCODE 03520 ELSE 03530 MOVE O-PCODE-NULL TO O-PCODE 03540 END-IF. 03550 IF XIPNAME IS >= 0 THEN 03560 MOVE XPNAME TO O-PNAME 03570 ELSE 03580 MOVE O-PNAME-NULL TO O-PNAME 03590 END-IF. 03600 IF XICOLOR IS >= 0 THEN 03610 MOVE XCOLOR TO O-COLOR 03620 ELSE 03630 MOVE O-COLOR-NULL TO O-COLOR 03640 END-IF. 03650 IF XIPRICE IS >= 0 THEN 03660 MOVE XPRICE TO O-PRICE 03670 ELSE 03680 MOVE O-PRICE-NULL TO O-PRICE 03690 END-IF. 03700 IF XISTOCK IS >= 0 THEN 03710 MOVE XSTOCK TO O-STOCK 03720 ELSE 03730 MOVE O-STOCK-NULL TO O-STOCK 03740 END-IF. 03750 WRITE PRINT-STOCK-REC 03760 FROM SELECT-OUT-REC 03770 AFTER ADVANCING 2 LINES. 03780 GO TO F-2. 03790 F-3. 03800 EXEC SQL 03810 WHENEVER SQLERROR CONTINUE 03820 END-EXEC. 03830 EXEC SQL 03840 WHENEVER NOT FOUND CONTINUE 03850 END-EXEC 03860 EXEC SQL 03870 WHENEVER SQLWARNING CONTINUE 03880 END-EXEC. 03890 EXEC SQL (a) 8 03900 CLOSE CR1 (a) 8 03910 END-EXEC. (a) 8 03920* 03930 EXEC SQL (b) 8 03940 COMMIT (b) 8 03950 END-EXEC. (b) 8 03960* 03970 WRITE PRINT-STOCK-REC 03980 FROM NORMAL-END-REC 03990 AFTER ADVANCING 2 LINES. 04000 GO TO F-EX. 04010 F-4. 04020 PERFORM ERROR. 04030 F-EX. 04040 EXIT. 04050 ERROR SECTION. 04060 I-1. 04070 MOVE SQLCODE TO WSQLCODE. 04080 MOVE WSQLCODE TO WMSGID. 04090 MOVE MSGID TO E-MSGID. 04100 MOVE ERRORMSGID TO RC-MSGID. 04110 MOVE SQLERRMC TO RC-SQLERRMC. 04120 WRITE PRINT-STOCK-REC 04130 FROM SQLERR-PRINT-REC 04140 AFTER ADVANCING 2 LINES. 04150 EXEC SQL (a) 9 04160 WHENEVER SQLERROR CONTINUE (a) 9 04170 END-EXEC. (a) 9 04180 EXEC SQL (a) 9 04190 WHENEVER NOT FOUND CONTINUE (a) 9 04200 END-EXEC. (a) 9 04210 EXEC SQL (a) 9 04220 WHENEVER SQLWARNING CONTINUE (a) 9 04230 END-EXEC. (a) 9 04240 EXEC SQL (b) 9 04250 ROLLBACK (b) 9 04260 END-EXEC. (b) 9 04270 I-EX. 04280 EXIT.
Figures 7-14 through 7-17 show the PAD chart for program example 5.
Figure 7-14 PAD chart for program example 5 (1/4)
Figure 7-15 PAD chart for program example 5 (2/4)
Figure 7-16 PAD chart for program example 5 (3/4)
Figure 7-17 PAD chart for program example 5 (4/4)
00010 ********************************************** 00020 * * 00030 * EMBEDDED TYPE SQL COBOL UAP * 00040 * ROW INTERFACE SAMPLE * 00050 * 1997/11/27 * 00060 ********************************************** 00070 IDENTIFICATION DIVISION. 00080 PROGRAM-ID. ROW-SAMPLE. 00090 AUTHOR. CLIENT. 00100 DATA-WRITTEN. 1997/11/27. 00110 DATA-COMPILED. ROW-SAMPLE. 00120 REMARKS. 00130 * 00140 ENVIRONMENT DIVISION. 00150 CONFIGURATION SECTION. 00160 SOURCE-COMPUTER. HITAC. 00170 OBJECT-COMPUTER. HITAC. 00180 INPUT-OUTPUT SECTION. 00190 FILE-CONTROL. 00200 SELECT OUTLIST ASSIGN TO LP. 00210 * 00220 DATA DIVISION. 00230 FILE SECTION. 00240 FD OUTLIST RECORDING MODE IS F 00250 LABEL RECORD IS OMITTED 00260 DATA RECORD OUTREC. 00270 01 OUTREC PIC X(80). 00280 * 00290 WORKING STORAGE SECTION. 00300 EXEC SQL 00310 BEGIN DECLARE SECTION 00320 END-EXEC. 00330 01 IN-REC1 IS GLOBAL. 00340 02 IN-CHR1 PIC X(15) VALUE 'EVA-00'. 00350 02 IN-INT1 PIC S9(9) COMP VALUE 255. 00360 02 IN-INT2 PIC S9(9) COMP VALUE 1. 00370 00380 01 XSQLROW IS GLOBAL1 00390 02 ROW-CHR1 PIC X(30). 1 00400 02 ROW-INT1 PIC S9(9) COMP. 1 00410 02 ROW-INT2 PIC S9(9) COMP. 1 00420 00430 EXEC SQL 00440 END DECLARE SECTION 00450 END-EXEC. 00460 00470 01 DISP-REC IS GLOBAL. 00480 02 DISP-CHR1 PIC X(15). 00490 02 DISP-INT1 PIC S9(9). 00500 02 DISP-INT2 PIC S9(4). 00510 01 ERRFLG PIC S9(4) COMP IS GLOBAL. 00520 00530 01 MSG-ERR PIC X(10) VALUE '!! ERROR'. 00540 01 MSG-CODE IS GLOBAL. 00550 02 FILLER PIC X(15) VALUE '!! SQLCODE =' 00560 02 MSG-SQLCODE PIC S9(9) DISPLAY. 00570 01 MSG-MC IS GLOBAL. 00580 02 FILLER PIC X(15) VALUE '!! SQLERRMC =' 00590 02 MSG-SQLERRMC PIC X(100). 00600 00610 PROCEDURE DIVISION. 00620 ********************************************** 00630 * DISPLAY TITLE 00640 ********************************************** 00650 MAIN SECTION 00660 CALL 'DISPLAY-TITLE'. 00670 MOVE ZERO TO ERRFLG. 00680 00690 ********************************************** 00700 * CONNECT 00710 ********************************************** 00720 EXEC SQL 00730 WHENEVER SQLERROR GOTO ERR-EXIT 00740 END-EXEC 00750 00760 DISPLAY '***** CONNECT '. 00770 EXEC SQL 2 00780 CONNECT 2 00790 END-EXEC. 2 00800 DISPLAY '***** CONNECT : END'. 00810 00820 ********************************************** 00830 * INIT 00840 ********************************************** 00850 DISPLAY '## TABLE WILL BE INITIALIZED'. 00860 CALL 'INIT-TABLE'. 00870 IF ERRFLG < ZERO 00880 GO TO ERR-EXIT 00890 END-IF 00900 DISPLAY '## IS NORMAL'. 00910 00920 ********************************************** 00930 * INSERT 00940 ********************************************** 00950 DISPLAY 'INSERT ## DATA'. 00960 CALL 'TEST-INSERT'. 00970 IF ERRFLG < ZERO 00980 GO TO ERR-EXIT 00990 END-IF 01000 DISPLAY '## IS NORMAL'. 01010 01020 ********************************************** 01030 * ROW 01040 ********************************************** 01050 DISPLAY '## ROW TYPE TEST WILL BE EXECUTED'. 01060 CALL 'TEST-ROW'. 01070 IF ERRFLG < ZERO 01080 GO TO ERR-EXIT 01090 END-IF 01100 DISPLAY '## IS NORMAL'. 01110 01120 ********************************************** 01130 * DISCONNECT 01140 ********************************************** 01150 ERR-EXIT. 01160 IF SQLCODE < ZERO 01170 MOVE SQLCODE TO MSG-SQLCODE 01180 MOVE SQLERRMC TO MSG-SQLERRMC 01190 DISPLAY MSG-ERR 01200 DISPLAY MSG-CODE 01210 DISPLAY MSG-MC 01220 MOVE -1 TO ERRFLG 01230 END-IF 01240 01250 EXEC SQL 01260 WHENEVER SQLERROR CONTINUE 01270 END-EXEC 01280 EXEC SQL 01290 WHENEVER NOT FOUND CONTINUE 01300 END-EXEC 01310 EXEC SQL 01320 WHENEVER SQLWARNING CONTINUE 01330 END-EXEC 01340 01350 DISPLAY '##DISCONNECT' 01360 01370 EXEC SQL 3 01380 DISCONNECT 3 01390 END-EXEC 3 01400 STOP RUN. 01410 01420 ********************************************** 01430 * INSERT STATEMENT TEST 01440 ********************************************** 01450 IDENTIFICATION DIVISION. 01460 PROGRAM-ID. TEST-INSERT. 01470 DATA DIVISION. 01480 WORKING-STORAGE SECTION. 01490 01 DCNT PIC S9(9) COMP. 01500 PROCEDURE DIVISION. 01510 EXEC SQL 01520 WHENEVER SQLERROR GOTO :Exit-Test-Insert 01530 END-EXEC. 01540 ********************************************** 01550 * INSERT HOST 01560 ********************************************** 01570 DISPLAY 'INSERT start WITH ***** EMBEDDED VARIABLE' 01580 MOVE ZERO TO DCNT. 01590 INSERT-LOOP. 01600 COMPUTE IN-INT1 = DCNT 01610 COMPUTE IN-INT2 = DCNT + 100 01620 COMPUTE DCNT = DCNT + 1 01630 EXEC SQL 4 01640 INSERT INTO TT1(CLM1, 4 01650 CLM2, 4 01660 CLM3) 4 01670 VALUES (:IN-CHR1, 4 01680 :IN-INT1, 4 01690 :IN-INT2) 4 01700 END-EXEC 4 01710 IF DCNT <20 THEN 01720 GO TO INSERT-LOOP 01730 END-IF 01740 DISPLAY '***** insert : SUCCESS'. 01750 ********************************************** 01760 * 01770 ********************************************** 01780 EXIT-TEST-INSERT. 01790 IF SQLCODE < ZERO 01800 MOVE SQLCODE TO MSG-SQLCODE 01810 MOVE SQLERRMC TO MSG-SQLERRMC 01820 DISPLAY MSG-CODE 01830 DISPLAY MSG-MC 01840 MOVE -1 TO ERRFLG 01850 END-IF 01860 DISPLAY '>> TEST-INSERT<<' 01870 GOBACK. 01880 ********************************************** 01890 * WARNING 01900 ********************************************** 01910 INSERT-WARNING. 01920 DISPLAY 'WARNING' 01930 MOVE SQLCODE TO MSG-SQLCODE 01940 MOVE SQLERRMC TO MSG-SQLERRMC 01950 DISPLAY MSG-CODE 01960 DISPLAY MSG-MC, 01970 END PROGRAM TEST-INSERT. 01980 01990 ********************************************** 02000 * TEST ROW 02010 ********************************************** 02020 IDENTIFICATION DIVISION. 02030 PROGRAM-ID. TEST-ROW. 02040 DATA DIVISION. 02050 WORKING-STORAGE SECTION. 02060 PROCEDURE DIVISION. 02070 DISPLAY '***** ROW CURSOR OPEN' 02080 EXEC SQL 5 02090 DECLARE CUR_ROW CURSOR FOR 5 02100 SELECT ROW FROM TT15 02110 WHERE CLM2 = 10 5 02120 FOR UPDATE OF CLM35 02130 END-EXEC 5 02140 ********************************************** 02150 * ROW CURSOR 02160 ********************************************** 02170 DISPLAY '***** ROW CURSOR OPEN'. 02180 EXEC SQL 02190 WHENEVER SQLERROR GOTO :Exit-Test-Row 02200 END-EXEC 02210 EXEC SQL 6 02220 OPEN CUR_ROW 6 02230 END-EXEC 6 02240 02250 ********************************************** 02260 * FETCH ROW CURSOR 02270 ********************************************** 02280 DISPLAY '***** ROW CURSOR FETCH' 02290 EXEC SQL 02300 WHENEVER NOT FOUND GOTO :Exit-Test-ROW 02310 END-EXEC 02320 EXEC SQL 02330 WHENEVER SQLERROR GOTO :Exit-Test-ROW 02340 END-EXEC 02350 MOVE SPACE TO XSQLROW 02360 EXEC SQL 7 02370 FETCH CUR_ROW INTO :XSQLROW 7 02380 END-EXEC 7 02390 DISPLAY '## FETCH DATA' 02400 MOVE ROW-CHR1 TO DISP-CHR1 02410 MOVE ROW-INT1 TO DISP-INT1 02420 MOVE ROW-INT2 TO DISP-INT2 02430 DISPLAY DISP-REC 02440 02450 DISPLAY '***** ROW UPDATE' 02460 MOVE 'ANGEL' TO ROW-CHR1 02470 EXEC SQL 8 02480 UPDATE TT1 SET ROW = :XSQLROW 8 02490 WHERE CURRENT OF CUR_ROW 8 02500 END-EXEC 8 02510 02520 ********************************************** 02530 * FETCH ROW CURSOR 02540 ********************************************** 02550 DISPLAY '***** ROW CURSOR CLOSE' 02560 EXEC SQL 02570 WHENEVER NOT FOUND CONTINUE 02580 END-EXEC 02590 EXEC SQL 02600 WHENEVER SQLERROR CONTINUE 02610 END-EXEC 02620 EXEC SQL 9 02630 CLOSE CUR_ROW 9 02640 END-EXEC. 9 02650 ********************************************** 02660 * 02670 ********************************************** 02680 EXIT-TEST-ROW. 02690 IF SQLCODE < ZERO THEN 02700 MOVE SQLCODE TO MSG-SQLCODE 02710 MOVE SQLERRMC TO MSG-SQLERRMC 02720 DISPLAY MSG-CODE 02730 DISPLAY MSG-MC 02740 MOVE -1 TO ERRFLG 02750 END-IF 02760 EXEC SQL 02770 WHENEVER NOT FOUND CONTINUE 02780 END-EXEC 02790 EXEC SQL 02800 WHENEVER SQLERROR CONTINUE 02810 END-EXEC 02820 EXEC SQL 02830 COMMIT 02840 END-EXEC 02850 DISPLAY '>> TEST-ROW END <<' 02860 GOBACK. 02870 02880 ********************************************** 02890 * WARNING 02900 ********************************************** 02910 ROW-WARNING. 02920 DISPLAY 'WARNING' 02930 MOVE SQLCODE TO MSG-SQLCODE 02940 MOVE SQLERRMC TO MSG-SQLERRMC 02950 DISPLAY MSG-CODE 02960 DISPLAY MSG-MC. 02970 END PROGRAM TEST-ROW. 02980 02990 03000 ************************************************ 03010 * INITIALIZE TABLE 03020 ************************************************ 03030 IDENTIFICATION DIVISION. 03040 PROGRAM-ID. INIT-TABLE. 03050 DATA DIVISION. 03060 WORKING-STORAGE SECTION. 03070 PROCEDURE DIVISION. 03080 EXEC SQL 03090 WHENEVER SQLERROR CONTINUE 03100 END-EXEC 03110 03120 ************************************************ 03130 * DROP TABLE 03140 ************************************************ 03150 DISPLAY '***** DROP TABLE'. 03160 EXEC SQL 10 03170 DROP TABLE TT1 10 03180 END-EXEC 10 03190 DISPLAY '***** CREATE SCHEMA'. 03200 EXEC SQL 11 03210 CREATE SCHEMA 11 03220 END-EXEC 11 03230 03240 ************************************************ 03250 * COMMIT 03260 ************************************************ 03270 DISPLAY '***** COMMIT START'. 03280 EXEC SQL 03290 WHENEVER SQLERROR GOTO EXIT-INIT-TABLE 03300 END-EXEC 03310 EXEC SQL 03320 COMMIT 03330 END-EXEC 03340 DISPLAY '***** COMMIT : END '. 03350 03360 ************************************************ 03370 * CREATE TABLE 03380 ************************************************ 03390 DISPLAY '***** create table'. 03400 EXEC SQL 12 03410 CREATE FIX TABLE TT1(CLM1 CHAR(30), 12 03420 CLM2 INTEGER, 12 03430 CLM3 INTEGER) 12 03440 END-EXEC 12 03450 03460 DISPLAY '***** create table : SUCCESS'. 03470 03480 ************************************************ 03490 * 03500 ************************************************ 03510 EXIT-INIT-TABLE. 03520 IF SQLCODE < ZERO THEN 03530 MOVE SQLCODE TO MSG-SQLCODE 03540 MOVE SQLERRMC TO MSG-SQLERRMC 03550 DISPLAY MSG-CODE 03560 DISPLAY MSG-MC 03570 MOVE -1 TO ERRFLG 03580 END-IF 03590 GOBACK. 03600 03610 ************************************************ 03620 * WARNING 03630 ************************************************ 03640 INIT-TABLE-WARNING. 03650 DISPLAY 'WARNING' 03660 MOVE SQLCODE TO MSG-SQLCODE 03670 MOVE SQLERRMC TO MSG-SQLERRMC 03680 DISPLAY MSG-CODE 03690 DISPLAY MSG-MC. 03700 END PROGRAM INIT-TABLE. 03710 03720 ************************************************ 03730 * DISPLAY 03740 ************************************************ 03750 IDENTIFICATION DIVISION. 03760 PROGRAM-ID. DISPLAY-TITLE. 03770 DATA DIVISION. 03780 WORKING-STORAGE SECTION. 03790 PROCEDURE DIVISION. 03800 DISPLAY '###################################' 03810 DISPLAY '# #' 03820 DISPLAY '# THIS PROGRAM IS A SAMPLE #' 03830 DISPLAY '# PROGRAM FOR THE ROW-TYPE #' 03840 DISPLAY '# INTERFACE #' 03850 DISPLAY '###################################' 03860 END PROGRAM DISPLAY-TITLE. 03870 END PROGRAM ROW-SAMPLE.
A coding example that uses the TYPE, TYPEDEF, and SAME AS clauses follows:
000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. CBL001. 000300 DATA DIVISION. 000400 WORKING-STORAGE SECTION. 000500 EXEC SQL BEGIN DECLARE SECTION END-EXEC. 000600* -- type declaration -- 000700 01 VCHR20 TYPEDEF. 000800 05 LEN PIC S9(4) COMP. 000900 05 STR PIC X(20). 001000 001100* -- data declaration -- 001200 01 D-4C. 001300 05 XCUT TYPE VCHR20. 001400 05 XCOLOR PIC X(10). 001500 05 XCLARITY SAME AS XCOLOR. 001600 05 XCARAT PIC S9(4) COMP. 001700 001800 EXEC SQL END DECLARE SECTION END-EXEC. : : : : 002000 PROCEDURE DIVISION. 002100 CB_001 SECTION. : : : : 003400 INS-1. 003500 EXEC SQL 003600 INSERT INTO A_DIM (C1, C2, C3, C4) 003700 VALUES (:XCUT, :XCOLOR, :XCLARITY, :XCARAT) 003800 END-EXEC. : : : : 005000 INS-EX. 005100 EXIT. 005200 END PROGRAM CBL001.
All Rights Reserved. Copyright (C) 2011, Hitachi, Ltd.