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 ;