2.11.2 コーディング例
COBOLソースプログラムのコーディング例を次に示します。
左端の番号は行番号を示しています。
1 IDENTIFICATION DIVISION. 2 PROGRAM-ID. UAPDML01. 3 * 4 ENVIRONMENT DIVISION. 5 * 6 INPUT-OUTPUT SECTION. 7 * 8 DATA DIVISION. 9 * 10 SDB-DATABASE SECTION. - 11 SDB DATABASE01 | 12 RECORD NAME RECNAME | 1. 13 RECORD LENGTH RECLENG | 14 . - 15 * 16 WORKING-STORAGE SECTION. 17 * 18 77 EOF PIC X VALUE '0'. 19 77 ERR-FLG PIC X VALUE '0'. 20 77 TENPO_END PIC X VALUE '0'. 21 77 ZAIKO_END PIC X VALUE '0'. 22 77 TENPO_NOT_1ST PIC X VALUE '0'. 23 * 24 77 RECNAME PIC X(30) VALUE SPACE. ←2. 25 77 RECLENG PIC S9(8) COMP-5 VALUE ZERO. ←2. 26 * 27 01 OUTREC IS GLOBAL PIC X(132). 28 * 29 01 INREC IS GLOBAL PIC X(80). 30 01 INREC_W REDEFINES INREC. 31 02 IW_SYORI PIC X. 32 02 FILLER PIC X. 33 02 IW_KUBUN PIC X. 34 02 FILLER PIC X(77). 35 * 36 01 INREC_R REDEFINES INREC_W. 37 02 IR_SYORI PIC X. 38 02 FILLER PIC X. 39 02 IR_KUBUN PIC X. 40 02 FILLER PIC X. 41 02 IR_KSN-KUBUN PIC X. 42 02 FILLER PIC X. 43 02 IR_TENPO_CD PIC X. 44 02 FILLER PIC X. 45 02 IR_TENPO_NAME PIC X(30). 46 01 INREC_C REDEFINES INREC_W. 47 02 IC_SYORI PIC X. 48 02 FILLER PIC X. 49 02 IC_KUBUN PIC X. 50 02 FILLER PIC X. 51 02 IC_KSN-KUBUN PIC X. 52 02 FILLER PIC X. 53 02 IC_IO-KUBUN PIC X. 54 02 FILLER PIC X. 55 02 IC_TENPOID PIC X. 56 02 FILLER PIC X. 57 02 IC_SCODE PIC X(4). 58 02 FILLER PIC X. 59 02 IC_SNAME PIC X(30). 60 02 FILLER PIC X. 61 02 IC_SCOLOR PIC X(10). 62 02 FILLER PIC X. 63 02 IC_STANKA PIC 9(10). 64 02 FILLER PIC X. 65 02 IC_SSURYO PIC 9(10). 66 * 67 01 TENPO. - 68 02 RT_DBKEY. | 3. 69 03 TENPO_CD PIC X. | 70 02 TENPO_NAME PIC X(30). - 71 * 72 01 ZAIKO. - 73 02 CH_TENPO_CD PIC X. | 74 02 CH_DBKEY PIC S9(8) COMP-5. | 75 02 SCODE PIC X(4). | 4. 76 02 SNAME PIC X(30). | 77 02 SCOLOR PIC X(10). | 78 02 TANKA PIC S9(8) COMP-5. | 79 02 ZSURYO PIC S9(8) COMP-5. - 80 * 81 01 MIDASHI. 82 02 FILLER PIC X(80) VALUE 83 '*** ZAIKO ICHIRAN ***'. 84 * 85 01 O_TENPO. 86 02 FILLER PIC X(15) VALUE ' TENPO CODE : '. 87 02 O_TENPO_CD PIC X. 88 02 FILLER PIC X(10) VALUE ', NAME : "'. 89 02 O_TENPO_NAME PIC X(30). 90 02 FILLER PIC X VALUE '"'. 91 * 92 01 O_ZAIKO. 93 02 FILLER PIC X(15) VALUE ' ZAIKO CODE : '. 94 02 O_ZAIKO_CODE PIC X(4). 95 02 FILLER PIC X(10) VALUE ', NAME : "'. 96 02 O_ZAIKO_NAME PIC X(30). 97 02 FILLER PIC X(11) VALUE '", COLOR : '. 98 02 O_ZAIKO_COLOR PIC X(10). 99 02 FILLER PIC X(10) VALUE ', TANKA : '. 100 02 O_ZAIKO_TANKA PIC ZZZZZZZZ9. 101 02 FILLER PIC X(11) VALUE ', SUURYO : '. 102 02 O_ZAIKO_SUURYO PIC ZZZZZZZZ9. 103 * 104 01 ERR_MSG. 105 02 FILLER PIC X(22) VALUE '*** ERROR SQLCODE : '. 106 02 EM_SQLCODE PIC -ZZZZZZZZ9. 107 02 FILLER PIC X(15) VALUE ', ERROR DML : "'. 108 02 EM_ERRDML PIC X(30). 109 02 FILLER PIC X(7) VALUE '" ***'. 110 * 111 LINKAGE SECTION. 112 * 113 77 IN_DATA PIC X(80). ←5. 114 77 IN_LENG PIC S9(9) COMP-5. ←6. 115 77 OUT_DATA PIC X(32). ←7. 116 77 OUT_LENG PIC S9(9) COMP-5. ←8. 117 * 118 PROCEDURE DIVISION USING IN_DATA IN_LENG OUT_DATA OUT_LENG. 119 MAIN SECTION. 120 * test 121 MOVE IN_DATA TO INREC. 122 * 123 M-01. 124 MOVE 0 TO RETURN-CODE. 125 MOVE 'SVR01: NORMAL END' TO OUT_DATA ←9. 126 MOVE 32 TO OUT_LENG ←9. 127 DISPLAY 'UAPDML01 START'. 128 DISPLAY 'IW_SYORI =' IW_SYORI. 129 DISPLAY 'IW_KUBUN =' IW_KUBUN. 130 * 131 M-02. 132 IF IW_SYORI = 'D' 133 THEN 134 PERFORM DB-KOUSHIN 135 ELSE IF IW_SYORI = 'F' 136 PERFORM FUTSUU 137 END-IF. 138 * 139 IF OUT_DATA NOT = 'SVR01: NORMAL END' 140 THEN 141 PERFORM IJYOU 142 END-IF. 143 M-EXIT. 144 EXIT PROGRAM. 145 * 146 DB-KOUSHIN SECTION. 147 D-01. 148 * MOVE INREC TO INREC_W 149 IF IW_KUBUN = 'R' 150 THEN 151 EVALUATE IR_KSN-KUBUN 152 WHEN 'S' 153 PERFORM TENPO-TSUIKA 154 WHEN 'E' 155 PERFORM TENPO-SAKUJO 156 END-EVALUATE 157 ELSE 158 MOVE IC_TENPOID TO TENPO_CD 159 MOVE 'D-01:FIND TENPO' TO EM_ERRDML 160 EXEC DML - 161 FIND FIRST "TENPO" WHERE ( "DBKEY" = :RT_DBKEY ) | 10. 162 END-DML - 163 IF SQLCODE = 0 ←11. 164 EVALUATE IC_KSN-KUBUN 165 WHEN 'M' 166 PERFORM ZAIKO-KOUSHIN 167 WHEN 'S' 168 PERFORM ZAIKO-TSUIKA 169 WHEN 'E' 170 PERFORM ZAIKO-SAKUJO 171 END-EVALUATE 172 ELSE 173 MOVE '2' TO ERR-FLG 174 MOVE 'SVR01: DB-KOUSHIN FAILED' TO OUT_DATA ←12. 175 MOVE 24 TO OUT_LENG 176 END-IF 177 END-IF. 178 D-EXIT. 179 EXIT. 180 * 181 ZAIKO-KOUSHIN SECTION. 182 M-01. 183 PERFORM ICHIDUKE. ←13. 184 IF ERR-FLG = '0' 185 THEN 186 IF IC_IO-KUBUN = '1' 187 THEN 188 COMPUTE ZSURYO = ZSURYO + IC_SSURYO ←14. 189 ELSE 190 COMPUTE ZSURYO = ZSURYO - IC_SSURYO ←14. 191 END-IF 192 MOVE 'M-01:MODIFY ZAIKO' TO EM_ERRDML 193 EXEC DML 194 MODIFY ZAIKO FROM :ZAIKO ←15. 195 END-DML 196 IF SQLCODE NOT = 0 ←11. 197 THEN 198 MOVE '2' TO ERR-FLG 199 MOVE 'SVR01: ZAIKO-KOUSHIN FAILED' TO OUT_DATA ←16. 200 MOVE 27 TO OUT_LENG 201 ELSE 202 CONTINUE 203 END-IF 204 END-IF. 205 M-EXIT. 206 EXIT. 207 * 208 ZAIKO-TSUIKA SECTION. 209 S-01. 210 MOVE IC_TENPOID TO TENPO_CD. ←17. 211 MOVE 0 TO CH_DBKEY. ←18. 212 MOVE IC_SCODE TO SCODE. - 213 MOVE IC_SNAME TO SNAME. | 214 MOVE IC_SCOLOR TO SCOLOR. |17. 215 MOVE IC_STANKA TO TANKA. | 216 MOVE IC_SSURYO TO ZSURYO. - 217 S-02. 218 MOVE 'S-02:STORE ZAIKO' TO EM_ERRDML. 219 EXEC DML 220 STORE ZAIKO FROM :ZAIKO ←19. 221 END-DML. 222 IF SQLCODE NOT = 0 ←11. 223 THEN 224 MOVE '2' TO ERR-FLG 225 MOVE 'SVR01: ZAIKO-TSUIKA FAILED' TO OUT_DATA ←12. 226 MOVE 26 TO OUT_LENG 227 ELSE 228 CONTINUE 229 END-IF. 230 S-EXIT. 231 EXIT. 232 * 233 ZAIKO-SAKUJO SECTION. 234 E-01. 235 PERFORM ICHIDUKE. ←20. 236 IF ERR-FLG = '0' 237 THEN 238 MOVE 'E-01:ERASE ZAIKO' TO EM_ERRDML 239 EXEC DML 240 ERASE ZAIKO ALL ←21. 241 END-DML 242 IF SQLCODE NOT = 0 ←11. 243 THEN 244 MOVE '2' TO ERR-FLG 245 MOVE 'SVR01: ZAIKO-SAKUJO FAILED' TO OUT_DATA ←12. 246 MOVE 26 TO OUT_LENG 247 ELSE 248 CONTINUE 249 END-IF 250 END-IF. 251 E-EXIT. 252 EXIT. 253 * 254 TENPO-TSUIKA SECTION. 255 A-01. 256 MOVE IR_TENPO_CD TO TENPO_CD. ←22. 257 MOVE IR_TENPO_NAME TO TENPO_NAME. ←17. 258 MOVE 'A-01:STORE TENPO' TO EM_ERRDML 259 DISPLAY TENPO. 260 EXEC DML 261 STORE TENPO FROM :TENPO ←23. 262 END-DML. 263 IF SQLCODE NOT = 0 ←11. 264 THEN 265 MOVE '2' TO ERR-FLG 266 MOVE 'SVR01: TENPO-TSUIKA FAILED' TO OUT_DATA ←12. 267 MOVE 26 TO OUT_LENG 268 ELSE 269 CONTINUE 270 END-IF. 271 A-EXIT. 272 EXIT. 273 * 274 TENPO-SAKUJO SECTION. 275 K-01. 276 MOVE IR_TENPO_CD TO TENPO_CD. ←24. 277 MOVE 'K-01:FIND TENPO' TO EM_ERRDML 278 EXEC DML 279 FIND FOR UPDATE FIRST TENPO ←25. 280 WHERE ( "DBKEY" = :RT_DBKEY ) ←25. 281 END-DML. 282 IF SQLCODE = 0 ←11. 283 THEN 284 MOVE 'K-01:ERASE TENPO' TO EM_ERRDML 285 EXEC DML 286 ERASE TENPO ALL ←26. 287 END-DML 288 ELSE 289 CONTINUE 290 END-IF. 291 IF SQLCODE NOT = 0 ←11. 292 THEN 293 MOVE '2' TO ERR-FLG 294 MOVE 'SVR01: TENPO-SAKUJO FAILED' TO OUT_DATA ←12. 295 MOVE 26 TO OUT_LENG 296 ELSE 297 CONTINUE 298 END-IF. 299 K-EXIT. 300 EXIT. 301 * 302 ICHIDUKE SECTION. 303 I-01. 304 MOVE 'I-01:FETCH ZAIKO 01' TO EM_ERRDML. 305 EXEC DML 306 FETCH FOR UPDATE FIRST ZAIKO ←27. 307 INTO :ZAIKO WITHIN TENPO_ZAIKO 308 END-DML. 309 IF SQLCODE NOT = 0 ←11. 310 THEN 311 MOVE '2' TO ERR-FLG 312 MOVE 'SVR01: ICHIDUKE FAILED' TO OUT_DATA ←12. 313 MOVE 22 TO OUT_LENG 314 ELSE 315 CONTINUE 316 END-IF. 317 PERFORM UNTIL ( IC_SCODE = SCODE OR ERR-FLG NOT = '0' ) 318 MOVE 'I-01:FETCH ZAIKO 02' TO EM_ERRDML 319 EXEC DML 320 FETCH FOR UPDATE NEXT ZAIKO ←28. 321 INTO :ZAIKO WITHIN TENPO_ZAIKO 322 END-DML 323 IF SQLCODE NOT = 0 ←11. 324 THEN 325 MOVE '2' TO ERR-FLG 326 MOVE 'SVR01: ICHIDUKE FAILED' TO OUT_DATA ←12. 327 MOVE 22 TO OUT_LENG 328 ELSE 329 CONTINUE 330 END-IF 331 END-PERFORM. 332 I-EXIT. 333 EXIT. 334 * 335 FUTSUU SECTION. 336 F-01. 337 MOVE MIDASHI TO OUTREC. 338 DISPLAY OUTREC UPON SYSOUT. 339 PERFORM UNTIL ( TENPO_END = '1' OR ERR-FLG NOT = '0' ) 340 MOVE 'F-01:FETCH TENPO' TO EM_ERRDML 341 IF TENPO_NOT_1ST = '0' 342 THEN 343 EXEC DML 344 FETCH FOR UPDATE FIRST TENPO INTO :TENPO ←29. 345 END-DML 346 ELSE 347 EXEC DML 348 FETCH FOR UPDATE NEXT TENPO INTO :TENPO ←30. 349 END-DML 350 END-IF 351 IF SQLCODE = 0 ←11. 352 THEN 353 MOVE TENPO_CD TO O_TENPO_CD 354 MOVE TENPO_NAME TO O_TENPO_NAME 355 MOVE O_TENPO TO OUTREC 356 DISPLAY OUTREC UPON SYSOUT 357 PERFORM UNTIL ( ZAIKO_END = '1' OR ERR-FLG NOT = '0' ) 358 MOVE 'F-01:FETCH ZAIKO' TO EM_ERRDML 359 EXEC DML 360 FETCH NEXT ZAIKO INTO :ZAIKO WITHIN TENPO_ZAIKO ←31. 361 END-DML 362 IF SQLCODE = 0 ←11. 363 THEN 364 MOVE SCODE TO O_ZAIKO_CODE - 365 MOVE SNAME TO O_ZAIKO_NAME | 366 MOVE SCOLOR TO O_ZAIKO_COLOR | 32. 367 MOVE TANKA TO O_ZAIKO_TANKA | 368 MOVE ZSURYO TO O_ZAIKO_SUURYO | 369 MOVE O_ZAIKO TO OUTREC - 370 DISPLAY OUTREC UPON SYSOUT 371 ELSE 372 IF SQLCODE = 100 - 373 THEN | 33. 374 MOVE '1' TO ZAIKO_END - 375 ELSE 376 MOVE '2' TO ERR-FLG 377 MOVE 'SVR01: FUTSUU FAILED' TO OUT_DATA ←12. 378 MOVE 20 TO OUT_LENG 379 END-IF 380 END-IF 381 END-PERFORM 382 MOVE '1' TO TENPO_NOT_1ST 383 MOVE '0' TO ZAIKO_END 384 ELSE 385 IF SQLCODE = 100 - 386 THEN | 34. 387 MOVE '1' TO TENPO_END - 388 ELSE 389 MOVE '2' TO ERR-FLG 390 MOVE 'SVR01: FUTSUU FAILED' TO OUT_DATA ←12. 391 MOVE 20 TO OUT_LENG 392 END-IF 393 END-IF 394 END-PERFORM. 395 F-EXIT. 396 EXIT. 397 * 398 IJYOU SECTION. 399 J-01. 400 MOVE SQLCODE TO EM_SQLCODE. ←35. 401 MOVE ERR_MSG TO OUTREC. 402 DISPLAY OUTREC UPON SYSOUT. ←36. 403 DISPLAY SQLERRMC(1:SQLERRML) UPON SYSOUT. ←37. 404 MOVE INREC TO OUTREC. 405 DISPLAY OUTREC UPON SYSOUT. ←38. 406 MOVE OUT_DATA TO OUTREC. 407 DISPLAY OUTREC UPON SYSOUT. ←39. 408 J-EXIT. 409 EXIT.
［説明］
-
SDBデータベース節を指定します。
-
UAP内のDMLでアクセスするSDBデータベースを指定します。
-
DMLの実行後にレコード名を受け取る埋込み変数の名前を指定します。
-
DMLの実行後にレコード長を受け取る埋込み変数の名前を指定します。
SDBデータベース節については，「2.3 SDBデータベース節の記述」を参照してください。
-
-
次の埋込み変数を宣言します。
-
SDBデータベース節のRECORD NAMEで指定した埋込み変数を宣言します。
-
SDBデータベース節のRECORD LENGTHで指定した埋込み変数を宣言します。
-
-
レコード型TENPOとデータの受け渡しを行う埋込み変数を宣言します。
埋込み変数の宣言については，「2.4 埋込み変数の宣言」を参照してください。
-
レコード型ZAIKOとデータの受け渡しを行う埋込み変数を宣言します。
-
クライアントUAPから値が渡されるデータ領域：入力パラメタ
-
クライアントUAPから値が渡されるデータ領域：入力パラメタ長
-
UAPで値を設定するデータ領域：サービスプログラムの応答
-
UAPで値を設定するデータ領域：サービスプログラムの応答の長さ
-
SUPに返すメッセージを正常時の値で初期設定します。
-
ルートレコードのデータベースキーの一致するTENPOレコードに位置指示子を位置づけます。
DML先頭子（EXEC DML）に続けてDMLを記述します。DMLの直後にDML終了子（END-DML）を記述します。
-
SQLCODEを参照してDMLの実行結果を判定します。
DMLの実行結果の判定については，「2.7 DMLの実行結果の判定処理」を参照してください。
-
SUPに返すメッセージにエラーを示す値を設定します。
-
レコード実現値の変更前に，変更するレコードに対して位置指示子を位置づけます。
-
変更する構成要素に対応する埋込み変数に更新値を設定します。
-
位置づけしたZAIKOレコードのユーザデータを埋込み変数の値に変更します。
-
SUP側でチェックするメッセージです。
-
構成要素に対応する埋込み変数に格納するデータを設定します。
-
一連番号はHiRDB/SDが割り当てます。
-
親レコードTENPOへの位置づけ後に，子レコードZAIKOを格納します。
-
レコードの削除をする前に，削除するレコードに位置指示子を位置づけます。
-
位置づけしたZAIKOレコードを削除します。
-
TENPOレコードはルートレコードのため，格納前にルートレコードのデータベースキーの値を埋込み変数に設定します。
-
ルートレコードのTENPOレコードを格納します。
-
キーの検索条件に指定する埋込み変数に，削除対象のルートレコードのデータベースキーの値を設定します。
-
レコード実現値の削除前に，削除するレコードに対して位置指示子を更新指定で位置づけます。削除するレコードはキーの検索条件で指定します。
-
位置指示子が位置づけられているレコードを削除します。下位レコードがある場合は，下位レコードも同時に削除されます。
-
子レコードZAIKOの検索は，親レコードTENPOの位置づけ後に行います。更新指定で先頭のZAIKOレコードへの位置づけを行い，レコード実現値を埋込み変数ZAIKOに取得します。
-
現在位置づけられているZAIKOレコードの次のレコードに更新指定で位置づけを行い，レコード実現値を埋込み変数ZAIKOに取得します。
-
先頭のTENPOレコードへの位置づけを行い，レコード実現値を埋込み変数TENPOに取得します。
-
現在位置づけられているTENPOレコードの次のレコードに位置づけを行い，レコード実現値を埋込み変数TENPOに取得します。
-
ZAIKOレコードに位置づけがない場合は，先頭のZAIKOレコードに位置づけを行い，レコード実現値を埋込み変数ZAIKOに取得します。
位置づけられている場合，位置づけられているZAIKOレコードの次のレコードに位置づけを行い，レコード実現値を埋込み変数ZAIKOに取得します。
-
埋込み変数からレコード実現値を取り出します。
-
SQLCODEが100かどうかを判定します。100の場合は，TENPOレコード下のすべてのZAIKOレコードの検索が完了しています。
-
SQLCODEが100かどうかを判定します。100の場合は，すべてのTENPOレコードの検索が完了しています。
-
エラー要因を取得するため，SQLCODEをエラーメッセージに含めます。
-
エラーメッセージを出力します。
-
HiRDBのエラーメッセージを出力します。
-
エラーが発生した入力データを出力します。
-
エラーが発生した手続きを出力します。