7.3.2　プログラム例題

(a)　PADチャート

プログラム例題4のPADチャートを次の図に示します。

図7‒12　プログラム例題4のPADチャート（1/3）

図7‒13　プログラム例題4のPADチャート（2/3）

図7‒14　プログラム例題4のPADチャート（3/3）

(b)　コーディング例

プログラム例題4のコーディング例を次に示します。

000010*ZAIKO KANRI PROG.
000020*
000030*
000040* ALL RIGHTS RESERVED,COPYRIGHT (C)1997 HITACHI,LTD.
000050* LICENSED MATERIAL OF HITACHI,LTD.
000060*
000070 IDENTIFICATION DIVISION.
000080 PROGRAM-ID. ECOBUAP.
000090*
000100 ENVIRONMENT DIVISION.
000110 CONFIGURATION SECTION.
000120 SOURCE-COMPUTER. HITAC.
000130 OBJECT-COMPUTER. HITAC.
000140 INPUT-OUTPUT SECTION.
000150 FILE-CONTROL.
000160     SELECT INPUT-CARD-FILE
000170       ASSIGN TO  DISK
000180       ORGANIZATION IS LINE SEQUENTIAL.
000190     SELECT PRINT-ZAIKO-FILE
000200       ASSIGN TO  LP.
000210*
000220 DATA DIVISION.
000230 FILE SECTION.
000240 FD  INPUT-CARD-FILE
000250                    DATA RECORD USER-CARD-REC I-ZAIKO-REC.
000260*
000270 01  USER-CARD-REC.
000280     02 IUSERID          PIC X(20).
000290     02 IPSWD            PIC X(20).
000300     02 FILLER           PIC X(40).
000310*
000320 01  I-ZAIKO-REC.
000330     02 IKUBUN           PIC X(1).
000340     02 FILLER           PIC X(2).
000350     02 ISCODE           PIC X(4).
000360     02 FILLER           PIC X(2).
000370     02 ISNAME           PIC N(8).
000380     02 ICOL             PIC N(1).
000390     02 ITANKA           PIC X(9).
000400     02 IGRYO            PIC X(9).
000410     02 IIOKBN           PIC X(1).
000420     02 FILLER           PIC X(34).
000430*
000440 FD  PRINT-ZAIKO-FILE RECORDING MODE IS F
000450                      LABEL RECORD IS OMITTED
000460                      DATA RECORD PRINT-ZAIKO-REC.
000470 01  PRINT-ZAIKO-REC      PIC X(132).
000480*
000490 WORKING-STORAGE SECTION.
000500*
000510     EXEC SQL                                            1
000520           BEGIN DECLARE SECTION                         1
000530     END-EXEC.                                           1
000540 77  XUSERID            PIC X(30).                       1
000550 77  XPSWD              PIC X(30).                       1
000560 77  XSCODE             PIC X(4)  VALUE '0000'.          1
000570 77  XSNAME             PIC N(8).                        1
000580 77  XCOL               PIC N(1).                        1
000590 77  XTANKA             PIC S9(9) COMP.                  1
000600 77  XGRYO              PIC S9(9) COMP.                  1
000610* INDICATOR VARIABLE                                     1
000620 77  XISCODE            PIC S9(4) COMP  VALUE 1040.      1
000630 77  XISNAME            PIC S9(4) COMP  VALUE 1050.      1
000640 77  XICOL              PIC S9(4) COMP  VALUE 1060.      1
000650 77  XITANKA            PIC S9(4) COMP  VALUE 1070.      1
000660 77  XIGRYO             PIC S9(4) COMP  VALUE 1080.      1
000670*                                                        1
000680*                                                        1
000690     EXEC SQL                                            1
000700           END DECLARE SECTION                           1
000710     END-EXEC.                                           1
000720*
000730 01  MIDASHI-REC.
000740     02 FILLER          PIC X(13) VALUE SPACE.
000750     02 FILLER          PIC X(32)
000760           VALUE '******  ZAIKO TABLE LIST  ******'.
000770     02 FILLER          PIC X(87) VALUE SPACE.
000780*
000790 01  RETSUMEI-REC.
000800     02 FILLER          PIC X(14) VALUE SPACE.
000810     02 FILLER          PIC X(9)  VALUE 'SCODE'.
000820     02 FILLER          PIC X(16) VALUE 'SNAME'.
000830     02 FILLER          PIC X(8)  VALUE 'COLOR'.
000840     02 FILLER          PIC X(8)  VALUE 'TANKA'.
000850     02 FILLER          PIC X(8)  VALUE 'SURYO'.
000860     02 FILLER          PIC X(69) VALUE SPACE.
000870*
000880 01  LINE-REC.
000890     02 FILLER          PIC X(14) VALUE SPACE.
000900     02 FILLER          PIC X(9)  VALUE '-----  '.
000910     02 FILLER          PIC X(16) VALUE '--------  '.
000920     02 FILLER          PIC X(8)  VALUE '------- '.
000930     02 FILLER          PIC X(8)  VALUE '------- '.
000940     02 FILLER          PIC X(8)  VALUE '------- '.
000950     02 FILLER          PIC X(69) VALUE SPACE.
000960*
000970 01  SELECT-OUT-REC.
000980     02 FILLER          PIC X(14) VALUE SPACE.
000990     02 O-SCODE         PIC X(5).
001000     02 FILLER          PIC X(2)  VALUE SPACE.
001010     02 O-KANJI         CHARACTER TYPE KEIS.
001020        03 O-SNAME         PIC N(8).
001030        03 FILLER          PIC X(2)  VALUE SPACE.
001040        03 O-COL           PIC N(1).
001050        03 FILLER          PIC X(6)  VALUE SPACE.
001060        03 O-TANKA         PIC X(8)  JUST RIGHT.
001070        03 FILLER          PIC X(2)  VALUE SPACE.
001080        03 O-GRYO          PIC X(8)  JUST RIGHT.
001090        03 FILLER          PIC X(69) VALUE SPACE.
001100 77  O-SCODE-NULL       PIC X(5) VALUE '*****'.
001110 77  O-SNAME-NULL       PIC N(8) VALUE NC'−−−−−−'.
001120 77  O-COL-NULL         PIC N(1) VALUE NC'−'.
001130 77  O-TANKA-NULL       PIC X(8) VALUE '********'.
001140 77  O-GRYO-NULL        PIC X(8) VALUE '********'.
001150*
001160 01  I-CARD-ERROR-REC.
001170     02 FILLER          PIC X(14) VALUE SPACE.
001180     02 FILLER          PIC X(41)
001190           VALUE '***  ERROR  ***  NO CARD FOR CONNECT  ***'.
001200     02 FILLER          PIC X(77) VALUE SPACE.
001210*
001220 01  CONNECT-ERROR-REC.
001230     02 FILLER          PIC X(14) VALUE SPACE.
001240     02 FILLER          PIC X(45)
001250           VALUE '***  ERROR  ***  CANNOT CONNECT  ***  CODE = '.
001260     02 CNCT-EC         PIC X(5).
001270     02 FILLER          PIC X(68) VALUE SPACE.
001280*
001290 01  NORMAL-END-REC.  
001300     02 FILLER          PIC X(14) VALUE SPACE.
001310     02 FILLER          PIC X(22)
001320           VALUE '***  NORMAL ENDED  ***'.
001330     02 FILLER          PIC X(96) VALUE SPACE.
001340*
001350 01  SQLERR-PRINT-REC.
001360     02 FILLER          PIC X(14) VALUE SPACE.
001370     02 FILLER          PIC X(34)
001380           VALUE '***  HiRDB SQL ERROR MESSAGE-ID = '.
001390     02 RC-MSGID        PIC X(8).
001400     02 FILLER          PIC X(14) VALUE ' SQLERRORMC ='.
001500     02 RC-SQLERRMC     PIC X(62).
001510*
001520 01  WSQLCODE           PIC -(10)9.
001530*
001540 01  WMSGID.
001550     02 FILLER          PIC X(8).
001560     02 MSGID           PIC X(3).
001570*
001580 01  ERRORMSGID.
001590     02 FILLER          PIC X(5) VALUE 'KFPA1'.
001600     02 E-MSGID         PIC X(4).
001610     02 FILLER          PIC X(2) VALUE '-E'.
001620*
001630 01  EOF                PIC X(1) VALUE '0'.
001640 01  ERR-FLG            PIC X(1) VALUE '0'.
001650*
001660*
001670 PROCEDURE DIVISION.
001680 MAIN SECTION.
001690 M-1.
001700     OPEN INPUT  INPUT-CARD-FILE
001710             OUTPUT PRINT-ZAIKO-FILE.
001720     READ INPUT-CARD-FILE
001730           AT END
001740             MOVE '1' TO ERR-FLG
001750             GO TO M-3
001760     END-READ.
001770     MOVE IUSERID TO XUSERID.
001780     MOVE IPSWD TO XPSWD.
001790*
001800     EXEC SQL                                           (a) 2
001810           WHENEVER SQLERROR                            (a) 2
001820              GO TO M-2                                 (a) 2
001830     END-EXEC.                                          (a) 2
001840     EXEC SQL                                           (b) 2
001850           CONNECT USER :XUSERID USING :XPSWD           (b) 2
001860     END-EXEC.                                          (b) 2
001870     PERFORM HENKOU.
001880     GO TO M-3.
001890 M-2.
001900     MOVE '2' TO ERR-FLG.
001910*
001920 M-3.
001930     EVALUATE ERR-FLG
001940       WHEN '0'
001950         PERFORM FUTSUU
001960       WHEN '1'
001970         WRITE PRINT-ZAIKO-REC
001980           FROM I-CARD-ERROR-REC
001990           AFTER ADVANCING 2 LINES
002000       WHEN '2'
002010         MOVE SQLCODE  TO CNCT-EC
002020         WRITE PRINT-ZAIKO-REC
002030           FROM CONNECT-ERROR-REC
002040           AFTER ADVANCING 2 LINES
002050       WHEN '3'
002060         PERFORM IJYOU
002070     END-EVALUATE.
002080 M-4.
002090     CLOSE INPUT-CARD-FILE
002100           PRINT-ZAIKO-FILE.
002110 M-EX.
002120     EXEC SQL
002130        WHENEVER SQLERROR   CONTINUE 
002140     END-EXEC.
002150     EXEC SQL
002160        WHENEVER NOT FOUND  CONTINUE 
002170     END-EXEC
002180     EXEC SQL
002190        WHENEVER SQLWARNING CONTINUE 
002200     END-EXEC.
002210     EXEC SQL
002220        DISCONNECT
002230     END-EXEC.
002240     GOBACK.
002250 HENKOU SECTION.
002260 H-1.
002270     READ INPUT-CARD-FILE
002280       AT END
002290         MOVE '1' TO ERR-FLG
002300     END-READ.
002310     EXEC SQL
002320          WHENEVER SQLERROR
002330            GO TO H-2
002340     END-EXEC.
002350     PERFORM UNTIL EOF = '1' OR ERR-FLG NOT = '0'
002360       EVALUATE IKUBUN
002370         WHEN 'I'
002380           PERFORM TSUIKA
002390         WHEN 'U'
002400           PERFORM KOUSHIN
002410         WHEN 'D'
002420           PERFORM SAKUJO
002430       END-EVALUATE
002440       READ INPUT-CARD-FILE
002450         AT END
002460           MOVE '1' TO EOF
002470       END-READ
002480     END-PERFORM.
002490     GO TO H-EX.
002500 H-2.
002510     MOVE '3' TO ERR-FLG.
002520 H-EX.
002530     EXIT.
002540*
002550 TSUIKA SECTION.
002560 T-1.
002570     MOVE ISCODE  TO XSCODE.
002580     MOVE ISNAME  TO XSNAME.
002590     MOVE ICOL    TO XCOL.  
002600     MOVE ITANKA  TO XTANKA.
002610     MOVE IGRYO   TO XGRYO.
002620     EXEC SQL 
002610           WHENEVER SQLERROR GO TO T-2
002620     END-EXEC.
002630     EXEC SQL                                                    3
002640           INSERT INTO ZAIKO(SCODE, SNAME, COL, TANKA, ZSURYO)   3
002650              VALUES(:XSCODE, :XSNAME, :XCOL, :XTANKA, :XGRYO)   3
002660     END-EXEC.                                                   3
002670     GO TO T-EX.
002680 T-2.
002690     MOVE '3' TO ERR-FLG.
002700 T-EX.
002710     EXIT.
002720 KOUSHIN SECTION.
002730 K-1.
002740     MOVE ISCODE TO XSCODE.
002750     MOVE IGRYO  TO XGRYO.
002760     EXEC SQL
002770           WHENEVER SQLERROR GO TO K-2
002780     END-EXEC.
002790     EVALUATE IIOKBN
002800       WHEN '1'                                                  4
002810         EXEC SQL                                            (a) 4
002820               UPDATE ZAIKO SET ZSURYO = ZSURYO + :XGRYO     (a) 4
002830                  WHERE SCODE=:XSCODE                        (a) 4
002840         END-EXEC                                            (a) 4
002850       WHEN '2'                                                  4
002860         EXEC SQL                                            (b) 4
002870               UPDATE ZAIKO SET ZSURYO = ZSURYO - :XGRYO     (b) 4
002880                  WHERE SCODE=:XSCODE                        (b) 4
002890         END-EXEC                                            (b) 4
002900     END-EVALUATE.
002910     GO TO K-EX.
002920 K-2.
002930     MOVE '3' TO ERR-FLG.
002940 K-EX.
002950     EXIT.
002960*
002970 SAKUJO SECTION.
002980 S-1.
002990     MOVE ISCODE TO XSCODE.
003010     EXEC SQL
003020           WHENEVER SQLERROR GO TO S-2
003030     END-EXEC.
003040     EXEC SQL                                                   5
003050           DELETE FROM ZAIKO                                    5
003060              WHERE SCODE=:XSCODE                               5
003070     END-EXEC.                                                  5
003080     GO TO S-EX.
003090 S-2.
003100     MOVE '3' TO ERR-FLG.
003110 S-EX.
003120     EXIT.
003130*
003140 FUTSUU SECTION.
003150 F-0.
003160     WRITE PRINT-ZAIKO-REC
003170        FROM MIDASHI-REC
003180        AFTER ADVANCING 4 LINES.
003190     WRITE PRINT-ZAIKO-REC
003200        FROM RETSUMEI-REC
003210        AFTER ADVANCING 2 LINES.
003220     WRITE PRINT-ZAIKO-REC
003230        FROM LINE-REC
003240        AFTER ADVANCING 2 LINES.
003250 F-1.
003260     EXEC SQL
003270           WHENEVER SQLERROR GO TO F-4
003280     END-EXEC.
003290     EXEC SQL                                                (a) 6
003300           DECLARE CR1 CURSOR FOR                            (a) 6
003310             SELECT SCODE,SNAME,COL,TANKA,ZSURYO FROM ZAIKO  (a) 6
003320     END-EXEC.                                               (a) 6
003330     EXEC SQL                                                (b) 6
003340           OPEN CR1                                          (b) 6
003350     END-EXEC.                                               (b) 6
003360 F-2.
003370     EXEC SQL                                                (a) 7
003380           WHENEVER NOT FOUND                                (a) 7
003390              GO TO F-3                                      (a) 7
003400     END-EXEC.                                               (a) 7
003410     EXEC SQL                                                (b) 7
003420           FETCH CR1                                         (b) 7
003430              INTO :XSCODE:XISCODE, :XSNAME:XISNAME,         (b) 7
003440                :XCOL:XICOL, :XTANKA:XITANKA, :XGRYO:XIGRYO  (b) 7
003450     END-EXEC.                                               (b) 7
003460     EXEC SQL
003470          WHENEVER NOT FOUND  
003480             CONTINUE
003490     END-EXEC.
003500     IF XISCODE IS >= 0 THEN
003510       MOVE XSCODE TO O-SCODE 
003520     ELSE
003530       MOVE O-SCODE-NULL TO O-SCODE
003540     END-IF.
003550     IF XISNAME IS >= 0 THEN
003560       MOVE XSNAME TO O-SNAME
003570     ELSE 
003580       MOVE O-SNAME-NULL TO O-SNAME
003590     END-IF.
003600     IF XICOL IS >= 0 THEN
003610       MOVE XCOL TO O-COL
003620     ELSE 
003630       MOVE O-COL-NULL TO O-COL    
003640     END-IF.
003650     IF XITANKA IS >= 0 THEN
003660       MOVE XTANKA TO O-TANKA
003670     ELSE 
003680       MOVE O-TANKA-NULL TO O-TANKA    
003690     END-IF.
003700     IF XIGRYO IS >= 0 THEN
003710       MOVE XGRYO TO O-GRYO 
003720     ELSE 
003730       MOVE O-GRYO-NULL TO O-GRYO
003740     END-IF.
003750     WRITE PRINT-ZAIKO-REC
003760           FROM SELECT-OUT-REC
003770           AFTER ADVANCING 2 LINES.
003780     GO TO F-2.
003790 F-3.
003800     EXEC SQL
003810        WHENEVER SQLERROR   CONTINUE 
003820     END-EXEC.
003830     EXEC SQL
003840        WHENEVER NOT FOUND  CONTINUE 
003850     END-EXEC
003860     EXEC SQL
003870        WHENEVER SQLWARNING CONTINUE 
003880     END-EXEC.
003890     EXEC SQL                                              (a) 8
003900        CLOSE CR1                                          (a) 8
003910     END-EXEC.                                             (a) 8
003920*
003930     EXEC SQL                                              (b) 8
003940        COMMIT                                             (b) 8
003950     END-EXEC.                                             (b) 8
003960*
003970     WRITE PRINT-ZAIKO-REC
003980           FROM NORMAL-END-REC
003990           AFTER ADVANCING 2 LINES.
004000     GO TO F-EX.
004010 F-4.
004020     PERFORM IJYOU.
004030 F-EX.
004040     EXIT.
004050 IJYOU SECTION.
004060 I-1.
004070     MOVE SQLCODE TO WSQLCODE.
004080     MOVE WSQLCODE TO WMSGID.
004090     MOVE MSGID TO E-MSGID.
004100     MOVE ERRORMSGID TO RC-MSGID.
004110     MOVE SQLERRMC TO RC-SQLERRMC.
004120     WRITE PRINT-ZAIKO-REC
004130           FROM SQLERR-PRINT-REC
004140           AFTER ADVANCING 2 LINES.
004150     EXEC SQL                                            (a) 9
004160        WHENEVER SQLERROR   CONTINUE                     (a) 9
004170     END-EXEC.                                           (a) 9
004180     EXEC SQL                                            (a) 9
004190        WHENEVER NOT FOUND  CONTINUE                     (a) 9
004200     END-EXEC.                                           (a) 9
004210     EXEC SQL                                            (a) 9
004220        WHENEVER SQLWARNING CONTINUE                     (a) 9
004230     END-EXEC.                                           (a) 9
004240     EXEC SQL                                            (b) 9
004250        ROLLBACK                                         (b) 9
004260     END-EXEC.                                           (b) 9
004270 I-EX.
004280     EXIT.

