以前に Tools で「17. IFSのファイルの存在チェックを行う CHKIFS」を紹介したが

実行プログラム(CPP) が C/400 であったために、少しわかりずらかったかも知れない。

ここでは、同じ C/400 の open/close 関数を利用するにしても CLP でできる、さらに

やさしい方法を紹介しよう。

CLP といっても、ILE-CLP であるので CRTCLPGM ではなく、CRTBNDCL によって

コンパイルする必要があるが、C関数のバインド・ディレクトリーの指定も必要ない。

単純に CRTBNDCL を実行するだけのコンパイルでよい。

CLP のソース・タイプには CLP ではなく、CLLE を指定すること。

0001.00              CMD        PROMPT('IFS 検査 ')                          
0002.00              PARM       KWD(DIR) TYPE(*CHAR) LEN(256) CASE(*MIXED) + 
0003.00                           PROMPT(' 登録簿 (/)')

0001.00              PGM        PARM(&DIR)                                     
0002.00 /*---------------------------------------------------------*/          
0003.00 /*     CHKIFS :  IFS 検査                                  */          
0004.00 /*---------------------------------------------------------*/          
0005.00              DCL        VAR(&MSG) TYPE(*CHAR) LEN(80)                  
0006.00              DCL        VAR(&DIR) TYPE(*CHAR) LEN(256)                 
0007.00              DCL        VAR(&FILDES) TYPE(*INT)                        
0008.00              DCL        VAR(&OFLAG) TYPE(*INT)                         
0009.00              DCL        VAR(&O_RDONLY) TYPE(*INT) VALUE(1)             
0010.00              DCL        VAR(&O_SHR_NONE) TYPE(*INT) VALUE(524288)      
0011.00              DCL        VAR(&NULL) TYPE(*CHAR) LEN(1) VALUE(X'00')     
0012.00              DCL        VAR(&FALSE) TYPE(*INT) VALUE(-1)               
0013.00              MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))        
0014.00                                                                        
0015.00              CHGVAR     VAR(&DIR) VALUE(&DIR *TCAT &NULL)              
0016.00              MONMSG     MSGID(MCH3601) EXEC(GOTO CMDLBL(ERROR))        
0017.00              CHGVAR     VAR(&OFLAG) VALUE(&O_RDONLY + &O_SHR_NONE)     
0018.00              CALLPRC    PRC('open') PARM((&DIR) (&OFLAG *BYVAL)) +     
0019.00                           RTNVAL(&FILDES)                              
0020.00              IF         COND(&FILDES *EQ &FALSE) THEN(DO) /*  失敗  */ 
0021.00              SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) +             
0022.00                           MSGDTA(' ファイル ' *CAT &DIR *TCAT +    
0023.00                           ' は見つかりません。 ') MSGTYPE(*ESCAPE) 
0024.00              ENDDO      /*  失敗  */                               
0025.00              ELSE       CMD(DO) /*  成功  */                       
0026.00              CALLPRC    PRC('close') PARM((&FILDES *BYVAL))        
0027.00              RETURN                                                
0028.00              ENDDO      /*  成功  */                               
0029.00                                                                    
0030.00  ERROR:      RCVMSG     MSGTYPE(*LAST) RMV(*NO) MSG(&MSG)          
0031.00  SNDMSG:     SNDPGMMSG  MSG(&MSG) MSGTYPE(*DIAG)                   
0032.00              ENDPGM

【 コンパイル 】

CRTCMD CMD(MYLIB/CHKIFS) PGM(MYLIB/CHKIFSCL) SRCFILE(MYSRCLIB/QCMDSRC) AUT(*ALL)

CRTBNDCL PGM(MYLIB/CHKIFSCL) SRCFILE(MYSRCLIB/QCLLESRC) AUT(*ALL)

【 実行 】