RPG Reading IFS Directory
RPG can manage table data or directory data.
This is an example of an interactive program that reads stream file information from a network folder. RPG originally only read EBCIDIC data representation from the OS database. However, bound to the IBM QC2LE binding directory, an RPG application can access network folders and present ASCII data. Of course, the main difference between accessing the stream files and th DB2 database is that the RPG program must be bound to the QC2LE binding directory supplied by IBM.
Accessing a Directory
This ILE application illustrated below uses the bound services to read a directory and report the contents. Check the drop down menu on this page to view sample of reading or writing a stream file.
ctl-Opt DEBUG(*YES) OPTION(*SRCSTMT : *NODEBUGIO)
DFTACTGRP(*NO) ACTGRP('QILE') Main(ISI400RP)
BNDDIR('QC2LE':'ISI000_BD':'MST0000_BD') ;
//*******************************************************************
// Program Name - ISI400RP *
// *
// Function - This program was designed to allow a user to *
// work with ASCII files from a folder *
// *
// Programmer - Steve Croy 99/99/9999 *
//*******************************************************************
//*******************************************************************
// Modification log *
// *
// Date Programmer Description *
// *
//*******************************************************************
**------------ File section -----------------------------------------
Dcl-F ISI400DF WORKSTN UsrOpn
SFILE(ISI400S1:RRNSI)
INFDS(DSPDS) ;
**------------ Data Structures --------------------------------------
Dcl-DS *N ExtName('PGMSDSPF') PSDS ;
End-DS ;
Dcl-DS functionKey EXTNAME('MSTKEYSP') qualified ;
End-DS ;
Dcl-DS DSPDS ; // Workstation feedback
status *STATUS ;
opcode *OPCODE ;
fmtnam *RECORD ;
msgid char(7) POS(46) ;
keyPressed char(1) pos(369) ;
csrloc binDec(4:0) pos(370) ;
End-DS ;
//-- Prototype Copybooks
/copy qrpglesrc,ISIIFS_pr
/copy qrpglesrc,ISI001_pr
/copy qrpglesrc,mst0002_pr
//---
*------------ Define Global Variables ------------------------------
Dcl-S indPtr pointer inz( %addr(*in) ) ;
Dcl-DS indicators len(99) based( indPtr ) ;
ScreenChange ind pos(22) ;
SflControl ind pos(50) ;
SflDisplay ind pos(51) ;
SflInitialize ind pos(52) ;
SflClear ind pos(53) ;
SflEnd ind pos(54) ;
SflDelete ind Pos(55) ;
SflNxtChange ind pos(58) ;
SflMSGQdisplay ind pos(59) ;
End-DS ;
Dcl-DS #DFPOS INZ ; // default cursor position
#DFROW packed(2:0) INZ(8) ;
#DFCOL packed(3:0) INZ(17);
End-DS ;
Dcl-DS dftPgmMsgF ; // default message file
dftMsglib char(10) INZ('*LIBL') ;
dftMsgFile Char(10) INZ('CISMSGFILE');
End-DS ;
*------------ Define constants -------------------------------------
Dcl-C Title1 CONST('* Review Certificate Files *') ;
Dcl-C Title2 CONST('** Review Certified Files **') ;
*------------ Define Global Variables ------------------------------
Dcl-DS *N inz ;
dirArray char(208) dim(500) ;
dtSort zoned(8:0) overlay(dirArray:201) ;
End-DS ;
Dcl-S ErrorOccurred ind ;
Dcl-S listAction ind ;
Dcl-S MessageToDisplay ind ;
Dcl-S MoreRecordsRemain ind ;
Dcl-S NoMoreRecords ind ;
Dcl-S objectFound ind ;
Dcl-S AREA char(15) ;
Dcl-S ELEMENT char(25) ;
Dcl-S dspatr char(1) ;
Dcl-S MSG char(80) ;
Dcl-S MSGtxt char(80) ;
Dcl-S MSGDTA char(132) ;
Dcl-S MSGF char(10) ;
Dcl-S MSGPGM char(10) ;
Dcl-S MSGRLQ char(5) ;
Dcl-S PXERR char(7) ;
Dcl-S pXmode char(1) ;
Dcl-S thisFormat char(10) ;
Dcl-S typatr char(1) ;
Dcl-S UsrNam char(10) ;
Dcl-S Cl zoned(3:0) ;
Dcl-S RCDNBR int(5) INZ(1) ;
Dcl-S RRNSI binDec(4) ;
Dcl-S Rw zoned(3:0) ;
Dcl-S SAVRRN binDec(4) ;
Dcl-S SFLLOD binDec(4) ;
Dcl-S SFLMAX binDec(4) INZ(12) ;
Dcl-S SFLPOS binDec(4) ;
Dcl-S SFLRCN binDec(4) ;
Dcl-S SUBPGM CHAR(10) ;
Dcl-S x int(5) ; // array index
Dcl-S idx int(5) ; // array index
Dcl-S pos int(5) ; // position
Dcl-S lc int(5) ; // found lower case
Dcl-S uc int(5) ; // found upper case
Dcl-S objPath char(200) ;
Dcl-S objAction char(2) ;
Dcl-S objType char(15) ;
Dcl-S rtnID char(7) ;
Dcl-S dtaType char(15) ;
//*--------- End of work fields ---------------------------
Dcl-Pr CommandLine extpgm('QUSCMDLN') ;
End-Pr ;
Dcl-Pr getReviewFolder ExtPgm('ISI005RP') ;
csgArea char(15) ;
csgElement char(25) ;
csgValue char(200) ;
End-Pr ;
Dcl-Pr executeFunction ExtPgm(SUBPGM) ;
objPath char(200) ; // Object
objAction char(2) ; // Object action
objType char(15) ; // certificate
rtnID char(7) ; // Message ID (returned)
End-Pr ;
Dcl-Proc ISI400RP ;
Dcl-PI ISI400RP extPgm('ISI400RP') ;
END-PI;
If not %open(ISI400DF) ;
OPEN ISI400DF ;
ENDIF ;
jobnam = sdsjob ;
user = sdsuser ;
jobNbr = %editc(sdsjnbr:'X') ;
prgnam = sdsproc ;
area = 'POLICY' ;
element = 'CERTIFICATE' ;
z$seq1 = title1 ;
functionKey = getFunctionKeys();
getMessage('MIS0001') ;
resetDisplay() ;
DOU keyPressed = functionKey.F3;
IF MessageToDisplay;
SflMSGQdisplay = *ON;
ELSE;
SflMSGQdisplay = *OFF;
ENDIF;
WRITE ISI400C2 ; // write subfile message queue
IF ScreenChange;
#ROW = #DFROW;
#COL = #DFCOL;
ENDIF;
rrnsi = 0 ;
sflControl = *ON ; // Set subfile control on
IF sflrcn > 0 ; // and if records were loaded
sflDisplay = *ON ; // turn on subfile display
ENDIF ;
WRITE ISI40001 ;
EXFMT ISI400C1 ;
sflControl = *OFF ;
sflDisplay = *OFF ;
#ROW = csrloc / 256 ; // save row
#COL = %rem(csrloc : 256) ; // and column
IF MessageToDisplay ;
RmvMessage(prgnam) ;
MessageToDisplay = *OFF ;
ENDIF ;
SELECT ;
WHEN KeyPressed = functionKey.ENTER ;
processChanges() ;
READ ISI40001 ;
If ScreenChange ;
resetDisplay() ;
ENDIF ;
WHEN KeyPressed = functionKey.ROLLUP ;
loadSubfile() ;
WHEN KeyPressed = functionKey.ROLLDN ;
pageDown() ;
WHEN KeyPressed = functionKey.F3 ;
EndPgm() ;
WHEN KeyPressed = functionKey.F12 ;
EXSR returnToCaller ;
WHEN KeyPressed = functionKey.F5 ;
resetDisplay() ;
WHEN KeyPressed = functionKey.F11 ;
IF element = 'CERTIFIED' ;
element = 'CERTIFICATE' ;
z$seq1 = title1 ;
Else ;
element = 'CERTIFIED' ;
z$seq1 = title2 ;
EndIf ;
resetDisplay() ;
WHEN KeyPressed = functionKey.F21 ;
CommandLine() ;
EndSL ;
ENDDO;
//*----------------------------------------------------------------
BEGSR returnToCaller ;
If %open(ISI400DF) ;
CLOSE ISI400DF ;
ENDIF ;
*inlr = *on ;
return ; // return to caller
ENDSR ;
End-Proc ISI400RP ;
//*================================================================
Dcl-Proc resetDisplay ;
Dcl-PI resetDisplay end-PI ;
rrnsi = 1 ;
rcdnbr = 1 ;
sflrcn = 0 ;
sflpos = 0 ;
SflInitialize = *ON ;
WRITE ISI400C1 ;
SflInitialize = *OFF ;
SflEnd = *OFF ;
ThisFormat = fmtnam ;
usrnam = user ;
reset dftPgmMsgF ;
loadFileArray() ;
loadSubfile() ;
%subst(z$opt1:1) = 'MV=move to process' ;
%subst(z$opt1:21) = 'RJ=Reject files' ;
%subst(z$opt1:41) = 'VW=View Object' ;
%subst(z$opt2:01) = 'RN=Rename file' ;
%subst(z$opt2:21) = 'DL=Delete file' ;
%subst(z$opt2:41) = 'UP=Update Image' ;
%subst(z$key1:1) = 'F3=Exit' ;
%subst(z$key1:21) = 'F5=Refresh' ;
%subst(z$key1:41) = 'F11=POM/Certified' ;
%subst(z$key2: 1) = 'F12=Cancel' ;
%subst(z$key2:41) = 'F21=Command line' ;
Return ;
END-Proc resetDisplay ;
//*================================================================
Dcl-Proc pageDown ;
Dcl-PI pageDown end-PI ;
Z$RRN2 = Z$rrn2 - SFLMAX ;
SFLPOS = (SFLPOS - SFLMAX) ;
IF SFLPOS < 1 ;
SFLPOS = sflmax ;
ENDIF ;
IF Z$RRN2 < 1 ;
Z$RRN2 = 1 ;
getMessage('MIS0006') ;
ENDIF ;
Return ;
END-Proc pageDown ;
//*================================================================
Dcl-Proc loadSubfile ;
Dcl-PI loadSubfile end-PI ;
sfllod = 0 ;
savrrn = z$rrn2 ;
SflEnd = *OFF ;
NoMoreRecords = *OFF ;
DOU NoMoreRecords or sfllod >= sflmax ;
MoreRecordsRemain = NextObject() ;
IF MoreRecordsRemain ;
sflrcn = sflrcn + 1 ;
sfllod = sfllod + 1 ;
RRNSI = SFLRCN ;
Z$RRN1 =SFLRCN ;
z$opt = *BLANKS ;
uc = %scan('.PDF':zffnam) ;
lc = %scan('.pdf':zffnam) ;
If (uc + lc) > 0 ;
dspatr = SetColor('WHT') ;
Else ;
dspatr = SetColor('GRN') ;
EndIf ;
zffnam = dspatr + %trim(zffnam) ;
WRITE ISI400S1 ;
ELSE ;
Sflend = *ON ;
NoMoreRecords = *ON ;
ENDIF ;
ENDDO ;
sflpos = sflpos + sflmax ;
z$rrn2 = (sflpos - sflmax) + 1 ;
IF z$rrn2 > sflrcn ;
sflpos = sflpos - sflmax ;
z$rrn2 = savrrn ;
getMessage('MIS0007') ;
ENDIF ;
Return ;
END-Proc loadSubfile ;
//*================================================================
Dcl-Proc nextObject ;
Dcl-PI nextObject ind ;
End-PI ;
Dcl-S nextEntry ind ;
Dcl-S r int(5) ;
Dcl-S l int(5) ;
idx = sflrcn + 1 ;
l = 1 ;
zffnam = *blanks ;
if idx < 501 ;
ecvalu = dirArray(idx) ;
If ecvalu <> *blanks ;
DoU r = 0 ;
r = %scan('/':ecvalu:l) ;
If r > 0 ;
l = r + 1 ;
EndIf ;
EndDo ;
zffnam = %subst(ecvalu:l) ;
EndIf ;
EndIf ;
If ecvalu = *blanks ;
nextEntry = *off ;
Else ;
nextEntry = *on ;
EndIf ;
return nextEntry ;
END-Proc nextObject ;
//*=====================================================================
Dcl-Proc getMessage ;
Dcl-PI getMessage ;
thisMsg char(7) const ;
end-PI ;
msgID = thisMsg ;
msgdta = *BLANKS ;
msg = *BLANKS ;
msgf = dftMsgFile ;
MONITOR ;
RtvMessage(msgid:msgf:msgdta:msg) ;
msgtxt = msg ;
ON-ERROR ;
msgf = 'CISMSGFILE' ;
ENDMON ;
msgRlq = '*SAME' ;
msgdta = msgtxt ;
msgpgm = PRGNAM ;
SndMessage(msgid : msgF: msgdta : msgrlq : msgpgm) ;
MessageToDisplay = *ON ;
Return ;
END-Proc getMessage ;
//*=====================================================================
Dcl-Proc EndPgm ;
Dcl-PI *n end-PI ;
*inlr = *on ;
If %open(ISI400DF) ;
CLOSE ISI400DF ;
EndIf ;
Quit(0) ; // close activation group
Return ;
End-Proc EndPgm ;
//*=====================================================================
Dcl-Proc processChanges ;
Dcl-PI processChanges end-PI ;
IF Z$RRN1 > 0 ;
DOU %eof(ISI400DF) ;
READC ISI400S1 ;
listAction = *off ;
IF NOT %eof(ISI400DF) ;
IF Z$OPT <> *BLANK ;
listAction = *ON ;
ThisFormat = fmtnam ;
objPath = ecvalu ;
objAction = z$opt ;
objType = element ;
SELECT ;
WHEN z$opt = 'DL' ; // Delete the file
dspatr = SetColor('RED') ;
%subst(zffnam:1:1) = dspatr ;
*IN30 = *ON ;
SUBPGM = 'ISI405RP';
WHEN z$opt = 'MV' ; // Move to processing folder
dspatr = SetColor('BLU') ;
%subst(zffnam:1:1) = dspatr ;
*IN30 = *ON ;
SUBPGM = 'ISI405RP';
WHEN z$opt = 'RJ' ; // Reject file
dspatr = SetColor('RED') ;
%subst(zffnam:1:1) = dspatr ;
*IN30 = *ON ;
SUBPGM = 'ISI405RP';
WHEN z$opt = 'RN' ; // Rename file object
dspatr = SetColor('BLU') ;
%subst(zffnam:1:1) = dspatr ;
*IN30 = *ON ;
SUBPGM = 'ISI405RP';
WHEN z$opt = 'VW' ; // View file
dspatr = SetColor('BLU') ;
%subst(zffnam:1:1) = dspatr ;
SUBPGM = 'ISI405RP';
WHEN z$opt = 'UP' ; // Update image
dspatr = SetColor('GRN') ;
%subst(zffnam:1:1) = dspatr ;
SUBPGM = 'ISI410RP';
OTHER ; // Invalid option
z$opt = '**' ;
ENDSL ;
If z$opt <> '**' ;
executeFunction ( objPath
: objAction
: objType
: rtnID ) ;
EndIf ;
z$opt = *BLANK ;
z$rrn2 = z$rrn1 ;
UPDATE ISI400S1 ;
*IN30 = *OFF ;
ENDIF ;
ENDIF ;
ENDDO ;
ENDIF ;
Return ;
END-PROC processChanges ;
//*=====================================================================
Dcl-Proc loadFileArray ;
Dcl-PI loadFileArray end-PI;
Dcl-DS dirent based(p_dirent) ALIGN ;
d_reserv1 char(16) ;
d_fileno_gen uns(10) ;
d_fileno uns(10) ;
d_reclen uns(10) ;
d_reserv3 int(10) ;
d_reserv4 char(8) ;
d_nlsinfo char(12) ;
nls_ccsid int(10) OVERLAY(d_nlsinfo:1) ;
nls_cntry char(2) OVERLAY(d_nlsinfo:5) ;
nls_lang char(3) OVERLAY(d_nlsinfo:7) ;
nls_reserv char(3) OVERLAY(d_nlsinfo:10) ;
d_namelen uns(10) ;
d_name char(640) ;
End-DS dirent ;
Dcl-DS ArrayData ;
filePath char(200) ;
fileCreated zoned(8:0) ;
End-DS ArrayData ;
Dcl-DS statds BASED(p_stat) ALIGN ;
st_mode uns(10) ;
st_ino uns(10) ;
st_nlink uns(5) ;
st_uid uns(10) ;
st_gid uns(10) ;
st_size int(10) ;
st_atime int(10) ;
st_mtime int(10) ;
st_ctime int(10) ;
st_dev uns(10) ;
st_blksize uns(10) ;
st_allocsize uns(10) ;
st_objtype char(11) ;
st_codepage uns(5) ;
st_reserved char(62) ;
st_ino_gen_i uns(10) ;
End-DS statds ;
//--* Constants.
Dcl-C decalage const(18000) ;
Dcl-C #ROOT const('/') ;
Dcl-C #UP const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') ;
Dcl-C #LO const('abcdefghijklmnopqrstuvwxyz') ;
//--* Stand alone fields
Dcl-S p_dirent pointer ;
Dcl-S p_stat pointer ;
Dcl-S dh pointer ;
Dcl-S Path char(256) ;
Dcl-S Pathx00 char(256) ;
Dcl-S Name char(256) ;
Dcl-S Msg char(100) ;
Dcl-S rc int(10) ;
Dcl-S cmd char(256) ;
Dcl-S errno int(10) ;
Dcl-S error_p pointer ;
Dcl-s errmsg char(80) ;
Dcl-S w$iext char(4) ;
Dcl-S w$prfx char(4) ;
Dcl-S w$inam char(256) ;
Dcl-S w$ifsdte packed(8:0) ;
Dcl-S w$pos packed(3:0) ;
Dcl-S w$len packed(3:0) ;
Dcl-S w$path like(path:+1) ;
Dcl-S tPath like(path:+1) ;
Dcl-S tFile like(path:+1) ;
Dcl-S $$date date inz ;
Dcl-S a$date date inz ;
Dcl-S c$date date inz ;
Dcl-S m$date date inz ;
Dcl-S x$date date ;
Dcl-S w$date packed(8:0) ;
Dcl-S $$timestmp timestamp inz ;
Dcl-S $$epoch timestamp INZ ;
Dcl-S epochv char(26) INZ('1970-01-01-00.00.00.000000') ;
Dcl-S qt char(1) inz(x'7D') ;
Dcl-S returnValue char(200) ;
Dcl-S p$msgid char(7) ;
Dcl-S p$path char(200) ;
p$msgid = *blanks ;
clear dirArray ;
x = 0 ;
getReviewFolder(area:element:returnValue) ;
p$path = returnValue ;
w$path = p$path ;
$$epoch = %timestamp(epochv);
w$len = %len(%trim(p$path));
IF %subst(p$path:w$len:1) <> '/';
p$path = %trim(p$path) + '/';
ENDIF;
p_stat = %alloc(512);
w$path = %trim(w$path) + x'00';
dh = opendir(%addr(w$path)) ; // Open specified directory
IF dh = *NULL ; // If not found
x = 1 ;
dirArray(1) = 'No Review Directory found.' ;
p$msgid = 'CPFADFB' ; // set message and
Return ; // exit procedure
ENDIF ;
DOU p_dirent = *NULL ; // Read directory entries
p_dirent = readdir(dh) ;
If p_dirent <> *NULL ;
If d_namelen < 1024;
Name = %subst(d_name:1:d_namelen);
IF %trim(name) <> '.'
and %trim(name) <> '..'
and name <> *blanks ;
w$inam = name;
w$inam = %xlate(#LO:#UP:w$inam);
tpath = %trim(p$path) + %trim(Name) + x'00';
rc = stat(%addr(tpath):p_stat);
st_ctime = st_ctime - decalage;
$$timestmp = $$epoch + %seconds(st_ctime);
$$date = %date($$timestmp) ;
w$date = %dec($$date:*ISO) ;
filePath = %trim(p$path) + %trim(Name) ;
fileCreated = w$date ;
x += 1 ;
dirArray(x) = arrayData ;
EndIf ;
ENDIF;
ENDIF;
ENDDO;
If x < 1 ;
filePath = 'No files to review at this time.' ;
fileCreated = %dec(%date():*ISO) ;
x += 1 ;
dirArray(x) = arrayData ;
EndIf ;
SORTA %SubArr(dtSort:1:x);
error_p = strerror(errno);
errmsg = %str(error_p);
return ;
End-Proc loadFileArray ;