＜説明＞

1. 埋込みSQL宣言節の始まりと終わり

   UAP中で使用する変数を，BEGIN DECLARE SECTIONとEND DECLARE SECTIONとで囲んで，埋込みSQL宣言節の始まりと終わりを示します。

2. HiRDBとの接続

   (a) 特異状態発生時の指定

   以下のSQLの実行後に，エラー（SQLERROR）が発生した場合の処理として，分岐先（M-2）を指定します。

   (b) HiRDBへの接続

   HiRDBに認可識別子（XUSERID）及びパスワード（XPSWD）を連絡して，UAPがHiRDBを使用できる状態にします。

3. 在庫表への行の追加

   在庫表の各列に，埋込み変数に読み込まれた値を追加します。

4. 在庫表の行の更新

   (a) 入庫

   在庫表から，埋込み変数（:XGNO）に読み込んだ品番をキーとして，更新する行を検索します。検索した行の数量（SURYO）の値に，埋込み変数（:XSURYO）に読み込んだ値を加算して，行を更新します。

   (b) 在庫

   在庫表から，埋込み変数(:XGNO)に読み込んだ品番をキーとして，更新する行を検索します。検索した行の数量（SURYO）の値に，埋込み変数（:XSURYO）に読み込んだ値を減算して，行を更新します。

