RPG Reading ASCII Files
RPG can manage EBCIDIC or ASCII data.
This is an example of an interactive program that reads a stream file 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. This ILE application uses the bound services to read the stream file, byte at a time, then displays the information on a 5250 display panel.
/TITLE ** Browse IFS Data *
H DEBUG(*YES)
H OPTION(*SRCSTMT : *NODEBUGIO) DFTACTGRP(*NO) ACTGRP('QILE')
H BNDDIR('QC2LE':'SC0000_BD')
********************************************************************
* Program Name - SC0600RP *
* *
* Function - This program was designed to browse IFS file *
* data in a subfile. *
* *
********************************************************************
*
FSC0600DF CF E WORKSTN SFILE(SC0600S1:RRN1)
F INFDS(DSPDS)
*
*================================================================
D FUNCTIONKEY E DS EXTNAME(SCKEYSPF) qualified Function keys
D PGMDS ESDS EXTNAME(SCPSTSPF) Pgm status map
D DSPDS E DS EXTNAME(SCDSPFPF) Display INFDS
D MACDS E DS EXTNAME(SCFUNCPF) INZ Key map
D Macro E DS extname(SCMACRPF)
D Function 30a overlay(Macro:1)
*
* * Prototypes and definitions for working with the IFS
*
/copy qrpglesrc,SC0000_pr
/copy qrpglesrc,SC0001_pr
*------------------------------------------------------------
* values for oflag parameter, used by open()
*------------------------------------------------------------
D O_APPEND s 10i 0 inz(75) Append to file
D O_CODEPAGE s 10i 0 inz(8388608) Convert by code page
D O_CREAT s 10i 0 inz(8) Create if not exist
D O_EXCL s 10i 0 inz(16) Exclusive create
D O_RDONLY s 10i 0 inz(1) Read Only - Oflag
D O_RDWR s 10i 0 inz(4) Read/Write - Oflag
D O_TEXTDATA s 10i 0 inz(16777216) Open in text mode
D O_TRUNC s 10i 0 inz(64) Truncate to 0 bytes
D O_WRONLY s 10i 0 inz(2) Write only - Oflag
*------------------------------------------------------------
* user authorities for omode parameter, used by open()
* from QSYSINC/SYS, member STAT
*------------------------------------------------------------
* Owner authorities
D S_IRUSR s 10i 0 inz(72)
D S_IWUSR s 10i 0 inz(128)
D S_IXUSR s 10i 0 inz( 64)
D S_IRWXU s 10i 0 inz(448)
* group authorities
D S_IRGRP s 10i 0 inz( 32)
D S_IWGRP s 10i 0 inz( 16)
D S_IXGRP s 10i 0 inz( 8)
D S_IRWXG s 10i 0 inz( 56)
* other authorities
D S_IROTH s 10i 0 inz( 4)
D S_IWOTH s 10i 0 inz( 2)
D S_IXOTH s 10i 0 inz( 1)
D S_IRWXO s 10i 0 inz( 7)
*
D RdIfsFil PR 40A
D FileName 40A CONST
D*CodePage S 10u 0 inz(437)
D CodePage S 10u 0 inz(819)
D Data_Rec S 75A
D Eol C Const(x'0D25')
D Error_Flag S 1A INZ('0')
D File S 40
D FileName S 40
D Fp S 10i 0
D N S 5 0
D Oflag S 10i 0
D Omode S 10u 0
D R S 5 0
D Rc S 10i 0
D Rrn1 S 10i 0
D rtnCode S 10i 0
d indPtr s * inz( %addr(*in) )
* define named indicators
d indicators ds 99 based( indPtr )
d ScreenChange n overlay( indicators : 22 )
d SflControl n overlay( indicators : 50 )
d SflDisplay n overlay( indicators : 51 )
d SflClear n overlay( indicators : 52 )
d SflInitialize n overlay( indicators : 53 )
d SflEnd n overlay( indicators : 54 )
d SflDelete n overlay( indicators : 55 )
d SflNxtChange n overlay( indicators : 58 )
d SflMSGQdisplay...
d n overlay( indicators : 59 )
D authl S 3 inz('999')
D CATEG S 3S 0 inz(999)
D CMDKEY S 720
D MSG S 80
D MSGDTA S 132
D MSGF S 10
D MSGPGM S 10
D MSGRLQ S 5
d MessageToDisplay...
d S n
D M S 3S 0
D thisFormat S 10
D thisPgm S 10
D UsrNam S 10a
D #TITLE C CONST('** Browse IFS File **')
D #MSGF C CONST('SCMSSGF')
D #SAME C CONST('*SAME')
*---------------------------------------------------------
* MAIN
*---------------------------------------------------------
/free
functionKey = FunctionKeys();
z$seq1 = #TITLE;
MSGID = 'MIS0001';
ThisPgm = prgnam;
EXSR @GetMsg;
EXSR @Reset;
DoU function = 'EXIT';
IF MessageToDisplay;
SflMSGQdisplay = *ON;
ELSE;
SflMSGQdisplay = *OFF;
ENDIF;
WRITE SC0600C2; // Write subfile message queue
WRITE SC060001;
sflControl = *ON;
IF rrn1 > 0;
sflDisplay = *ON;
ENDIF;
EXFMT SC0600C1;
sflControl = *OFF;
sflDisplay = *OFF;
Function = *blanks;
ThisFormat = fmtnam;
GetFunction(thisPgm:thisFormat:keypressed:fkeyid:macro:authl);
SELECT;
WHEN Function = 'RESET';
EXSR @RESET;
WHEN Function = 'EXIT';
*INLR = *ON;
RETURN;
WHEN keyPressed = functionKey.ENTER;
IF xFile > *blanks;
EXSR @Reset;
error_Flag = RdIFSfil(xFile);
IF error_Flag = '1';
rrn1 = rrn1 + 1;
IF rrn1 = 1;
data = '*File not found in IFS';
ELSE;
data = '*** End of IFS Data ***';
ENDIF;
WRITE SC0600S1;
ENDIF;
ENDIF;
ENDSL;
ENDDO;
*INLR = *ON;
RETURN;
//*-----------------------------------------------------------
//* Initialize subfile and display empty subfile
//*-----------------------------------------------------------
Begsr @Reset;
sflClear = *ON;
WRITE SC0600C1;
sflClear = *OFF;
SflEnd = *Off;
rrn1 = 0;
m = 0;
usrnam = user;
GetKeyText(thisPgm:thisFormat:cmdkey:authl);
DisplayKeys(cmdkey: z$key1: z$key2: M);
Endsr;
//*=====================================================================
//* Get message text from message file and turn on message flag
//*=====================================================================
BEGSR @getmsg;
msgdta = *BLANKS;
msg = *BLANKS;
msgf = #MSGF;
MONITOR;
RtvMessage(msgid:msgf:msgdta:msg);
ON-ERROR;
MessageToDisplay = *ON;
ENDMON;
msgtxt = msg;
EXSR @SendMessage;
ENDSR;
//*=====================================================================
//* Subroutine to send messages to program message queue
//*=====================================================================
BEGSR @SendMessage;
msgdta = msgtxt;
msgpgm = PRGNAM;
msgrlq = #SAME;
msgf = #MSGF;
SndMessage(msgid:msgf:msgdta:msgrlq:msgpgm);
MessageToDisplay = *ON;
ENDSR;
/end-free
*=============================================================
* RdIfsFil - Subprocedure To Read The IFS File
*=============================================================
P RdIfsFil B Export
D RdIfsFil PI 40A
D FileName 40A Const
D CharsRead S 10i 0
D CurChar S 1
D Eof C const(x'00')
/free
Oflag = O_Rdonly + O_Textdata;
File = %trim(FileName) + x'00';
Fp = openIFS(%addr(File): Oflag);
IF Fp < 0;
Error_Flag = *On;
Return Error_Flag;
Endif;
R = 0;
N = 0;
DoU CurChar = Eof;
// Limit to 9999 lines
IF RRN1 >= 9998;
leave;
ENDIF;
EXSR GetChar;
R += 1;
%Subst(Data: R: 1) = CurChar;
IF curChar = x'25';
%Subst(Data: R: 1) = *blanks;
ENDIF;
SELECT;
When R = 75 or CurChar = X'25';
//* if you find the lf code then we still have more data in
//* memory and we need to process that remaining data.
IF CurChar = X'25';
%Subst(Data: R: 1) = *blanks;
ENDIF;
EXSR Write_Sfl;
CLEAR R;
CLEAR Data;
OTHER;
ENDSL;
ENDDO;
//* Write last line and close the IFS File (seton subfile end)
*In99 = *On;
Exsr Write_Sfl;
rtnCode = CloseIFS(Fp);
Return Error_Flag;
//*----------------------------------------------------
//* GetChar - Process IFS Record, One Character At A Time
//*----------------------------------------------------
Begsr GetChar;
//* If input buffer is empty, or all characters have been
//* processed, refill the input buffer.
IF n = charsRead;
charsRead = readIFS(fp:%addr(Data_Rec): 75);
n = 0;
ENDIF;
//* Get the next character in the input buffer.
IF CharsRead <= 0;
CurChar = Eof;
ELSE;
n +=1;
CurChar = %Subst(Data_Rec: N: 1);
ENDIF;
ENDSR;
//*-------------------------------------------------------------
//* Write_Sfl - Write Subfile Record
//*--------------------------------------------------------
BEGSR Write_Sfl;
rrn1 += 1;
WRITE SC0600S1;
ENDSR;
/end-free
P RdIfsFil E