5. 在庫表の行の削除

   在庫表から，埋込み変数(:XGNO)に読み込んだ品番をキーとして，それと等しいキーを持つ行を削除します。

6. カーソルCR1の宣言とオープン

   (a) カーソルCR1の宣言

   在庫表（ZAIKO）の行を検索するために，カーソルCR1を宣言します。

   (b) カーソルCR1のオープン

   在庫表（ZAIKO）の検索行の直前にカーソルを位置づけて，行を取り出せる状態にします。

7. 在庫表の行の取り出し

   (a) 特異状態発生時の処理の指定

   以下の在庫表の検索で，FETCH文で取り出す行がない場合（NOT FOUND）の処理として，分岐先（M-３）を指定します。

   (b) FETCH文の実行

   在庫表（ZAIKO）から，カーソルCR1の示す行を１行取り出して，各埋込み変数に設定します。

8. トランザクションの終了

   (a) カーソルCR1のクローズ

   カーソルCR1を閉じます。

   (b) トランザクションの終了

   現在のトランザクションを正常終了させて，そのトランザクションによるデータベースへの追加，更新，削除の結果を有効にします。

9. トランザクションの取り消し

   (a) 特異状態発生時の処理の指定

   以下のSQLの実行でエラー（SQLERROR）や警告（SQLWARNING）が発生した場合，何もしないで次の命令に進むことを指定します。

   (b) トランザクションの取り消し

   現在のトランザクションを取り消して，そのトランザクションによるデータベースへの追加，更新，削除の結果を無効にします。

(a)　PADチャート

プログラム例題5のPADチャートを次の図に示します。

図7‒15　プログラム例題5のPADチャート（1/4）

図7‒16　プログラム例題5のPADチャート（2/4）

図7‒17　プログラム例題5のPADチャート（3/4）

図7‒18　プログラム例題5のPADチャート（4/4）

(b)　コーディング例

000010***************************************************************
000020*                                                             *
000030*       埋込み型SQL  COBOL  UAP                               *
000040*        ROW インタフェースサンプル                           *
000050*                           1997/11/27                        *
000060***************************************************************
000070 IDENTIFICATION DIVISION.
000080 PROGRAM-ID.            ROW-SAMPLE.
000090 AUTHOR.                CLIENT.
000100 DATA-WRITTEN.          1997/11/27.
000110 DATA-COMPILED.         ROW-SAMPLE.
000120 REMARKS.
000130*
000140 ENVIRONMENT DIVISION.
000150 CONFIGURATION SECTION.
000160 SOURCE-COMPUTER. HITAC.
000170 OBJECT-COMPUTER. HITAC.
000180 INPUT-OUTPUT SECTION.
000190 FILE-CONTROL.
000200     SELECT OUTLIST  ASSIGN TO LP.
000210*
000220 DATA DIVISION.
000230 FILE SECTION.
000240 FD OUTLIST RECORDING MODE IS F
000250            LABEL RECORD IS OMITTED
000260            DATA RECORD OUTREC.
000270 01  OUTREC             PIC X(80).
000280*
000290 WORKING-STORAGE SECTION.
000300     EXEC SQL 
000310       BEGIN DECLARE SECTION
000320     END-EXEC.
000330 01 IN-REC1 IS GLOBAL.
000340   02  IN-CHR1       PIC X(15)       VALUE 'EVA-00'.
000350   02  IN-INT1       PIC S9(9) COMP  VALUE 255.
000360   02  IN-INT2       PIC S9(9) COMP  VALUE 1.
000370
000380 01 XSQLROW  IS GLOBAL.                                          1
000390   02 ROW-CHR1 PIC X(30).                                        1
000400   02 ROW-INT1 PIC S9(9) COMP.                                   1
000410   02 ROW-INT2 PIC S9(9) COMP.                                   1
000420
000430     EXEC SQL
000440       END DECLARE SECTION
000450     END-EXEC.
000460
000470 01 DISP-REC IS GLOBAL. 
000480   02  DISP-CHR1       PIC X(15).
000490   02  DISP-INT1       PIC S9(9).
000500   02  DISP-INT2       PIC S9(4).
000510 01  ERRFLG  PIC S9(4) COMP IS GLOBAL.
000520
000530 01  MSG-ERR      PIC X(10) VALUE '!! ERROR'.
000540 01  MSG-CODE IS GLOBAL.
000550     02  FILLER     PIC X(15) VALUE '!! SQLCODE ='.
000560     02  MSG-SQLCODE    PIC S9(9) DISPLAY.
000570 01  MSG-MC IS GLOBAL.
000580     02  FILLER     PIC X(15) VALUE '!! SQLERRMC ='.
000590     02  MSG-SQLERRMC   PIC X(100).
000600
000610 PROCEDURE DIVISION.
000620**********************************************
000630* DISPLAY TITLE       
000640**********************************************
000650 MAIN SECTION.
000660    CALL 'DISPLAY-TITLE'.
000670    MOVE ZERO TO ERRFLG. 
000680
000690**********************************************
000700* CONNECT       
000710**********************************************
000720      EXEC SQL 
000730        WHENEVER SQLERROR GOTO ERR-EXIT
000740      END-EXEC
000750
000760      DISPLAY '***** CONNECT '.
000770      EXEC SQL                                                   2
000780        CONNECT                                                  2
000790      END-EXEC.                                                  2
000800      DISPLAY '***** CONNECT : END'.
000810
000820*********************************************************
000830* INIT          
000840*********************************************************
000850      DISPLAY '## テーブルの初期化を行います'.
000860      CALL 'INIT-TABLE'.
000870      IF ERRFLG < ZERO 
000880        GO TO ERR-EXIT
000890      END-IF 
000900      DISPLAY '## 正常です'.
000910
000920*********************************************************
000930* INSERT        
000940*********************************************************
000950      DISPLAY '## DATAをINSERT'.
000960      CALL 'TEST-INSERT'.
000970      IF ERRFLG < ZERO 
000980        GO TO ERR-EXIT
000990      END-IF 
001000      DISPLAY '## 正常です'.
001010
001020*********************************************************
001030* ROW          
001040*********************************************************
001050      DISPLAY '## ROW型のテストを行います'.
001060      CALL 'TEST-ROW'.       
001070      IF ERRFLG < ZERO 
001080        GO TO ERR-EXIT
001090      END-IF 
001100      DISPLAY '## 正常です'.
001110
001120*********************************************************
001130* DISCONNECT           
001140*********************************************************
001150 ERR-EXIT.
001160      IF SQLCODE < ZERO 
001170        MOVE SQLCODE TO MSG-SQLCODE 
001180        MOVE SQLERRMC TO MSG-SQLERRMC 
001190        DISPLAY MSG-ERR 
001200        DISPLAY MSG-CODE 
001210        DISPLAY MSG-MC 
001220        MOVE -1 TO ERRFLG 
001230      END-IF
001240
001250      EXEC SQL
001260        WHENEVER SQLERROR  CONTINUE
001270      END-EXEC
001280      EXEC SQL
001290        WHENEVER NOT FOUND CONTINUE
001300      END-EXEC
001310      EXEC SQL
001320        WHENEVER SQLWARNING CONTINUE
001330      END-EXEC
001340
001350      DISPLAY '##DISCONNECT'
001360
001370      EXEC SQL                                                   3
001380        DISCONNECT                                               3
001390      END-EXEC                                                   3
001400      STOP RUN.
001410
001420************************************************************
001430*  INSERT文のテスト                                         
001440************************************************************
001450 IDENTIFICATION DIVISION.
001460 PROGRAM-ID. TEST-INSERT.
001470 DATA DIVISION.
001480 WORKING-STORAGE SECTION.
001490   01 DCNT PIC S9(9) COMP.
001500 PROCEDURE DIVISION.      
001510       EXEC SQL
001520         WHENEVER SQLERROR  GOTO :Exit-Test-Insert
001530       END-EXEC.
001540*********************************************************
001550* INSERT HOST   
001560*********************************************************
001570       DISPLAY '***** 埋込み変数によるINSERT start'
001580       MOVE ZERO TO DCNT.
001590 INSERT-LOOP.
001600       COMPUTE IN-INT1 = DCNT
001610       COMPUTE IN-INT2 = DCNT + 100
001620       COMPUTE DCNT = DCNT + 1
001630       EXEC SQL                                                  4
001640         INSERT INTO TT1(CLM1,                                   4
001650                         CLM2,                                   4
001660                         CLM3)                                   4
001670           VALUES (:IN-CHR1,                                     4
001680                   :IN-INT1,                                     4
001690                   :IN-INT2)                                     4
001700       END-EXEC                                                  4
001710       IF DCNT < 20 THEN
001720         GO TO INSERT-LOOP
001730       END-IF
001740       DISPLAY '***** insert : SUCCESS'.
001750*********************************************************
001760*
001770*********************************************************
001780 EXIT-TEST-INSERT.
001790       IF SQLCODE < ZERO 
001800         MOVE SQLCODE TO MSG-SQLCODE 
001810         MOVE SQLERRMC TO MSG-SQLERRMC 
001820         DISPLAY MSG-CODE 
001830         DISPLAY MSG-MC 
001840         MOVE -1 TO ERRFLG 
001850       END-IF
001860       DISPLAY '>> TEST-INSERT <<'
001870       GOBACK.
001880******************************************************
001890*  WARNING
001900******************************************************
001910 INSERT-WARNING.
001920     DISPLAY 'WARINING'
001930     MOVE SQLCODE TO MSG-SQLCODE 
001940     MOVE SQLERRMC TO MSG-SQLERRMC 
001950     DISPLAY MSG-CODE 
001960     DISPLAY MSG-MC. 
001970 END PROGRAM TEST-INSERT.
001980
001990******************************************************
002000*  ROWのテスト                           
002010******************************************************
002020 IDENTIFICATION DIVISION.
002030 PROGRAM-ID. TEST-ROW.
002040 DATA DIVISION.
002050 WORKING-STORAGE SECTION.
002060 PROCEDURE DIVISION.      
002070        DISPLAY '***** ROW CURSOR OPEN'
002080        EXEC SQL                                                 5
002090          DECLARE CUR_ROW CURSOR FOR                             5
002100             SELECT ROW FROM TT1                                 5
002110              WHERE CLM2 = 10                                    5
002120              FOR UPDATE OF CLM3                                 5
002130        END-EXEC                                                 5
002140******************************************************
002150*  ROW CURSOR                                         
002160******************************************************
002170        DISPLAY '***** ROW CURSOR OPEN'.
002180        EXEC SQL
002190          WHENEVER SQLERROR  GOTO :Exit-Test-ROW
002200        END-EXEC
002210        EXEC SQL                                                 6
002220          OPEN CUR_ROW                                           6
002230        END-EXEC                                                 6
002240
002250******************************************************
002260*  FETCH ROW CURSOR                                   
002270******************************************************
002280        DISPLAY '***** ROW CURSOR FETCH'
002290        EXEC SQL
002300          WHENEVER NOT FOUND GOTO :Exit-Test-ROW
002310        END-EXEC
002320        EXEC SQL
002330          WHENEVER SQLERROR GOTO :Exit-Test-ROW
002340        END-EXEC
002350        MOVE SPACE TO XSQLROW
002360        EXEC SQL                                                 7
002370          FETCH CUR_ROW INTO :XSQLROW                            7
002380        END-EXEC                                                 7
002390        DISPLAY '## FETCH DATA'
002400        MOVE ROW-CHR1 TO DISP-CHR1
002410        MOVE ROW-INT1 TO DISP-INT1
002420        MOVE ROW-INT2 TO DISP-INT2
002430        DISPLAY DISP-REC
002440                          
002450        DISPLAY '***** ROW UPDATE'
002460        MOVE 'ANGEL' TO ROW-CHR1
002470        EXEC SQL                                                 8
002480          UPDATE TT1 SET ROW = :XSQLROW                          8
002490           WHERE CURRENT OF CUR_ROW                              8
002500        END-EXEC                                                 8
002510
002520******************************************************
002530*  FETCH ROW CURSOR                                  
002540******************************************************
002550        DISPLAY '***** ROW CURSOR CLOSE'
002560        EXEC SQL
002570          WHENEVER NOT FOUND CONTINUE
002580        END-EXEC
002590        EXEC SQL
002600          WHENEVER SQLERROR CONTINUE
002610        END-EXEC
002620        EXEC SQL                                                 9
002630          CLOSE  CUR_ROW                                         9
002640        END-EXEC.                                                9
002650******************************************************
002660*
002670******************************************************
002680 EXIT-TEST-ROW.               
002690        IF SQLCODE < ZERO THEN
002700          MOVE SQLCODE  TO MSG-SQLCODE 
002710          MOVE SQLERRMC TO MSG-SQLERRMC 
002720          DISPLAY MSG-CODE 
002730          DISPLAY MSG-MC 
002740          MOVE -1 TO ERRFLG 
002750        END-IF
002760        EXEC SQL
002770          WHENEVER NOT FOUND CONTINUE
002780        END-EXEC
002790        EXEC SQL
002800          WHENEVER SQLERROR CONTINUE
002810        END-EXEC
002820        EXEC SQL
002830          COMMIT
002840        END-EXEC
002850        DISPLAY '>> TEST-ROW END <<'
002860        GOBACK.
002870
002880******************************************************
002890*  WARNING
002900******************************************************
002910 ROW-WARNING.
002920     DISPLAY 'WARINING'
002930     MOVE SQLCODE TO MSG-SQLCODE 
002940     MOVE SQLERRMC TO MSG-SQLERRMC 
002950     DISPLAY MSG-CODE 
002960     DISPLAY MSG-MC. 
002970 END PROGRAM TEST-ROW.
002980
002990
003000 *****************************************************
003010 *  テーブルの初期化                                  
003020 *****************************************************
003030 IDENTIFICATION DIVISION.
003040 PROGRAM-ID. INIT-TABLE. 
003050 DATA DIVISION.
003060 WORKING-STORAGE SECTION.
003070 PROCEDURE DIVISION.      
003080       EXEC SQL 
003090         WHENEVER SQLERROR CONTINUE
003100       END-EXEC
003110  
003120*****************************************************
003130* DROP TABLE    
003140*****************************************************
003150       DISPLAY '***** DROP TABLE'.
003160       EXEC SQL                                                  10
003170         DROP TABLE TT1                                          10
003180       END-EXEC                                                  10
003190       DISPLAY '***** CREATE SCHEMA'.
003200       EXEC SQL                                                  11
003210         CREATE SCHEMA                                           11
003220       END-EXEC                                                  11
003230
003240*********************************************************
003250* COMMIT        
003260*********************************************************
003270       DISPLAY '***** COMMIT START'.
003280       EXEC SQL 
003290         WHENEVER SQLERROR GOTO EXIT-INIT-TABLE
003300       END-EXEC
003310       EXEC SQL 
003320         COMMIT
003330       END-EXEC
003340       DISPLAY '***** COMMIT : END'.
003350
003360*********************************************************
003370* CREATE TABLE  
003380*********************************************************
003390       DISPLAY '***** create table'.
003400       EXEC SQL                                                  12
003410         CREATE FIX TABLE TT1(CLM1 CHAR(30),                     12
003420                               CLM2 INTEGER,                     12
003430                               CLM3 INTEGER)                     12
003440       END-EXEC                                                  12
003450
003460       DISPLAY '***** create table : SUCCESS'.
003470          
003480******************************************************
003490*
003500******************************************************
003510 EXIT-INIT-TABLE.              
003520       IF SQLCODE < ZERO THEN
003530         MOVE SQLCODE  TO MSG-SQLCODE 
003540         MOVE SQLERRMC TO MSG-SQLERRMC 
003550         DISPLAY MSG-CODE 
003560         DISPLAY MSG-MC 
003570         MOVE -1 TO ERRFLG 
003580       END-IF
003590       GOBACK.
003600
003610******************************************************
003620*  WARNING
003630******************************************************
003640 INIT-TABLE-WARNING.
003650     DISPLAY 'WARINING'
003660     MOVE SQLCODE TO MSG-SQLCODE 
003670     MOVE SQLERRMC TO MSG-SQLERRMC 
003680     DISPLAY MSG-CODE 
003690     DISPLAY MSG-MC. 
003700 END PROGRAM INIT-TABLE.
003710
003720******************************************************
003730*  DISPLAY
003740******************************************************
003750 IDENTIFICATION DIVISION.
003760 PROGRAM-ID. DISPLAY-TITLE.
003770 DATA DIVISION.
003780 WORKING-STORAGE SECTION.
003790 PROCEDURE DIVISION.      
003800     DISPLAY '##############################################'
003810     DISPLAY '#                                            #'
003820     DISPLAY '# このプログラムはROW型インタフェースの     #'
003830     DISPLAY '#   サンプルプログラムです                   #'
003840     DISPLAY '#                                            #'
003850     DISPLAY '##############################################'.
003860 END PROGRAM DISPLAY-TITLE.
003870 END PROGRAM ROW-SAMPLE.

＜説明＞

1. ROW型の埋込み変数の宣言

   行インタフェースで使用する埋込み変数（:XSQLROW）を宣言します。

2. HiRDBへの接続

   環境変数PDUSERに定義されている認可識別子とパスワードを使用して，サーバに接続します。

3. HiRDBの切り離し

   UAPをサーバから切り離します。

4. 行の追加

   FIX表（TT1）にデータを追加します。

5. カーソルCUR_ROWの宣言

   行インタフェースを使用してFIX表（TT1）を検索するので，カーソルCUR_ROWを宣言します。

6. カーソルCUR_ROWのオープン

   FIX表（TT1）の検索行の直前にカーソルを位置づけて，各行を取り出せる状態にします。

7. 行の取り出し

   FIX表（TT1）から，カーソルCUR_ROWの示す行を１行取り出し，埋込み変数（:XSQLROW）に設定します。

8. 行の更新

   カーソルCUR_ROWが位置づけられているFIX表（TT1）の行を，埋込み変数（:XSQLROW）の値で更新します。

9. カーソルCUR_ROWのクローズ

   カーソルCUR_ROWを閉じます。

10. 表（TT1）を削除する

    FIX表（TT1）を作成するために，同名の表があった場合は削除します。

11. スキーマの生成

    スキーマがないときのために，スキーマを生成します。

12. FIX表（TT1）の作成

    FIX表（TT1）を作成します。行インタフェースはFIX属性の表に対してだけ使用できます。