RPG-ILE LABS
NAV IGA TI ON CHA RT
DAY 1
DAY 2
DAY3
DAY 4
COMPARISON CHART
COMPILER DIRECTIVE
Data Type Conversion
TESTING
CHEAT SHEETS
ADVANCED DATABASE PROCESSING
PROCEDURES and MODULES. Bind by COPY and REFERENCE
LOGIC CYCLE
FEATURES
FLAT PHYSICAL FILE SERVICE PROGRAM
PROJECT
BINDER LANGUAGE
SIX DAYS BREAKUP
EMBEDDED SQL OPERATION EXTENDERS
API
BASICS
RLU
I Specs ARRAYS BUILT IN FUNCTIONS
DATA Q PROGRAMMING
MISC
DATA AREA
ERROR HANDLING*
POINTERS
DATE TIME PROGRAMMING
MESSAGING
FREE
NEW KEYWORDS
MONITOR
KA and KB indicators ODP
ACTIVATION GROUP
HUB ILE coding style Memorc
DATA STRUCTURES SUBFILES STRING OPERATION
VALIDATION
1
RPG-ILE LABS
DISPLAY FILES
SMALL UTILITY PROJECT (imp
Indicator data structure
PROJECT
!!!)
DATABASE PROCESSING
2
RPG-ILE LABS
SIX DAYS BREAKUP Day
1
Remarks
Coverage COMPARISON CHART FEATURES CHEAT SHEETS OPERATION EXTENDERS BASICS ARRAYS BUILT IN FUNCTIONS DATE TIME PROGRAMMING DATA STRUCTURES
2
DATA AREA STRING OPERATION VALIDATION SUBFILES API RLU
3
DISPLAY FILES
4
5 6
COMPILER DIRECTIVE Data Type Conversion
ADVANCED DATABASE PROCESSINGERROR HANDLING ODP PROCEDURES and MODULES. Bind by COPY and REFERENCE SERVICE PROGRAM BINDER LANGUAGE ACTIVATION GROUP DATA Q PROGRAMMING MESSAGING EMBEDDED SQL LOGIC CYCLE MONITOR TESTING POINTERS FREE SMALL UTILITY PROJECT (imp !!!)
Assignments
3
RPG-ILE LABS
SMAL L UTILI T Y PR O JEC TS 1. 2. 3. 4.
( Use ILE built in functions where possible. )
Utility to accept object name from user and display locations where the sources of the object are present. Compare utility : Compare contents of 2 members of a source physical file and produce a report. Utility to locate all libraries where specified object is present and write the libraries to a physical file. Utility to locate source member and source physical file of the specified object and store it to a database file. Following report should be created :Objec t Name PF001
PF002
Object Library L1 L2 L3 L4 L11 L22
Src.
P F.
MySRC SamSRC SamSRC QDBHSRC MySRC EMOSRCDBF
Sr c. Member Names PF001 PF001 PFCUST CUSTDATA MPF001 PF002
Sou rce Library Lib002 Lib003 Lib001 L4 GHOHUBSPH GHOHUBCPH
5.
Utility to display all members of a source PF. User selects a few members. Combine all members and store them to a new member (name specified by user). The data for each member should be easily identifiable.
6.
Write a utility to accept member name and type from user and set of libraries to search. After user finishes entering the libraries (or asks you to refer to the library list), search each for presence of that member (search all source physical files in the library) for presence of that member.
7. 8.
RPGLE editor : Create a simple multi-Document Editor, which behaves like Notepad. (Notepad /400 ! ) A utility to display all physical and logical files containing XXXX entered by user ( eg. : User enters “FSTS” as a search string. The utility scans the library list / list of libraries specified by user and displays names and libraies of all Physical files and logical files containing the specified field name.)
9.
Utility to display all source physical files present in all libraries in the library list and write the list to a database.
File compi la tion u til ity 1.
2.
A Physical file P1 may have several logical files (say L1,L2,L3,L4 … ) based on it. Programmer makes a change to DDS of the Physical file and updates the PF object using CHGPF. This does not automatically update the LFs sicne they all use old definition. To update all Logical files, you need to compile all of them. This can get quite tedious. Build a utility to automatically determine and compile all the logical files.
Write a Utility to read source code of a program (member name will be specified by user) and write it to a spool file after indenting it. Indentation will be provided to IF statements and Do loops. ** *
4
RPG-ILE LABS 1. P ROJ ECT S 1.
A new module is to be developed for a bank. The module is for Calculation of interest on Saving A/c. It should allow inputing new customer, and saving any transactions done by the customer. For formula of calculating interest , see EPM.
2.
5
RPG-ILE LABS
RPG - IL E LA BS LAB : Source Physical file : QRPGLESRC
LAB : Study of new Specs : HFDICOP. Structure and purpose of each. New Spec : CX. F : SPEC :
6
RPG-ILE LABS
LAB : Data Types in RPGLE.Member type and compilation commands. A B D F G I P S T U Z *
: : : : : : : : : : : :
LAB
Character fixed Binary date Field Floating point Graphics character set Signed Integer Packed Decimal Zoned Field Time field Unsigned Integer Field Timestamp Field Pointer Field : Introduction of RPG programing. Declaring Variables in RPG. DA01 C*
S
2P 0 Inz(-1)
7
RPG-ILE LABS C C* C
A01
DSPLY EVAL
*INLR = *ON
DCON1 C CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ+ D cdefghijklmnopqrstuvwxyz') C CON1 DSPLY C EVAL *INLR = *ON LAB : RPG Constructs IF, DOW, DO, DOU,LEAVE ,ITER. * Declare a variable.Display a string,float and integer * ===================================================== Djsr S 20A Djsr1 S 20A C EVAL jsr1= 'string1' C EVAL jsr = 'string2' C if jsr1 <> jsr C EVAL jsr1='xx' C endif C jsr1 DSPLY C EVAL *INLR = *ON LAB : DO WHILE * (DEMO OF DO WHILE LOOP) DN S C DOW C EVAL C N IFEQ C ITER C ENDIF C N DSPLY C ENDDO C EVAL Output : 1 3 4
Output :
5i 0 N <=4 N=N+1 2
*INLR = *ON
1 2 3 4 5
LAB : ROUNDING RESULTS OF CALCULATION LOGIC : 1.124 + 0.001 ----1.13 (ROUNDED) 1.12 (NOT ROUNDED) DISPLAY FILE DDS : A A R R1 A
DSPSIZ(24 80 *DS3) 5
9'WITHOUT ROUNDING : '
8
RPG-ILE LABS A A A
DTOTAMT1 DTOTAMT2
5Y 2B 5Y 2B
7 9'WITH ROUNDING : ' 5 30EDTCDE(Q) 7 30EDTCDE(Q)
RPGLE PROGRAM : FDSRND CF E WORKSTN DCRS S 5S 3 INZ(1.121) DRATE S 5S 3 INZ(0.001) DTOTAMT1 S 5S 2 INZ(0) DTOTAMT2 S 5S 2 INZ(0) C DO 5 C EVAL TOTAMT1 = RATE + CRS C* now try with (H) for Rounding. C EVAL(H) TOTAMT2 = RATE + CRS C EVAL DTOTAMT1 = TOTAMT1 C EVAL DTOTAMT2 = TOTAMT2 C EXFMT R1 C EVAL RATE = RATE + 0.001 C ENDDO C SETON
LAB
LR
: Interactive Source Debugger
Step 1 : Compile the program with Debugging Views set to *SOURCE. This allows the Debugger to access the source code of the program and display it. Step 2 : Use STRDBG and press F4. *YES. Press Enter.
Specify “Display Module Source “ parameter as
Step 3 : The Source code will be displayed. Take the cursor to the line that needs a break point and press F6.
In the Figure above, the break point is set at Line 2. Perss F10 to to exit out and call the LE02 program. It is displayed in the debugger. The control will be at first executable line. Press F10 to step through the code.
9
RPG-ILE LABS To Display the current value of a variable : Bring the cursor under the variable and press F11. Press F3 to exit Debugger. Issue the ENDSBG command to end the Debug mode.
LAB : LEAVESR
: to leave a Sub routine !
Linkage : RPLEAVE CODE : da s 4s 0 inz(4) d c 'BEfore SR' dsply c ExSR SR001 c 'After SR' Dsply c Eval *inlr = *on c Return c* c SR001 BegSR c 'SR starting' Dsply c if a = 4 c LeaveSR c EndIf C* ---------------------------------------C* The following line never gets executed ! C* ---------------------------------------c 'Ending SR' Dsply c EndSR PF contents : --OUTPUT DSPLY DSPLY DSPLY
: BEfore SR SR starting After SR
REMARKS : LeaveSR is to leave the currently executing SR.
LAB : For loop dn1 d d d d c c c c c
s
n1
4s 0 inz(0)
For dsply EndFOr Eval Return
n1= 10 DOWNTO 1
by 2
*inlr = *on
10
RPG-ILE LABS
If n1 increments : c
For
n1= 1 TO 10
by 2
For
n1= 10 DOWNTO 1
If n1 decrements : c
by 2
in both cases the step size is 2.
11
RPG-ILE LABS
Lab : H-SPECS H DATFMT(*YMD) DJSRDT1 C JSRDT1 C
S
D
INZ(D'04/12/10')
DSPLY SETON
LR
H DATFMT(*YMD) CURSYM('£') H* ALT 156 FOR POUND SIGN H* DJSRDT1 S DCIH S C JSRDT1 DSPLY C CIH DSPLY C SETON
D INZ(D'04/12/10') 7P 2 INZ(120.25) LR
VALID DATE FORMATS : *iso,mdy,*ymd,*jul,*usa,*jis,*eur VALID TIME FORMATS: *HMS *USA *EUR *JIS SPECIFYING THE SEPERATOR FOR THE DATE FORMAT : (SEE THE ONLINE HELP - EXCELLENT !) H DATFMT(*DMY-) H* date format is DMY and seperator char is - (dash) DDT1 S D INZ(D'12-12-04') c DT1 DSPLY c SETON
LR
LAB : USING OVERLAY FOR DATES DDT1 DDAT1 DDATY DDATM DDATD C C C C C C
DS D 4 2 2 DT1 DAT1 DATY DATM DATD
DATFMT(*ISO-) INZ(D'1994-06-16') OVERLAY(DAT1:1) OVERLAY(DAT1:6) OVERLAY(DAT1:9)
DSPLY DSPLY DSPLY DSPLY DSPLY SETON
LR
LAB : Working with dates HDATFMT(*DMY) ddt1 s c adddur c adddur c adddur c dt1 dsply c* output is 04/07/07 c eval
8D inz(D'01/04/04') 3:*days dt1 3:*months dt1 3:*Years dt1 *inlr=*on
HDATFMT(*DMY)
12
RPG-ILE LABS ddt1 ddt2 c c c* c
s s dt1 dt2
adddur dsply eval
8D inz(D'01/04/04') 8D inz(D'01/03/03') 3:*days dt2 *inlr=*on
EXAMPLE 3 : SUBtract duration HDATFMT(*DMY) ddt1 s ddt2 s c dt1 subdur c dt2 dsply c* Output : 29/03/04 c eval HDATFMT(*DMY) ddt1 s ddt2 s dn s c dt1 adddur c dt2 dsply c* Output : 01/02/04 c dt2 adddur c dt2 dsply c* Output : 03/03/04 c eval HDATFMT(*DMY) dds1 dd dsep1 dm dsep2 dy ddt1 c c d c m c y c
8D inz(D'01/04/04') 8D inz(D'01/03/03') 3:*days dt2 *inlr=*on
8D inz(D'01/01/04') 8D 2s 0 inz(31) n:*days dt2 n:*days
dt2
*inlr=*on
ds
s movel dsply dsply dsply eval
2s 0 1a 2s 0 1a 2s 0 8D inz(D'15/02/04') dt1 ds1
*inlr=*on
LAB : SUBDUR H TIMFMT(*HMS:) DDS1 DSTARTTM DENDTM DH1 DH2 DM1 DM2 DTOTTIME C STARTTM C ENDTM C H1 C H2
DS T T 2S 2S 2S 2S T
S
0 0 0 0
INZ(T'07:00:00') INZ(T'10:21:00') OVERLAY(STARTTM:1) OVERLAY(ENDTM:1) OVERLAY(STARTTM:4) OVERLAY(ENDTM:4) INZ(T'00:00:00')
DSPLY DSPLY DSPLY DSPLY
13
RPG-ILE LABS C C C C C C
M1 M2 ENDTM
DSPLY DSPLY SUBDUR SUBDUR DSPLY SETON
TOTTIME
H1:*H M1:*MN
TOTTIME TOTTIME LR
OUTPUT : 03:21:00 LAB
: SUBDUR
H TIMFMT(*HMS:) DSTARTTM DENDTM DH1 DM1 C STARTTM C ENDTM C ENDTM C ENDTM C H1 C M1 C
S S S S
T INZ(T'07:00:00') T INZ(T'10:50:00') 3S 0 3S 0 DSPLY DSPLY SUBDUR SUBDUR DSPLY DSPLY SETON
STARTTM STARTTM
H1:*H M1:*MN LR
OUTPUT : DSPLY 07:00:00 DSPLY 10:50:00 DSPLY 3 DSPLY 230 LAB : SUBDUR H DATFMT(*DMY/) DSTARTDT DENDDT DDAYS C ENDDT C DAYS C
S S S SUBDUR DSPLY SETON
D INZ(D'10/12/04') D INZ(D'15/12/04') 3S 0 STARTDT DAYS:*D LR
OUTPUT : 5 LAB : ADDDUR H DATFMT(*DMY/) DSTARTDT DENDDT DDAYS C STARTDT C ENDDT C OUTPUT
S S S ADDDUR DSPLY SETON
D INZ(D'10/12/04') D 3S 0 INZ(25) DAYS:*D ENDDT LR
:
04/01/05 LAB : ACCESSING SYSTEM DATE H DATFMT(*DMY/)
14
RPG-ILE LABS DENDDT C C ENDDT C
S MOVE DSPLY SETON
D *DATE
DATFMT(*DMY) ENDDT LR
OUTPUT : CURRENT SYSTEM DATE LAB : Extracting date,month year fromdate H DATFMT(*ISO) DDT1 DTR C C TR C
S S EXTRCT DSPLY EVAL
D INZ(D'2004-12-10') 4S 0 INZ(0) DT1:*Y TR *INLR = *ON
LAB : TEST opcode to test validity of Date, time and Timestamp H DATFMT(*ISO) DDT1 S D INZ(D'2004-12-10') DDT2 S 6S 0 INZ(041312) DTR S 4S 0 INZ(0) C TEST DT1 C* ____________________________ C* If date is not a valid date C* with *ISO format, C* IND 55 is TURNED ON. C* ____________________________ C IF *IN55 = *OFF C 'dt1 valid' DSPLY C ENDIF C* OUTPUT : DT1 VALID C* Repeat this test for C* DT2 C* --------------------C *YMD TEST(D) DT2 C* ----------------------C* This date is not valid. C* ----------------------C IF *IN55 = *OFF C 'DT2 valid' DSPLY C ENDIF C EVAL *INLR = *ON
55
55
Notes : 1. 2. 3. 4.
No need to specify *YMD or any other format in Factor 1, if the variable to be tested is defined as Date/Time. Also OPERATION EXTENDER is not required if the variable to be tested is of TYPE DATE TIME or TIMESTAMP. IF a character or numeric variable is to be tested, specify the format in Factor 1. While testing DT1, the format for date is taken as *ISO. While testing DT2, Format is taken from factor 1 and tested against the contents of DT2. The month specified here is 13, which is not valid for a month value. So indicator 55 is turned ON.
TESTING VALIDITY OF TIME
15
RPG-ILE LABS H TIMFMT(*ISO) DTM1 S DTM2 S C TEST C IF C 'TM1 valid' DSPLY C ENDIF C* OUTPUT : TM1 VALID C* Repeat this test for C* TM2 C* --------------------C *HMS TEST(T) C* ----------------------C* This TIME is not valid. C* ----------------------C IF C 'TM2 valid' DSPLY C ENDIF c TM1 dsply c TM2 dsply C EVAL
T INZ(T'10.12.14') 6S 0 INZ(101214) TM1 *IN55 = *OFF
TM2
55
55
*IN55 = *OFF
*INLR = *ON
TESTING VALIDITY OF TIMESTAMP H TIMFMT(*ISO) DTS1 S C TEST C IF C 'TS1 valid' DSPLY C ENDIF C* OUTPUT : TS1 VALID c TS1 dsply C EVAL
Z
INZ(Z'2004-12-10-10.12.20.000000') TS1 55 *IN55 = *OFF
*INLR = *ON
LAB: Program to calculate days between 2 dates. Program accepts date values into fields with edit code of Y. If a wrong date is unput by the user, control directly enters PSSR. Better approach of accepting dates is previous lab. RPGLe program RPDATE1 : H DATFMT(*DMY) H* PROGRAM TO CALCULATE PENALTY. ISSUES DATE AND RECPT DATE ARE H* ARE ACCEPTED. IF THE RECPT DATE IS 7 DAYS OR LESS, NO PENALTY. H* FOR EVERY ADDITIONAL DAY, PENALTY IS Rs 5/- PER DAY. H* ---------------------------------------------------------------H* FDSPENAL CF E WORKSTN F* DNODATE S 6S 0 INZ(0) DNOTIME S 6S 0 INZ(0) DDELTA S 4S 0 INZ(0) DISDAT S D INZ(D'01/01/01') DRCDAT S D INZ(D'01/01/01') C DOW *IN03 = *OFF C IF *IN03 = *ON C EVAL *INLR = *ON
16
RPG-ILE LABS C RETURN C ENDIF C* C MOVE NODATE DISDAT C MOVE NODATE DRCDAT C EXFMT RDATE C SETOFF C MOVE DISDAT ISDAT C MOVE DRCDAT RCDAT C RCDAT SUBDUR ISDAT DELTA:*D C EVAL DELTA = DELTA - 7 C IF DELTA<0 C EVAL DPENAL = 0 C ITER C ENDIF C* C DELTA MULT 5 DPENAL C GONXT TAG C ENDDO C EVAL *INLR = *ON C RETURN C* --------------------------------------------------C *PSSR BEGSR C SETON C GOTO GONXT C ENDSR
7778
7778
Display file listing : DSPENAL A A A A A A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) CA03(03) R RDATE DISDAT 77 DRCDAT 78 DPENAL
6 4'ISSUE DATE :' 8 4'RECPT DATE : ' 6Y 0B 6 19EDTWRD(' / / EDTMSK(' & & COLOR(WHT) ERRMSG('INVALID 6Y 0B 8 19EDTWRD(' / / EDTMSK(' & & COLOR(WHT) ERRMSG('INVALID 12 4'PENALTY AMOUNT 4Y 0O 12 23EDTCDE(3) COLOR(RED) 12 29'Rs'
') ') DATA') ') ') DATA') : '
LAB : Loading date values to Physical file : Physical File: PFDATE RPG : RPDATE Display : DSDATE RPDATE Listing : H DATFMT(*DMY)
17
RPG-ILE LABS H* PROGRAM LOADS DATA INTO THE PFDATE PF. IT ACCEPTS 2 DATE VALUES H* AND 2 TIME VALUES. THE VALIDATION OF THE VALUES IS DEFAULT BY H* VIRTUE OF THEIR TYPE. NO VALIDATION SPECIFIED IN THE DISPLAY H* FILE. IF WRONG DATA ENTERED, THE CONTROL GOES INTO PSSR. H* CONTROL GOES INTO PSSR DURING A MOVE OPERATION, WHEN DDATE H* IS BEING MOVED INTO DATE FIELD. H* PSSR CAN DO OUTRAGEOUS THINGS LIKE ENTERING DOW LOOP USING A GOTO H* Program also performs auto generation of CODE value so that next H* record gets a code higher by 1 as comared to the previos rec code. H* ----------------------------------------------------------------FPFDATE UF A E DISK FDSDATE CF E WORKSTN F* DNODATE S 6S 0 INZ(0) DNOTIME S 6S 0 INZ(0) DCD S 4S 0 INZ(0) C EXSR AUTOGENCODE C READ BTIME 44 C DOW *IN03 = *OFF C MOVE NODATE DDATE1 C MOVE NODATE DDATE2 C MOVE NOTIME DTIME1 C MOVE NOTIME DTIME2 C EXFMT RDATE C MOVE DDATE1 DATE1 C MOVE DDATE2 DATE2 C MOVE DTIME1 TIME1 C MOVE DTIME2 TIME2 C ADD 1 CD C Z-ADD CD CODE C WRITE BTIME 77 C UNLOCK PFDATE C END1 TAG C ENDDO C* --------------------------------------------------C EVAL *INLR=*ON C RETURN C AUTOGENCODE BEGSR C *HIVAL SETLL BTIME C READP(N) BTIME 44 C Z-ADD CODE CD C 1 SETLL BTIME C ENDSR C* C *PSSR BEGSR C 'PSSR' DSPLY C DSP_MAJOR DSPLY C DSP_MINOR DSPLY C GOTO END1 C ENDSR Display file DSDATE : A A A A A A
DSPSIZ(24 80 *DS3) CA03(03) R RDATE 3 14'BOTH DATES AS FOLLOWS :' COLOR(WHT) DSPATR(UL)
18
RPG-ILE LABS A A A A A A A A A A A A A A A
DDATE1
6Y 0B
DDATE2
6Y 0B
DTIME1
6Y 0B
DTIME2
6Y 0B
5 14'DATE 1 :' 7 14'DATE 2 :' 10 14'BOTH TIME VALUES AS FOLLOW COLOR(WHT) DSPATR(UL) 12 15'TIME 1 : ' 14 15'TIME 2 : ' 5 25EDTWRD(' - - ') EDTMSK(' & & ') 7 25EDTWRD(' - - ') EDTMSK(' & & ') 12 25EDTWRD(' : : ') EDTMSK(' & & ') 14 25EDTWRD(' : : ') EDTMSK(' & & ')
Lisiting if PFDATE : A A A A A A
R BTIME CODE DATE1 DATE2 TIME1 TIME2
4S 0 L L T T
Only program is that of control goes into PSSR , I cannot say exactly which MOVE operation forced it into the PSSR. This way, you canot tell which field to high light. LAB : Time and Time stamp validation Rpgle listing : RPTIME H TIMFMT(*HMS) H* ------------------------------------------------------FDSTIME CF E WORKSTN DTM1 S T INZ(T'00:00:00') C* DISPLAY TIME DISPLAY FILE AND INPUT TIME FROM THE USER C* CHECK IF THIS TIME IS VALID. C* ------------------------------------------------------C DOW *IN03 = *OFF C MOVE *ZEROS DTIMEFLD C EXFMT RTIME C *HMS TEST(T) DTIMEFLD C IF *IN77 = *ON C EVAL *IN77 = *OFF C 'INCORRECT' DSPLY C ITER C ENDIF C *HMS MOVE DTIMEFLD TM1 C TM1 DSPLY C ENDDO C EVAL *INLR = *ON Display file listing A A A
77
DSTIME : DSPSIZ(24 80 *DS3) CA03(03)
R RTIME
19
RPG-ILE LABS A A A A A A A A A A
4 6 DTIMEFLD
6Y 0B
6 7 7
8'ENTER A TIME VALUE TO BE T COLOR(BLU) 13'===>' COLOR(WHT) 19EDTWRD(' : : ') EDTMSK(' & & ') COLOR(WHT) 19'hh mm ss' 9'Format :-' COLOR(BLU)
LAB : Calculate Time difference H* PROGRAM TO CALCULATE THE TIME DIFFERENCE BETWEEN 2 TIME VALUES. H* -------------------------------------------------------------H* Assumes that Factor 1 tim e value is greater than Factor 2 time H* value. h* -------------------------------------------------------------h* H TIMFMT(*HMS) DT1 s T INZ(T'07:15:30') DT2 S T INz(T'10:10:05') DRslt S T INz(T'00:00:00') DSEC S 10S 0 INZ(0) D* C* C T2 SUBDUR T1 SEC:*S C Rslt Adddur sec:*S Rslt C 'Diff Is : ' DSPLY C Rslt DSPLY C EVAL *INLR = *ON C* Output : 2:54:35 LAB : Read date and time data from PF which stores data as date and time. Create a PF called PFDAT in QGPL. DDS as follows : A* DATE AND TIME PROCESSING A* DATE IS STORED HERE A* -----------------------A R RDATE A BCODE 4S 0 A DISSUE L A DRETURN L A TISSUE T A TRETURN T
DATFMT(*DMY) DATFMT(*DMY) TIMFMT(*HMS) TIMFMT(*HMS)
STRSQL and F4 : Specify DATFMT as *DMY and press ENTER. Use INSERT SQL stmt to insert some sample values into PFDAT. Create a display file DSDAT with fields : DDISSUE,DDRETURN,DTISSUE, DTRETURN with ‘Y’ as edit code. (created as +9(8) and then edit code Y is applied). Write following RPDAT program to load the data into RPGLE and display it. H Datfmt(*DMY/) TimFmt(*HMS:) FPFdat If E Disk FDSdat CF E Workstn c Do 1
Display file fields
20
RPG-ILE LABS c c DIssue c* DReturn c TIssue c* TReturn c c use EVAL ! c c c c c
Read dsply dsply dsply dsply Movel Movel
RDate
DIssue DReturn
DDIssue DDreturn
Movel Movel Exfmt EndDo Eval
TIssue TReturn R1
DTIssue DTReturn
// dont
*inlr = *on
OUTPUT : DSPLY DSPLY Date Time
24/12/05 09:45:00 of issue : of issue :
24/12/0500 9/45/0000
___ Display file output ⌡
LAB : Using Date in IF statement. H Datfmt(*DMY/) TimFmt(*HMS:) FPFdat If E Disk c Do 1 c Read RDate c DIssue dsply c TIssue dsply c If DIssue = d'24/12/05' c '24 DEC 2005' Dsply c Endif c EndDo c Eval *inlr = *on c Return
LAB : PASS DATE TIME BY Reference to a prceodure H* PROGRAM TO CALCULATE THE TIME DIFFERENCE BETWEEN 2 TIME VALUES. H* -------------------------------------------------------------H* Assumes that Factor 1 tim e value is greater than Factor 2 time H* value. h* -------------------------------------------------------------h* H TIMFMT(*HMS) DFind_Difference PR DT1 T DT2 T DRslt T DT1 s T INZ(T'07:15:30') DT2 S T INz(T'10:10:05') DRslt S T INz(T'00:00:00') D* C CAllp Find_Difference(T1:T2:Rslt) C Rslt DSPLY
21
RPG-ILE LABS C Eval *inlr = *on C Return C* C* ------------------------------------------------------PFind_Difference B DFind_Difference PI DT1 T DT2 T DRslt T DTempTime S T INZ(T'00:00:00') DSec S 10s 0 inz(0) C T2 SUBDUR T1 SEC:*S C TempTime Adddur sec:*S TempTime C MOVE TempTime Rslt PFind_Difference E LAB : *NOPASS FOR PASSING OPTIONAL PARAMATERS H* PROGRAM TO CALCULATE THE TIME DIFFERENCE BETWEEN 2 TIME VALUES. H* -------------------------------------------------------------H* Assumes that Factor 1 tim e value is greater than Factor 2 time H* value. h* -------------------------------------------------------------h* H TIMFMT(*HMS) DFind_Difference PR DT1 T DT2 T DRslt T options (*nopass) DT1 s T INZ(T'07:15:30') DT2 S T INz(T'10:10:05') DRslt S T INz(T'00:00:00') D* C CAllp Find_Difference(T1:T2:Rslt) C Rslt DSPLY C CAllp Find_Difference(T1:T2) C Eval *inlr = *on C Return C* C* -----------------------------------------------------PFind_Difference B DFind_Difference PI LAB : Accessing Indidator ARRay dn1 s 4s 0 inz(1) c Dow n1 < 100 c Eval *in(n1) = *off c Eval n1 = n1 + 1 c Enddo c Exsr TestSR c Eval *inlr = *on c Return c* ---------------------------------------c* c TestSR Begsr c Eval *in(45) = *ON c If *in45 = *on
22
RPG-ILE LABS c c c c c c c
'45 on'
'45 on'
OUTPUT : Dsply
Dsply Endif Eval If Dsply Endif Endsr
*in45 = *off *in(45) = *on
'45 on'
A short cut method to set off all indicators is : c c c
Eval Eval Return
DT1 DT2 DRslt DTempTime S DSec S C T2 SUBDUR C TempTime Adddur C If C MOVE C Return C Else C 'No param!' Dsply c TempTime Dsply c Endif PFind_Difference E
*in(*) = *off *inlr = *on
T T T options(*nopass) T INZ(T'00:00:00') 10s 0 inz(0) T1 SEC:*S sec:*S TempTime %Parms = 3 TempTime Rslt
After one of the parameters is specified as a nopass parameters, the following parameters HAVE to be nopass parameters. NOPASS means OPTIONAL. LAB : Calculate years,months and days between 2 dates : H* PROGRAM TO CALCULATE THE TIME DIFFERENCE BETWEEN 2 date VALUES. H* -------------------------------------------------------------H* Assumes that Factor 1 tim e value is greater than Factor 2 time H* value. h* -------------------------------------------------------------h* H DATFMT(*DMY) DDs001 ds DDys 2s 0 inz(0) DMnt 2s 0 inz(0) DYrs 2s 0 inz(0) DFind_Difference PR DD1 d DD2 d D*--------------------------------------------------DD1 s D INZ(D'10/01/04') DD2 S D INz(D'15/01/04') ddelta s 4s 0 inz(0) D* C CAllp Find_Difference(D1:D2) C Eval *inlr = *on
23
RPG-ILE LABS C Return C* ------------------------------------------------------PFind_Difference B DFind_Difference PI DD1 d DD2 d C D2 SUBDUR D1 Yrs:*Y C D1 addDUR Yrs:*Y D1 C D2 SUBDUR D1 Mnt:*M C D1 addDUR Mnt:*M D1 C D2 SUBDUR D1 Dys:*D C* ==================================================== c Ds001 dsply C Return PFind_Difference E
24
RPG-ILE LABS LAB : Built-in functions : %TRIM, %SUBSTR, *LEN, %SIZE %ABS DA01 DA02 C* C C C* C C C* C C C* C
S S
2P 0 Inz(-1) 10P 3 Inz(-14.567) EVAL DSPLY
A01 = %ABS(A01)
A01
EVAL DSPLY
A02 = %ABS(A02)
A02
EVAL DSPLY
A02 = %ABS(A01 - -2)
A02
EVAL
*INLR = *ON
%TRIM %EDITC DNAME DDATE DTIME DRESULT DMSG DSALARY D* C C C C* C MSG C DATE C TIME C UDATE C* C
S S S S S S
20A D INZ(D'2003-05-05') T INZ(T'12.12.12') 10A 50A 9P 2 INZ(1000) EVAL
MSG = 'Annual Salary : ' +%TRIM(%EDITC(Salary*12 :'A': *CURSYM))
DSPLY DSPLY DSPLY DSPLY EVAL
*INLR = *ON
%SUBSTR DLEN DSTR C C C C C C
S S STR
4S 0 INZ(0) 12A INZ('TEST STRING') DSPLY EVAL DSPLY EVAL DSPLY SETON
LEN STR
OUTPUT : TEST STRING
12
LEN=%LEN(STR) STR=%SUBST(STR:2:3) LR
EST
%SIZE DSTR1
S
14A
INZ('TEST STRING')
25
RPG-ILE LABS DN C C C C
S STR1 N
4S 0 INZ(0) DSPLY EVAL DSPLY SETON
N=%SIZE(STR1) LR
Output : TEST STRING 14 %EDITC D* Demo of converting Numeric to String. D* -----------------------------------Dsal s 5i 0 inz(4000) Dx s 20a C eval x=%editc(sal:'A') C x dsply C seton
lr
LAB : Working on SCAN Opcode and SCAN function Scan will look for occruance of the sSrc string in the sStr string and write the position of nSrc (if found in sStr) to nPos. NPos is zero based so add 1 to nPos. Specify nPos in SubSt() function to get the rest of the characters after nPos. dsStr s dsSrc s dnPos s dsRes s d* c sSrc c c c sRes c* ---------------c* output : xyz mno c* ---------------c c
12a inz('abc xyz mno') 1a inz(' ') 4s 0 inz(0) 12a SCAN Eval Eval Dsply
sStr nPos nPos = nPos + 1 sRes = %SubSt(sStr:nPos)
Eval Return
*INLR= *ON
RPGLE program listing : RPSCAN Arguments to %SCAN : First arg : String to be searched Sec Arg : Main string containing the data Third Arg : START POSITION dString1 s 10a inz('abcdefghij') dsrcstr s 1a inz('d') dLoc s 2s 0 inz(0) d* d*----------------------------------------------------c Eval Loc = %Scan(srcstr:String1:1) c 'd loc :' Dsply c Loc Dsply
26
RPG-ILE LABS c* c c c c c* c c c c c
'b loc :' Loc 'x loc :' Loc
Eval Eval Dsply Dsply
srcstr = 'b' Loc = %Scan(srcstr:String1:3)
Eval Dsply Eval Dsply Eval
srcstr = 'x' Loc = %Scan(srcstr:String1:1) *inlr = *on
OUTPUT : DSPLY d loc : DSPLY 4 DSPLY b loc : DSPLY 0 DSPLY x loc : DSPLY 0
27
RPG-ILE LABS
LAB : STRING OPERATIONS : XLATE UPPER CASE TO LOWER CASE DUC DLC DSTRINP DSTROUT C UC:LC C STRINP C STROUT C
S S S S XLATE DSPLY DSPLY SETON
26A 26A 7A 7A STRINP
INZ('ABCDEFGHIJKLMNOPQRSTUVWXYZ') INZ('abcdefghijklmnopqrstuvwxyz') INZ('ASTRIX') STROUT LR
LAB : Special use of CAT Linkage : RPCAT CODE : ds1 ds2 ds3 ds4 c s1 c s1 c s3 c s4 c* output : c* abcd# c* abcd # c
s s s s cat cat Dsply Dsply
Eval
4a 4a 8a 8a '#':0 '#':2
inz('abcd') inz('qrst') s3 s4
*inlr = *on
PF contents : --OUTPUT
: appends # to the 2nd position after
‘#’:2
‘abcd’. Ei at abcdBB#
REMARKS : ‘#’:2
leaves a gap of 2 positions after d of abcd.
28
RPG-ILE LABS LAB : ARRAY DECLARATION *************** Beginning of data ********************************** DAR1 S 4S 0 DIM(5) DN S 4S 0 INZ(1) C N DOWLT 5 C EVAL AR1(N)=N C AR1(N) DSPLY C EVAL N=N+1 C ENDDO C SETON LR OUTPUT : 1 2 3 4 H*PRG FOR PRE RUN TIME ARRAY FPFDEL IT F 25 D ARR1 S C MOVEL C VAR LOOKUP c* C *IN35 IFEQ C 'FOUND' DSPLY C ELSE C 'NOT FND' DSPLY C ENDIF C ARR1(2) DSPLY C ARR1(4) DSPLY C ARR1(12) DSPLY c*data beyond limit C ARR1(14) DSPLY C SETON
DISK 25 'one' ARR1
DIM(16) FROMFILE(PFDEL) PERRCD(1) VAR 25 35
*ON
LR
LAB : COMPILE TIME ARRAY D ARR C C VAR C *IN25 C 'FOUND' C C 'NOT FND ' C C ARR(2) C ARR(4) C ARR(12) C
S MOVE LOOKUP IFEQ DSPLY ELSE DSPLY ENDIF DSPLY DSPLY DSPLY SETON
3 'JJL' ARR *ON
DIM(12) CTDATA PERRCD(6) VAR 3 25
LR
** JANFEBMARAPRMAYJUN
29
RPG-ILE LABS LAB : Compile time table
:
LAB : TABLE DTAB01 DTAB02 D$DATE D$YY D$MM D$TEMP D$DD D$SEP D$MON
S S S S S S S S S
12A DIM(3) CTDATA ASCEND 12S 0 DIM(12) CTDATA ASCEND 6 2 0 2 0 4 2 1 3
** JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC ** 01 02 03 04 05 06 07 08 09 10 11 12
30
RPG-ILE LABS LAB : ALTERNATE TABLE DTAB01 DTAB02 D*
S S
12A DIM(12) CTDATA PERRCD(2) ASCEND 2S 0 ALT(TAB01) DIM(12)
** 01JAN 02FEB 03MAR 04APR 05MAY 06JUN 07JUL 08AUG 09SEP 10OCT 11NOV 12DEC PRE-RUN TIME TABLE H*PROGRAM FOR PRE RUN TIME TABLE F* FTEST33 IF E DISK D TABROL S 3 0 DIM(12) EXTFMT(P) FROMFILE(TEST33) D PERRCD(1) C* C Z-ADD 125 VAR 3 0 C VAR LOOKUP TABROL 25 C *IN25 IFEQ *ON C 'FOUND' DSPLY C ENDIF C SETON LR
31
RPG-ILE LABS LAB : INTRODUCTION TO DATA STRUCTURE AND TYPES OF DATA STRUCTURES PSDS D D D D D I* C* C* C* C C* C C C C
SDS PGNAM UNAME DATE TIME
1 254 270 282
10 263 275 287
Main Logic ---- ----*IN03
DOWEQ
*OFF
MOVEL MOVEL MOVE MOVE
PGNAM UNAME DATE TIME
DNAME DUNAM DDATE DTIME
MULTI OCCURANCE DS D JSRDS D SCODE D SROLL D SNAME C 1 C C C 2 C C C C 1 C SNAME C SCODE C SROLL C 2 C SCODE C SROLL C '---' C JSRDS C
DS 1 6 11 OCCUR MOVEL Z-ADD OCCUR MOVEL Z-ADD MOVEL OCCUR DSPLY DSPLY DSPLY OCCUR DSPLY DSPLY DSPLY DSPLY SETON
30 OCCURS(20) 5 10 0 30 JSRDS 'S001' SCODE 1 SROLL JSRDS 'S002' SCODE 2 SROLL 'TRIAL' SNAME JSRDS
JSRDS
LR
DATA AREA DATA STRUCTURE D JSRDTA D BCODE D BNAME C BCODE C BNAME C
UDS 1 5 DSPLY DSPLY SETON
4 20 LR
FILE INFORMATION DATA STRUCTURE :
32
RPG-ILE LABS
FPF001 IF D INFDS1 D FILE D CODE D STATUS D RECORD D ROUTIN C FILE C CODE C STATUS C RECORD C ROUTIN C
E
DISK
INFDS(INFDS1)
DS *FILE *OPCODE *STATUS *RECORD *ROUTINE DSPLY DSPLY DSPLY DSPLY DSPLY SETON
LR
LAB : INTRODUCTION TO DATA AREAS AND TYPES OF DATA AREAS Infds : FTEST1 IF E FTEST1D UF A E F D STR1 DS D STA *STATUS C READ C Z-ADD C READ C *IN25 DOWEQ C Z-ADD C NUM DSPLY C* C WRITE C READ C ENDDO C SETON C* C *PSSR BEGSR C READ C ENDSR
DISK DISK
INFDS(STR1) INFSR(*PSSR)
PFREC1D 0 PFREC *OFF NUMBER
26 VAR
2 0 25
NUM
PFREC1D PFREC
25 LR
PFREC
25
NOW IF YOU DO A READ, THE DATA IS TAKEN FROM THE PF AND WRITTEN TO THE FIRST OCCURANCE OF DS. AND SO ON… LAB : Error Handling a Multi occurance Data structure dNOccur s dds001 ds dN1 dN2 d** d sds dStatus *status d* c* specify impossible occurance
4s 0 inz(12) occurs(10) 4s 0 4s 0
33
RPG-ILE LABS c* c NOccur Occur ds001 c If *in66 = *on c 'unreachable' dsply c Status Dsply c* c* value of Status will be 122 c* c EndIf C Eval *inlr =*on C Return PASSING A DS AS A
PARAMETER
66
(RPG/400)
RPRCV : RECIEVER PROGRAM LISTING : IDS001 I I C C C C C C C C
DS 1 5 *ENTRY NAME CODE
PLIST PARM DSPLY DSPLY MOVEL'XML' Z-ADD22 SETON RETRN
40CODE 14 NAME
DS001 NAME CODE LR
RPSENDER : CALLING PROGRAM IDS001 I I C C C C C C C C C
DS 1 5
'PARENT' NAME CODE
Z-ADD12 MOVEL'SAM' CALL 'RPRCV' PARM DSPLY DSPLY DSPLY SETON RETRN
40CODE 14 NAME
CODE NAME DS001
LR
LAB : Demo of OVERLAY and Multi occurance. Linkage : RPOVR. CODE : * _____________________________________________________ * RPOVR. * Demo of overlay and multi occurances of variable being * overlayed. * a is broken into 2 sections identified by b and c * There are 10 instances of a , so there are 10 inst of b and c * * ########## <-- a(1) * -----~~~~~ * b(1) c(1)
34
RPG-ILE LABS * _____________________________________________________ dds001 ds da 10a Dim(10) db 5a overlay(a) dc 5a overlay(a:6) dcount s 2s 0 inz(1) dtemp s 5 dabc s 2 c* c Dow count<4 c* conv to character c Movel count abc c 'ABC' cat abc temp c* ABC01... c Eval b(count) = temp c 'xyz' cat abc temp c* xyz01... c Eval c(count) = temp c a(count) dsply c* ABC01xyz01 ... c Eval count = count + 1 c End c Eval *inlr = *on PF contents : nil OUTPUT DSPLY DSPLY DSPLY
: ABC01xyz01 ABC02xyz02 ABC03xyz03
REMARKS : Overlay can access sections of a variable LAB : MULTI OCCURANCE EXTERNALLY DESCRIBED DS CREATE EXTDS : A TYPICAL BCODE, BNAME BPRICE PHYSICAL FILE WITH RECORD SIZE 21 CREATE DDS, COMPILE AND WRITE 5-6 RECORDS TO THE SAME. DECLARING A EXTERNALLY DESCRIBED DS : Prompt type . . . Data Struct Name DS001 FEXTDS IDS001 C C C C C
DS
Number E
Sequence number . . .
E EIDSEXTDS 1
Option I
DS DS
IF
DS001 2
0001.00
External File Name EXTDS
Occurs 4
Length 21
DISK 4 OCUR DS001 READ BM DSPLY OCUR DS001 READ BM
21 55 55
35
RPG-ILE LABS C C C C
DS001 1 DS001
DSPLY OCUR DS001 DSPLY SETON
LR
1 OCCUR DS001 SETS THE FIRST OCCURANCE OF DS AS CURRENT OCCURANCE. LAB : External data structure Example 1 DMYDS c c C c c C C C
E DS 1 BCODE 3 BCode
Eval Occur Dsply Occur Eval Dsply Eval Return
EXTNAME(BM001) Occurs(4) Bcode = 1 MyDS MyDS Bcode = 12 *INLR = *ON
LAB : External data structure : Example 2. FBM001 if e Disk DMYDS E DS EXTNAME(BM001) Occurs(4) c Read BM C* -------------------------------------------C* The READ opcode copies the data read from C* PF into the current occurance of the DS. C* -------------------------------------------c 1 Occur MyDS C C C c c C C C C
BCODE BNAME BPRICE 2 BCODE BNAME BPRICE
Dsply Dsply Dsply Occur Read Dsply Dsply Dsply Eval
MyDS BM
*INLR = *ON
* END *
36
RPG-ILE LABS
37
RPG-ILE LABS
38
RPG-ILE LABS LAB : LDA Lda : FD002 CF C *IN03 C *DTAARA C C C C C C C C C
E
WORKSTN *OFF *LDA CYNAM
DOWEQ DEFINE IN CLEAR MOVE OUT MOVEL EXFMT ENDDO MOVE SETON
CYNAM
10
CYNAM CYNAM
'test st' CYNAM CYNAM DATA
DCYNAM
*ON
*INLR LR
User defined DATA AREA : FD001 CF C *IN03 C *DTAARA C C C C *IN03 C C C C
E
WORKSTN *OFF
DOWEQ DEFINE IN Z-ADD EXFMT IFEQ LEAVE ENDIF ENDDO MOVE
LAB : Implementing
EMPN EMPN EMPN DATA *ON
5 0
DEMPNO
*ON
*INLR
a dataarea
Create a dataarea called “JSRDTA” fo the type *CHAR and length 10. Listing : dDta1 dtemp c *Lock c Dta1 c c c c c c
s s IN Dsply Movel Clear movel Out Unlock Eval
10a 10a Dta1
dtaara(jsrdta)
Dta1 'new data' Dta1 Dta1 *inlr = *on
temp Dta1 dta1
SIGNIFICANCE OF LOCKING THE DATA AREA : NOTE : If you do not lock the data area during the IN operation, you cannot UPDATE (ie Change) its contents. You can then only read the data area. LAB : Handling a locked data area Listing of CLDTAARA2 :
39
RPG-ILE LABS
Pgm
END1: end: Endpgm
ALCOBJ OBJ((QGPL/MYDTA *DTAARA *excl)) WAIT(0) monmsg msgid(CPF1002) exec(goto end1) CHGDTAARA DTAARA(QGPL/MYDTA) VALUE('sec') SNDPGMMSG MSG('hi2!') TOPGMQ(*EXT) MSGTYPE(*INQ) DLCOBJ OBJ((QGPL/MYDTA *DTAARA *excl)) goto end SNDPGMMSG MSG('cannot allocate')
LISTING OF CLDTAARA1 : Pgm ALCOBJ OBJ((QGPL/MYDTA *DTAARA *excl)) WAIT(0) monmsg msgid(CPF1002) exec(goto end1) /* cannot alocate since it is already locked. */ CHGDTAARA DTAARA(QGPL/MYDTA) VALUE('FIRST') SNDPGMMSG MSG('hi !') TOPGMQ(*EXT) MSGTYPE(*INQ) DLCOBJ OBJ((QGPL/MYDTA *DTAARA *excl)) goto end SNDPGMMSG MSG('cannot allocate')
END1:
LAB : Opening file under User Control. (UC). FPF001 IF C C C BCODE C
E OPEN READ DSPLY SETON
DISK PF001 BM
USROPN 77 LR
LAB : Ending a program without setting on LR causes files to remain open RPPARENT c c c c* c* c* c* c* c* c* c* c c
'Parent go:' 'Parent Bk'
dsply Call Dsply
'RPCHILD'
do a shift + esc notice that the file PFBMAST is not closed although Child has ended Use RCLRSC from command line to close the PFBMAST file Eval Return
*inlr = *on
RPCHILD fpfbmast if c c 'child!' c c 44
e Read dsply Eval Eval
disk bm
88
*in44 = *off *inlr = *on
40
RPG-ILE LABS c c
Return
Child does not allow the SETON LR to take place. Result is that child returns without Closing the PFBMAST file. This can be confirmed by Shift + Esc and 14 to see open files. LAB
: Handling database errors. PSSR, INFSR.INFDS. FTEST1 IF E DISK FTEST1D UF A E DISK INFDS(STR1) F INFSR(*PSSR) D STR1 DS D STA *STATUS C READ PFREC1D 26 C Z-ADD 0 VAR 2 0 C READ PFREC 25 C *IN25 DOWEQ *OFF C Z-ADD NUMBER NUM C NUM DSPLY C* --------------------------------------------------------------------C WRITE PFREC1D C READ PFREC 25 C ENDDO C SETON LR C* --------------------------------------------------------------------C *PSSR BEGSR C READ PFREC 25 C ENDSR C* ---------------------------------------------------------------------
41
RPG-ILE LABS Lab : I specs Program described files. In this lab we look at creating a flat physical file and access the same from a RPGLE program. The program breaks the row from the flat physical file into sections as required and assigns that data to variable. This happens for every read operation. Step1 : Create a flat physical file. PFFLAT : Record size : 21. FPfFlat
IF
F
21
Disk
IPfFlat XX I 1 4 0cd I 5 14 nm I 15 21 2pr I* First I line is by PI. Second by PJ. C C C C
cd nm pr
C
read dsply dsply dsply
pfFlat
Eval
*inlr = *on
The shaded I spec portion indicates the sections of the input record and variables to which those sections will be assigned. For each read operation, 1 row is read from the physical file. It is read as 1 single row of 21 positions. However, in the program, the row is split up and different sections of the same are assigned to different variables suc as cd,nm and pr as in above case. CD gets data abetween positions 1 and 4. Same for nm and pr. Thus although data, while reading is un-structured, it is bifercated into different sections and used as required in the program. Data read from physical file : 0001ACAD
0000120
after data is interpreted by I specs : 0001 ACAD ↓ ↓ cd nm 1..4
5..14
0000120 ↓ pr 14..21
To the read opcode, we pass the PFFLAT as the record format since flat physical file has same name for file and record format.
42
RPG-ILE LABS LAB : O Specs
FPfFlat dcd dnm dpr c C oPFFLAT o o o
o
F
21 s s s Except Eval e1 cd nm pr
e
Disk 4s 0 inz(108) 10a inz('Physics') 7s 2 inz(100.25) e1 *inlr = *on 4 14 21
The first O-spec line : Prompt type . . . Filename PFFLAT
O
Type e
Sequence number . . . Fetch
---- Space ----Before After ______ ______
N01N02N03
0014.00
----- Skip ----Before After ______ _____
EXCEPTName e1
Comment __________________
OUTPUT : 108 PHYSICS
10025
above record is added to the physical file. LAB : O Specs FPfFlat dcd dnm dpr c c C oPFFLAT o o o o o
o
F
21 s s s
e
e
Except Except Eval e1 cd nm pr e2
Disk 4s 0 inz(108) 10a inz('Physics') 7s 2 inz(100.25) e1 e2 *inlr = *on 4 14 21 14 '** ERROR ** '
In above case, the string ‘ ** ERROR * *’ is inserted into the physical file. It is placed from the beginning of the record, so some part of the same appears in the BCode column while some in BName column. (!!)
43
RPG-ILE LABS
44
RPG-ILE LABS LAB : Declaration of sub files. (rest pf the code is same,no need to cover all that ) FDSP1 F
CF
E
WORKSTN SFILE(SFLDATA:RRN)
LAB : Updating file records under Commitment control. Selecting the correct lock type. FPF001 UF C C C BCODE C C C
E OPEN READ DSPLY UPDATE CLOSE SETON
DISK PF001 BM
COMMIT
usropn 77
BM PF001 LR
LAB : Database basics : How access is done when you try to get a non-keyed access to a LF which has a K on a certain field. Database files : PFBMK : typical book master file. LFBMK : Typical book master based on pfbmk and keys on BPRICE. Linkage : RPREAD CODE : FLfbmk IF c 5 c c bcode c bprice c c c
E setll Read dsply dsply
PF contents :
Eval Return
BCODE 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
Disk bm bm
*inlr=*on
BNAME ACAD C C++ PAS COB AI HISTORY ENGLISH HINDI MARATHI Pascal Cobol C++ RPG CL DB2 ILE
LFBMK BPRICE 120.00 220.00 320.00 120.00 220.00 430.00 100.00 120.00 90.00 75.00 120.00 220.00 420.00 2,420.00 420.00 520.00 220.00
45
RPG-ILE LABS OUTPUT
:
5 220.00 REMARKS : Even if it is a keyed file, here we access it in sequential fashion. SETLL has 5 in factor 1. This gives access to the 5th from top record. The records are not even arranged in asc order of BPRICE. LAB : Access LFBMK in keyed fashion. Linkage : RPREAD1 CODE : FLfbmk IF E k Disk dsrc s 7p 2 inz(320) c src setll bm c Read bm c bcode dsply c bprice dsply c Eval src = 90 c* c* SETLL starts searching from the top of the Database file. c* Record with BPRICE=90 comes way before rec with BPRICE=320 c src setll bm c Read bm c bcode dsply c bprice dsply c Eval *inlr=*on c Return PF contents : Same as prev lab. OUTPUT
:
DSPLY DSPLY DSPLY DSPLY
3 32000 9 9000
REMARKS : SETLL starts searching from the top. LAB : Too less and too large values to setll. Linkage : RPREAD2 CODE : FLfbmk
IF
E
k Disk
46
RPG-ILE LABS dsrc s D* c* Too less. No rec c* c src c *in44 c *in45 c *in46 c c c bcode c bprice c c* c* Too large value. c* c src c *in44 c *in45 c *in46 c c c bcode c bprice c c
7p 2 inz(20) has bprice = 20. The least value=75. setll dsply dsply dsply Setoff Read dsply dsply Eval
bm
444546
444546 bm src = 3000
No record has bprice = 3000.Largest val is 2,400 setll dsply dsply dsply Setoff Read dsply dsply Eval Return
bm
444546
444546 bm *inlr=*on
PF contents : Same as prev. OUTPUT
:
DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY REMARKS
0 0 0 10 7500 1 0 0
at the first record. too high a value.
10 7500
still at the first record.
:
47
RPG-ILE LABS LAB :
Behavior of SETLL.
Linkage : RPREAD2 CODE : FLfbmk IF E dsrc s D* c src c *in44 c *in45 c *in46 c c c* Too less. No rec c* c src c *in44 c *in45 c *in46 c c c bcode c bprice c c* c* Too large value. c* c src c *in44 c *in45 c *in46 c c c bcode c bprice c c
k Disk 7p 2 inz(420) setll bm dsply dsply dsply Setoff Eval src=20 has bprice = 20. The least value=75.
444546
setll dsply dsply dsply Setoff Read dsply dsply Eval
444546
bm
444546
444546 bm src = 3000
No record has bprice = 3000 setll dsply dsply dsply Setoff Read dsply dsply Eval Return
bm
444546
444546 bm *inlr=*on
PF contents :
OUTPUT
:
DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
0 0 1 0 0 0 10 7500 1 0 0 10 7500
48
RPG-ILE LABS REMARKS : To start with, 420 is passed as search argument to setll. SETLL finds an exact match so the file pointer is positioned to that record and EQ indicator is set on (*in46 = *ON) . So we get 0 0 1 as the output. Next we put 20 as factor-one to setll. There is no record with this value of bprice. The rec with the least bprice value is 75 which is the first record. Hence file pointer is positioned to the first record and this is read. No indicator is changed.SETLL does not complain. So output : 0 0 0
10 75
Next we put 3000 as factor 1 argument to SETLL which is too high. The rec with largest BPRICE value is 2,400. Hence file pointer is not moved at all and HI indicator is set on. Hence Output : 1 0 0
10 75
49
RPG-ILE LABS LAB : Working on CHAIN, READE Linkage : RPREAD3 CODE : FLfbmk IF dsrc D* c src c c BCode c BPrice c src c c c
E
k Disk 7p 2 inz(120)
s chain Dow dsply dsply ReadE EndDo Eval Return
bm Not %EOF bm *inlr=*on
PF contents : The contents are re-ordered in ascending order of bprice. Thus the file will NOT be read in the followign order. BCODE 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
BNAME ACAD C C++ PAS COB AI HISTORY ENGLISH HINDI MARATHI Pascal Cobol C++ RPG CL DB2 ILE
OUTPUT
:
DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
BPRICE 120.00 220.00 320.00 120.00 220.00 430.00 100.00 120.00 90.00 75.00 120.00 220.00 420.00 2,420.00 420.00 520.00 220.00
1 12000 4 12000 8 12000 11 12000
REMARKS : First CHAIN locates the first record from top. Remaining records with same bprice can be located using READE.
50
RPG-ILE LABS LAB : Single page subfile KEYED access to LFBMK LFBMK : Logical file. Linkage : RPLFBMK, DSLFBMK. CODE : DSLFBMK : A A A A A A A A A A A A A A A A A A A A A A A A
R SFLDT DCODE DNAME DPRICE
4 20 7
0B B 2B
5 5 5
DSPSIZ(24 80 *DS3) PAGEUP(25) PAGEDOWN(26) SFL 10COLOR(WHT) 21COLOR(WHT) 49EDTWRD(' . ') COLOR(WHT) 61'Rs' SFLCTL(SFLDT) CA03(03) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) 23'Book Master Record' COLOR(WHT) 10'Code' COLOR(WHT) 28'Name' COLOR(WHT) 53'Price' COLOR(WHT)
5 R SFLCTL 50 51 52 1 3 3 3
RPSFLK : F* FLfbmk IF E Fdslfbmk CF E drrn s D* C* c Exsr c ExSR c Dow c ExSR c ExSR c EndDO c Eval c Return c* c UsrSR BegSR c* Pg up c If c Eval c* c* go back 8 records. c* c do
k Disk Workstn sfile(sfldt:rrn) 4s 0 inz(0) CLRSR LDSR *in03 = *off DspSR UsrSR *inlr = *on
*in25 = *on *in25 = *Off
8
51
RPG-ILE LABS c c c c c c c* c* c c c c* c* c* c c c* c c c c c c c* c c c* c* c* c c c* c c c c* c c c c c c c c c* c c c c c c c
ReadP if Leave EndIf EndDo EndIf
bm %EOF(lfbmk)
If Eval EndIf
*in26 = *on *in26 = *Off
end of PG UP Pg Dn
In either case,Load is necessary. Exsr EndSr ClrSR
LdSR
BegSR Eval Eval Write Eval EndSR BegSR Exsr
LDSR
rrn = 0 *in52 = *on SflCtl *in52 = *off
ClrSR
load next 4 records to subfile
DspSR
Read Do
bm 4
if Leave EndIf
%EOF
Eval Eval Eval Eval Write Read EndDO EndSR
DCode = BCode DName = BName DPrice = BPrice rrn = rrn + 1 SFLDT bm
BegSR Eval Eval Exfmt Eval Eval EndSR
*in50 = *in51 = SflCTL *in51 = *in50 =
*on *on *off *off
PF contents : Logical file OUTPUT
: Book Master. Keyes on BPRICE.
:
52
RPG-ILE LABS The records are displayed in single page subfile in ascending order of Bprice. REMARKS : Algorithm changes since the access is keyed.
53
RPG-ILE LABS LAB : Introduction to logic cycle : Default program processing algorithm. FPFBM FQPRINT IPFBM I I I C 20 OQPRINT O O O O O O O
IP O AA
F F
21 80
DISK PRINTER OFLIND(*IN20) 1 5 15
4 0CODE 14 NAME 21 2PRICE
SETOFF H
20
1P
1
1
1
1
40 '<TITLE COMES HERE>' D CODE NAME PRICE T
Z
10 30 60
Q
20
1
1 78 '------------------'
ONE MORE EXAMPLE : FQPRINT C N40 C C C 20 C CODE C C C* OQPRINT O O O O O
O
H
F
80 Z-ADD SETON ADD SETOFF IFGT SETON ENDIF
PRINTER OFLIND(*IN20) *ZEROS CODE
4 0 40
1
CODE 20
100 LR
1P
1
1
1
1
40 '<TITLE COMES HERE>' D CODE T
Z
20
10
1
1 78 '------------------'
USING OVERFLOW IND : FPFLGC F* FQPRINT
IP
F
63
O
F
132
DISK PRINTER OFLIND(*INOF)
LAB : SPECIFY OVERFLOW LINE NUMBER AND NUMBER OF LINES ON THE FORM ILE CODE : RUN THIS PROGRAM AND SEE THE NUMBER OF PAGES OF OUTPUT CREATED. FPFBM FQPRINT IPFBM I I I C 20 OQPRINT O O
IP O AA
F F
21 80
DISK PRINTER OFLIND(*IN20) FORMLEN(10) FORMOFL(09) 1 5 15
4 0CODE 14 NAME 21 2PRICE
SETOFF H
1P
20 1
1
1
1
40 '<TITLE COMES HERE>' D
54
RPG-ILE LABS O O O O O
CODE NAME PRICE T
Z
10 30 60
Q
20
1
1 78 '------------------'
RPG/400 CODE : L – SPECS ARE USED AS UNDER : Prompt type . . .
Filename QPRINT FPFBM FQPRINT LQPRINT IPFBM I I I C 20 OQPRINT O O O O O O O
L
Sequence number . . .
Line Number 20
Form Length FL
IP F 21 O F 80 20FL 18OL AA
Overflow Line Number 18
Overflow Line OL
DISK LPRINTER
20
1 5 15 SETOF H 11
0000.03
40CODE 14 NAME 212PRICE 20
1P 40 '<TITLE COMES HERE>'
D 11 CODE Z NAME PRICE Q T 11
10 30 60
20 78 '------------------'
LAB : Basic Logic Cycle with L1 indicator. F* BIOPF2 CONTAINS 4 FIELDS. F* BCODE1 AND BCODE2 HAVE L2 AND L1 INDICATORS F* ON THEM. L1 IS SET ON EVERTIME BCODE2 CHANGES F* L2 IS SETON WHEN BCODE1 CHANGES.L2 ALSO SETS ON F* L1 AUTOMATICALLY. F* -----------------------------------------------FBIOPF2 IP F 16 DISK FQSYSPRT O F 132 PRINTER OFLIND(*INOF) IBIOPF2 AA I 1 4 BCODE1 L2 I 5 8 BCODE2 L1 I 9 12 0BIN I 13 16 0BOUT OQSYSPRT H O 1P 40 'FIRST PAGE' O D N1P O 7 'BC 1 : ' O BCODE1 9 O 16 'BC 2 : ' O BCODE2 19 O 45 'BOOKS IN : ' O BIN 56
55
RPG-ILE LABS O O O O O
T
L1
T
LR
37 'TOTAL TIME' OF
37 'LR IS ON ' '* OVER FLOW *'
LAB : Simple Logic cycle program with L1 control break indicator. Linkage : RPGLC2 in samlesrc. CODE :
RPLC2
* ____________________________________________________________ * Simple program demonstrating a logic cycle. * ____________________________________________________________ * Database file contains BCODE BIN and BOUT fields * which store the qty of books comming in and going out * along with their codes. * Objective is to display the total bin and bout for each book. * ____________________________________________________________ * FQPRINT O F 80 PRINTER FPFBIO1 IP F 12 DISK DTOTBIN S 5I 0 INZ(0) DTOTBOUT S 5I 0 INZ(0) iPFBIO1 AA 88 i 1 4 0bcode L1 i 5 8 0bin i 9 12 0bout C* C IF *INL1 AND *IN88 C EVAL TOTBIN = 0 C EVAL TOTBOUT = 0 C ENDIF C* C IF *IN88 C EVAL TOTBIN = TOTBIN + BIN C EVAL TOTBOUT = TOTBOUT + BOUT C ENDIF C* C*____________________________________________ OQPRINT D N1P O 10 'CODE :' O BCODE Z 20 O 30 'IN :-' O BIN Q 40 O 50 'OUT :-' O BOUT Q 60 O T L1 88 1 1 O '_______________________ O T L1 88 1 1 O 10 'TOTAL IN :' O TOTBIN 17 O 40 'TOTAL OUT : ' O TOTBOUT 50 O* O T L1 88 1 1 O '_______________________
56
RPG-ILE LABS PF contents : PFBIO1 BCODE 1 1 1 2 2 2 3 3 3
BIN 10 0 10 10 0 10 10 0 10
BOUT 0 10 0 0 10 0 0 10 0
OUTPUT : QPRINT spool file. CODE : 1 IN CODE : 1 IN CODE : 1 IN _________________________ TOTAL IN : 00020 _________________________ CODE : 2 IN CODE : 2 IN CODE : 2 IN _________________________ TOTAL IN : 00020 _________________________ CODE : 3 IN CODE : 3 IN CODE : 3 IN
:::-
10 10
TOTAL OUT : :::-
10 10
TOTAL OUT : :::-
10 10
OUT :OUT :OUT :-
10
00010 OUT :OUT :OUT :-
10
00010 OUT :OUT :OUT :-
10
LAB : Working with L1 and L2 indicators. CODE :RPLC3 * ____________________________________________________________ * DEMONSTRATING L1 AND L2 INDICATORS. * ____________________________________________________________ * Database file contains SBCODE,BCODE BIN and BOUT fields * which store the qty of books comming in and going out * along with their codes AND THE subject code. * Objective is to display the total bin and bout for each book. * grouped by BCode and then Grouped by SBCODE (subject code) * SBCODE : 1 for mechanical Engg. * BCODE : 1 for the first book in the mech engg book. * ____________________________________________________________ * FQPRINT O F 80 PRINTER FPFBIO3 IP F 16 DISK DTOTBINSB S 5I 0 INZ(0) DTOTBOUTSB S 5I 0 INZ(0) DTOTBIN S 5I 0 INZ(0) DTOTBOUT S 5I 0 INZ(0) DTEMP S 4S 0 INZ(0) iPFBIO3 AA 88 i 1 4 0sbcode L2 i 5 8 0bcode L1
57
RPG-ILE LABS i 9 12 0bin i 13 16 0bout C* C* C IF (*INL1 AND *IN88) and (*INL2) C EVAL TOTBIN = 0 C EVAL TOTBOUT = 0 C EVAL TOTBINSB = 0 C EVAL TOTBOUTSB = 0 C ENDIF C* C IF (*INL1 AND *IN88) C EVAL TOTBIN = 0 C EVAL TOTBOUT = 0 C ENDIF c* C IF *IN88 C EVAL TOTBIN = TOTBIN + BIN C EVAL TOTBOUT = TOTBOUT + BOUT C EVAL TOTBINSB = TOTBINSB + BIN C EVAL TOTBOUTSB = TOTBOUTSB + BOUT C ENDIF C* C*____________________________________________ OQPRINT D N1P O 10 'CODE :' O BCODE Z 15 O 25 'IN :-' O BIN Q 30 O 35 'OUT :-' O BOUT Q 40 O 45 'SBCODE :' O SBCODE Q 50 O T L1 88 1 1 O '______________________ O T L1 88 1 1 O 10 'TOTAL IN :' O TOTBIN 17 O 40 'TOTAL OUT : ' O TOTBOUT 50 O* O T L1 88 1 1 O '___________________ O* O* O T L1 88 L2 1 1 O '+ + + + + + + + + + O T L1 88 L2 1 1 O 17 'GR.TOTL IN:' O TOTBINSB 17 O 40 'GR. TOTL OUT:' O TOTBOUTSB 50 O* O T L1 88 L2 1 1 O '~~~~~~~~~~~~~~~~~~~ O* PF contents :PFBIO3
58
RPG-ILE LABS L1
BCODE
SBCODE 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2
1 1 1 2 2 2 3 3 3 1 1 1 2 2 2 3 3 3
OUTPUT
:
BIN 10 0 10 10 0 10 10 0 10 20 0 20 20 0 20 20 0 40
L2
BOUT 0 10 0 0 10 0 0 10 0 0 20 0 0 20 0 0 20 0
*...+....1....+....2....+....3....+....4....+....5... CODE : 1 IN :1OUT :- SBCODE : 1 CODE : 1 IN :OUT :- SBCODE : 1 CODE : 1 IN :1OUT :- SBCODE : 1 _________________________ TOTAL IN : 00020 TOTAL OUT : 00010 _________________________ CODE : 2 IN :1OUT :- SBCODE : 1 CODE : 2 IN :OUT :- SBCODE : 1 CODE : 2 IN :1OUT :- SBCODE : 1 _________________________ TOTAL IN : 00020 TOTAL OUT : 00010 _________________________ CODE : 3 IN :1OUT :- SBCODE : 1 CODE : 3 IN :OUT :- SBCODE : 1 CODE : 3 IN :1OUT :- SBCODE : 1 _________________________ _________________________ TOTAL IN : 00020 _________________________ + + + + + + + + + + + +__ GR.TOT00060 ~~~~~~~~~~~~~~~~~~~~~~~~~ CODE : 1 IN :CODE : 1 IN :CODE : 1 IN :_________________________ TOTAL IN : 00040 _________________________ CODE : 2 IN :CODE : 2 IN :CODE : 2 IN :_________________________ TOTAL IN : 00040 _________________________
TOTAL OUT :
00010
GR. TOTL OUT:
00030
2OUT :OUT :2OUT :-
SBCODE : SBCODE : SBCODE :
TOTAL OUT :
2 2 2
2OUT :OUT :2OUT :-
SBCODE : SBCODE : SBCODE :
00020
TOTAL OUT :
2 2 2 00020
59
RPG-ILE LABS CODE : CODE : CODE :
3 3 3
IN :IN :IN :-
2OUT :OUT :2OUT :-
SBCODE : SBCODE : SBCODE :
2 2 2
60
RPG-ILE LABS LAB :
Matching record indicator.
CODE : * ____________________________________________________________ * Demonstrating the M1 AND L1 indicator. * ____________________________________________________________ * Database file PFBIO1 contains BCODE BIN and BOUT fields * Database file PFBIO2 contains XBCODE XBIN and XBOUT fields * which store the qty of books comming in and going out * along with their codes. * Objective is to SEE WHAT M1 DOES. * ____________________________________________________________ * FQPRINT O F 80 PRINTER FPFBIO1 IP F 12 DISK FPFBIO2 IS F 12 DISK DTOTBIN S 5I 0 INZ(0) DTOTBOUT S 5I 0 INZ(0) DXTOTBIN S 5I 0 INZ(0) DXTOTBOUT S 5I 0 INZ(0) DTEMP S 4S 0 INZ(0) iPFBIO1 AA 88 i 1 4 0bcode L1M1 i 5 8 0bin i 9 12 0bout I* iPFBIO2 AA 89 i 1 4 0Xbcode L1M1 i 5 8 0Xbin i 9 12 0Xbout C*_________________________________________ C IF *INL1 C EVAL TOTBIN=0 C EVAL XTOTBIN=0 C EVAL TOTBOUT=0 C EVAL XTOTBOUT=0 C ENDIF C* C 88 EVAL TOTBIN = TOTBIN + BIN C 88 EVAL TOTBOUT = TOTBOUT + BOUT C* C 89 EVAL TOTBIN = TOTBIN + XBIN C 89 EVAL TOTBOUT = TOTBOUT + XBOUT C*_____________________________________________________ OQPRINT D N1P 88 O 10 'CODE :' O BCODE Z 20 O 30 'IN :-' O BIN Q 40 O 50 'OUT :-' O BOUT Q 60 O*** D N1P O*** 10 '**MR**' O D N1P 89 O 10 'XCODE :' O XBCODE Z 20 O 30 'XIN :-' O XBIN Q 40 O 50 'XOUT :-'
61
RPG-ILE LABS O O O O O O
XBOUT T
L1
Q 1
60 1 20 'TOTBIN :' 30 50 'TOTBOUT :' 60
TOTBIN TOTBOUT
PF contents :
PFBIO1 BCODE 1 1 1 2 2 2 3 3 3 5 5
BIN 10 0 10 10 0 10 10 0 10 200 0
OUTPUT
BOUT 0 10 0 0 10 0 0 10 0 0 100
XBCODE 2 2 2 2 3 3 4 4
PFBIO2 XBIN 50 50 50 50 50 50 50 50
XBOUT 0 0 0 0 0 0 0 0
:
CODE : CODE : CODE : CODE CODE CODE XCODE XCODE XCODE XCODE
: : : : : : :
CODE CODE CODE XCODE XCODE
: : : : :
XCODE : XCODE : CODE : CODE :
1 1 1 TOTBIN : 2 2 2 2 2 2 2 TOTBIN : 3 3 3 3 3 TOTBIN : 4 4 TOTBIN : 5 5 TOTBIN :
IN :IN :IN :00020 IN :IN :IN :XIN :XIN :XIN :XIN :00220 IN :IN :IN :XIN :XIN :00120 XIN :XIN :00100 IN :IN :00200
10
OUT :OUT :10 OUT :TOTBOUT : 10 OUT :OUT :10 OUT :50 XOUT :50 XOUT :50 XOUT :50 XOUT :TOTBOUT : 10 OUT :OUT :10 OUT :50 XOUT :50 XOUT :TOTBOUT : 50 XOUT :50 XOUT :TOTBOUT : 200 OUT :OUT :TOTBOUT :
10 00010 10
00010 10
00010 00000 100 00100
REMARKS : The physical files must have data in ascending or descending order. Any deviation from this causes a run time error. System starts with the physical file and reads first rec from physical file. It also scans the first record in the secondary file . If the Bcode values match the MR is set ON. (we applied a M1 on BCode remember ?). The system starts processing records in primary file till Bcode does not change. Once the Bcode is found to be different in the subsequent record, system starts reading
62
RPG-ILE LABS records with the same bcode from the secondary file (if there were no matching records in the secondary file having this bcode, system will switch ON the L1 indicator and MR will never be ON in the first place)
1. 2. 3. 4.
Read records from primary file till bcode changes. If records with the same bcode are present in the secondar file read all those records in the secondary file. When all records are exhausted in the secondary file, then turn ON L1 and allow total output. Read next set of records from primary file.However, if secondary file contains records with bcode less than what primary file has, read records from the secondary file. For example in above case, PFBIO1 contains records with bcode as 2,3,4. So system first reads records with bcode=1 in primary file, then records with bcode=1 in secondary file, then records with bcode=2 in primary file then the same records in the seondary file. Then records with bcode=3 in primary and later in secondary file. Now instead of returning back to primary file for the next set, the system reads records with bcode= 4 in the seondary file and then comes back to primary file to read records with bcode=5.
PFBIO1 BCODE 1 1 1 2 2 2 3 3 3 5 5
LAB :
BIN 10 0 10 10 0 10 10 0 10 200 0
BOUT 0 10 0 0 10 0 0 10 0 0 100
XBCODE 2 2 2 2 3 3 4 4
PFBIO2 XBIN 50 50 50 50 50 50 50 50
XBOUT 0 0 0 0 0 0 0 0
Study of M1 indicator with L1 for control break.
Linkage : RPGLC6 CODE : * ____________________________________________________________ * Demonstrating the M1 AND L1 indicator. * ____________________________________________________________ * Database file PFBIO1 contains BCODE BIN and BOUT fields * Database file PFBIO2 contains XBCODE XBIN and XBOUT fields * which store the qty of books comming in and going out * along with their codes. * Objective is to SEE WHAT M1 DOES. * ____________________________________________________________
63
RPG-ILE LABS * FQPRINT O F 80 PRINTER FPFBIO3 IP F 16 DISK FPFBIO4 IS F 16 DISK DTOTBIN S 5I 0 INZ(0) DTOTBOUT S 5I 0 INZ(0) DXTOTBIN S 5I 0 INZ(0) DXTOTBOUT S 5I 0 INZ(0) DTEMP S 4S 0 INZ(0) iPFBIO3 AA 88 i 1 4 0sbcode L1M1 i 5 8 0bcode i 9 12 0bin i 13 16 0bout I* iPFBIO4 AA 89 i 1 4 0Xsbcode L1M1 i 5 8 0Xbcode i 9 12 0Xbin i 13 16 0xbout C*_________________________________________ C IF *INL1 C EVAL TOTBIN=0 C EVAL XTOTBIN=0 C EVAL TOTBOUT=0 C EVAL XTOTBOUT=0 C ENDIF C* C 88 EVAL TOTBIN = TOTBIN + BIN C 88 EVAL TOTBOUT = TOTBOUT + BOUT C* C 89 EVAL TOTBIN = TOTBIN + XBIN C 89 EVAL TOTBOUT = TOTBOUT + XBOUT C*_____________________________________________________ OQPRINT D N1P 88 O 10 'CODE :' O BCODE Z 20 O 30 'IN :-' O BIN Q 40 O 50 'OUT :-' O BOUT Q 60 O*** D N1P O*** 10 '**MR**' O D N1P 89 O 10 'XCODE :' O XBCODE Z 20 O 30 'XIN :-' O XBIN Q 40 O 50 'XOUT :-' O XBOUT Q 60 O T L1 1 1 O 20 'TOTBIN :' O TOTBIN 30 O 50 'TOTBOUT :' O TOTBOUT 60
64
RPG-ILE LABS PF contents :
PFBIO3 SBCODE 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2
OUTPUT
BCODE 1 1 1 2 2 2 3 3 3 1 1 1 2 2 2 3 3 3
BIN 10 0 10 10 0 10 10 0 10 20 0 20 20 0 20 20 0 20
BOUT 0 10 0 0 10 0 0 10 0 0 20 0 0 20 0 0 20 0
XSBCODE 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2
PFBIO4
XBCODE 1 1 1 2 2 2 3 3 3 1 1 1 2 2 2 3 3 3
XBIN 100 0 100 100 0 100 100 0 100 200 0 200 200 0 200 200 0 200
XBOUT 0 100 0 0 100 0 0 100 0 0 200 0 0 200 0 0 200 0
:
CODE CODE CODE CODE CODE CODE CODE CODE CODE XCODE XCODE XCODE XCODE XCODE XCODE XCODE XCODE XCODE
: : : : : : : : : : : : : : : : : :
CODE CODE CODE CODE CODE CODE CODE CODE CODE XCODE XCODE
: : : : : : : : : : :
1 1 1 2 2 2 3 3 3 1 1 1 2 2 2 3 3 3 TOTBIN : 1 1 1 2 2 2 3 3 3 1 1
IN :IN :IN :IN :IN :IN :IN :IN :IN :XIN :XIN :XIN :XIN :XIN :XIN :XIN :XIN :XIN :00660 IN :IN :IN :IN :IN :IN :IN :IN :IN :XIN :XIN :-
10 10 10 10 10 10 100 100 100 100 100 100 20 20 20 20 20 20 200
OUT :OUT :OUT :OUT :OUT :OUT :OUT :OUT :OUT :XOUT :XOUT :XOUT :XOUT :XOUT :XOUT :XOUT :XOUT :XOUT :TOTBOUT : OUT :OUT :OUT :OUT :OUT :OUT :OUT :OUT :OUT :XOUT :XOUT :-
10 10 10 100 100 100 00330 20 20 20 200
65
RPG-ILE LABS XCODE XCODE XCODE XCODE XCODE XCODE XCODE
: : : : : : :
1 2 2 2 3 3 3 TOTBIN :
XIN XIN XIN XIN XIN XIN XIN
:::::::-
01320
200 200 200 200 200
XOUT XOUT XOUT XOUT XOUT XOUT XOUT
:::::::-
TOTBOUT :
200 200
00660
REMARKS : First all records in the primary file with SBCODE = 1 are processed, then the system proceeds to process all records in the secondary file with XSBCODE = 1 anf when all records with sbcode/xsbcode=1 are exhausted, then the subtotal is pronted and displayed.
66
RPG-ILE LABS
LAB : SUBFILE DECLARATION FDSP1 F
CF
E
WORKSTN SFILE(SFLDATA:RRN)
LAB : Full Load subfile Linkage : rpsub CODE : fpfbm if fdssub cf drrn c c c c c c* c c c* c* c clrsr c c c c c* c ldsr c c c c c c c c c c c* c dspsr c c c c
e e s exsr exsr dow exsr EndDo Eval Return Begsr Eval Write Eval Endsr Begsr read Dow z-add movel z-add Eval Write read Enddo Endsr Begsr Seton Exfmt Setoff Endsr
DISPLAY FILE : DSSUB A A R SFLDT A DCODE A DNAME A DPRICE A
disk workstn sfile(sfldt:rrn) 4s 0 inz(0) clrsr ldsr *in03 = *off DSPSR *inlr = *on
*in52 = *on SFLCTL *in52 = *off
bm *in55=*off bcode dcode bname dname bprice dprice rrn = rrn + 1 sfldt bm
55
55
5051 sflctl 5051
4 10 7
0B B 2B
DSPSIZ(24 80 *DS3) SFL 4 9COLOR(WHT) 4 20COLOR(WHT) 4 36EDTWRD(' . ') COLOR(WHT)
67
RPG-ILE LABS A A A A A A A A A A
R SFLCTL 50 51 52
4 46'Rs' SFLCTL(SFLDT) CA03(03) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) 1 21'Book Master Information Sc COLOR(WHT)
PF contents : PFBM : Bcode, Bname and Bprice containing 12-14 records. OUTPUT
:
The contents displayed in tabular form REMARKS : Full Load Technique.
LAB : Single Page subfile. Linkage : RPSINGLE CODE : RPSINGLE FDssingle CF E WORKSTN SFILE(SFLDT:RRN) FPFBM IF E DISK Drrn S 5i 0 inz(0) Drecptr S 5i 0 inz(1) C EXSR LDSR C* C DOW *IN03 = *OFF C Eval drecptr = recptr C EXSR DSPSR c EXSR USRSR C ENDDO C* C EVAL *INLR = *ON C RETURN C* C*________________________________________________ C* C CLRSR Begsr c Eval rrn = 0 c Eval *in52 = *on c Write Sflctl c Eval *in52 = *off c EndSR c* c LDSR BEGSR c Exsr CLRSR
68
RPG-ILE LABS c recptr c* c* c* c* recptr c* c* c c c c c c c c c* c c c c* c c* c c* |~~~~~~~~| c DSPSR c c c c c c c c* c USRSR c* c* in25 = Page Up c* c c 'pag up !' c c c** c c c c** c c* c c* c* in26 = Page Down c* c c 'pag dn !' c c c** c c* c
Setll If Eval Eval Setll EndIf
bm *in77 = *on recptr = recptr -4 *in77 = *off bm
Read do Eval Eval Eval Eval Write Read
bm 4 dcode = bcode dname = bname dprice = bprice rrn = rrn + 1 SFLDT bm
If Leave Endif
%eof
77
77
ENDDO ENDSR BEGSR Eval Eval Exfmt EXSR Eval Eval ENDSR
*in50 = *in51 = sflctl USRSR *in50 = *in51 =
*on *on *off *off
BEGSR
if dsply Eval Eval
*in25 = *on
If Eval EndIf
recptr < 1 recptr = 1
EXSR
LDSR
*in25= *off recptr = recptr - 4
EndIf -> Get the next 4 records. if dsply Eval Eval
*in26 = *on
EXSR
LDSR
*in26= *off recptr = recptr + 4
Endif
69
RPG-ILE LABS c* c DISPLAY A A A A A A A A A A A A A A A A A A A A A A A A
ENDSR FILE : DSSINGLE R SFLDT DCODE DNAME DPRICE R SFLCTL
DSPSIZ(24 80 *DS3) CA03(03 'EXIT') SFL 4 20 7
0B B 2B
5
0O
50 51 52
DRECPTR
5 5 5 20 5 47EDTWRD(' . ') SFLCTL(SFLDT) SFLSIZ(0004) SFLPAG(0004) PAGEUP(25 'up') PAGEDOWN(26 'dn') SFLDSP SFLDSPCTL SFLCLR 1 25'BOOK MASTER INFORMATION DE DSPATR(RI) 3 5'CODE NAME PRICE' COLOR(WHT) DSPATR(UL) DSPATR(RI) 3 56'recptr' 3 63':' 3 66
PF contents : Typical Bcode,bname,bprice file. OUTPUT
:
Contents of the database file in a tabular form REMARKS : Single Page loading technique LAB :
expanding subfile.
Linkage : RPEXP CODE : FSUBEXP CF E WORKSTN SFILE(SFLDT:RRN) FPFBM IF E DISK drrn s 5i 0 inz(0) dRecPtr s 5i 0 inz(1) d* d*_______________________________________________ C EXSR CLRSR C EXSR LDSR C DOW *IN03 = *OFF C EXSR DspSR
70
RPG-ILE LABS C C C C C* C* C* c c c c c c* c* c c c c c* c c c c* c c c c c c c c* c c c c c c c c c* c* c* c c* c* c* c c c c c c c* c
EXSR EndDo Eval Return
UsrSR *INLR = *ON
________________________________________________ CLRSR
BegSr Eval Write Eval EndSR
LDSR RecPtr
BegSR Setll Do Read
*in52=*on SFLCTL *in52=*off
BM 4 BM %eof
Z-add Movel Z-add Eval Write EndDo EndSR
BCode DCode BName DName BPrice DPrice rrn = rrn + 1 SFLDT
DspSR
If Leave EndIf
BegSR Eval Eval Eval Exfmt Eval Eval EndSr
UsrSR check for PageDn (next set)
drecptr = recptr *in50=*on *in51=*on SflCTL *in50=*off *in51=*off
BegSR
If Eval Dsply Eval EXSR EndIf
'pg dn'
*in26=*on *in26=*off RecPtr = RecPtr + 4 LDSR
EndSR
DISPLAY FILE: SUBEXP A A A
R SFLDT
DSPSIZ(24 80 *DS3) CA03(03 'exit') SFL
71
RPG-ILE LABS A A A A A A A A A A A A A A A A A A A A
DCODE DNAME DPRICE
4 20 7
0B B 2B
R SFLCTL 50 51 52 DRECPTR
4S 0H
8 6COLOR(WHT) 8 18COLOR(WHT) 8 42EDTWRD(' . ') COLOR(WHT) 8 52'Rs' COLOR(WHT) SFLCTL(SFLDT) PAGEDOWN(26 'dn') SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) SFLRCDNBR 2 23'expanding subfile demo.' 4 24'Book Master Information ' COLOR(WHT) 6 7'Code Name rice' COLOR(WHT)
PF contents : Typical book master file. OUTPUT
:
Contents of the Book Master in tabular format. REMARKS : Expanding loading technique. LAB : Data entry subfile. Linkage : rpdatae CODE : RPDATAE FSUBDATAE CF E WORKSTN SFILE(SFLDT:RRN) DRRN S 5I 0 INZ(0) c* c* C Exsr INZSR c Dow *in03=*off C Exsr DSPSR C Exsr CHGSR c EndDO c* C Eval *inlr = *on C Return C* C* ============================================ C* C INZSR Begsr
72
RPG-ILE LABS C Eval *in52=*on C Write Sflctl C Eval *in52=*off C EndSR c* c*____________________________________________ c DSPSR Begsr c Eval *in50=*on c Eval *in51=*on c Exfmt SFLCTL c Eval *in50=*off c Eval *in51=*off c EndSR c* c* ___________________________________________ c ChgSR BegSR c ReadC SFLDT c Dow *in55=*off c DCode Dsply c DName Dsply c ReadC SFLDT c EndDo c EndSR
55
55
Display FILE : SUBDATAE A A A A A A A A A A A A A A A A A A A A A
R SFLDT DCODE DNAME DPRICE
4 20 7
0B 10 B 10 2B 10 10
R SFLCTL 50 51 52 3 6 8
DSPSIZ(24 80 *DS3) SFL 3COLOR(RED) 13COLOR(WHT) 43EDTWRD(' . ') COLOR(WHT) 54'Rs' SFLCTL(SFLDT) CA03(03) SFLDSP SFLDSPCTL SFLINZ SFLSIZ(0010) SFLPAG(0007) 25'Data Entry Subfile' 2'Enter the book details in owing table :' COLOR(BLU) 3'CODE NAME PRICE' COLOR(BLU)
PF contents : No pf OUTPUT
:
Data entered/changed is displayed by READC. REMARKS :
73
RPG-ILE LABS Data Entry can be done. LAB : Using CHAIN on Subfile. Display DSUSR : A A A A A A A A A A A A A A A A A A A A A A A A A A
R SFLDT DCODE DNAME
4 20
0B B
6 6
7
2B
6
55 DPRICE
6 R SFLCTL 50 51 52
2 3
DSPSIZ(24 80 *DS3) CF05(05) SFL 4COLOR(WHT) 14 DSPATR(RI) 38EDTWRD(' . ') COLOR(WHT) 48'Rs' SFLCTL(SFLDT) CA03(03) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0010) SFLPAG(0008) OVERLAY 4'Book Master datab COLOR(WHT) 4'_________________ COLOR(WHT)
R FOOT OVERLAY 22 2'F5:' 22 6'Remove' 22 13'Hilight'
RPUSR : Fdsusr cf e workstn sfile(sfldt:rrn) drrn s 4s 0 inz(1) dtotrec s 4s 0 inz(1) dtemp s 4s 0 inz(1) c ExSR SRClr c Exsr SRLoad c Dow *in03 = *Off c Exsr SRUsr c Exsr SRDsp c Eval *in55= *off c EndDo c Eval *inlr = *on c Return c*____________________________________________________ c SRClr BegSR c Eval *in52 = *on c Write SFLCTL c Eval *in52 = *off c EndSR c* ___________________________________________________ c SRLoad BegSR c Do 100
74
RPG-ILE LABS c Eval DCode = rrn c Eval DName = 'Abc' c Eval Dprice = 1.2 * rrn c Write SFLDT c Eval rrn = rrn + 1 c Eval totrec = totrec + 1 c EndDO c EndSR c*____________________________________________________ c* c SRDsp BegSR c Eval *in50 = *on c Eval *in51 = *on c write sflctl c write foot c Exfmt SflcTL c Eval *in50 = *off c Eval *in51 = *off c EndSR c*____________________________________________________ c SRUsr BegSR c Z-add 1 dummy c Dow dummy = 1 c Readc sfldt c If %Eof c Leave c EndIf c Eval *in55 = *on c update sfldt c EndDo c* c* Check if user wants to clear the hi-light c* User presses F5 to remove all hi-lights. c* c Eval *in55 = *off c If *in05 = *on c Eval *in05 = *off c dow temp < totrec c* c* Goto the first record of the subfile c* c temp Chain sfldt c Update sfldt c Eval temp = temp + 1 c Enddo c EndIf c EndSR Remarks : A subfile is displayed. Make changes to 2 rows and press ENTER. A READC traps the changes and switches ON the DSPATR(RI) indicator for those records. The records are thus hi-lighted. Press F5 to remove the hi-light. To remove, the system goes from first recrord of the subfile to the last and does UPDATE for each record with the DSPATR(RI) indicator being set OFF. This removes the Hi-light. LAB : Using SFLNXTCHG to fo what the above lab does. Display file :
75
RPG-ILE LABS A A A A A A A A A A A A A A A A A A A A A A A A A A A
R SFLDT 77 DCODE DNAME
4 20
0B B
6 6
DPRICE
7
2B
6
55 6 R SFLCTL 50 51 52
2 3
DSPSIZ(24 80 *DS3) CF05(05) SFL SFLNXTCHG 4COLOR(WHT) 14 DSPATR(RI) 38EDTWRD(' . ') COLOR(WHT) 48'Rs' SFLCTL(SFLDT) CA03(03) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0010) SFLPAG(0008) OVERLAY 4'Book Master datab COLOR(WHT) 4'_________________ COLOR(WHT)
R FOOT OVERLAY 22 2'F5:' 22 6'Remove' 22 13'Hilight'
RPG : Fdsusr1 cf e workstn sfile(sfldt:rrn) drrn s 4s 0 inz(1) dtotrec s 4s 0 inz(1) dtemp s 4s 0 inz(1) c ExSR SRClr c Exsr SRLoad c Dow *in03 = *Off c Exsr SRUsr c Exsr SRDsp c Eval *in55= *off c EndDo c Eval *inlr = *on c Return c*____________________________________________________ c SRClr BegSR c Eval *in52 = *on c Write SFLCTL c Eval *in52 = *off c EndSR c* ___________________________________________________ c SRLoad BegSR c Do 100 c Eval DCode = rrn c Eval DName = 'Abc' c Eval Dprice = 1.2 * rrn c Write SFLDT c Eval rrn = rrn + 1 c Eval totrec = totrec + 1
76
RPG-ILE LABS c EndDO c EndSR c*____________________________________________________ c* c SRDsp BegSR c Eval *in50 = *on c Eval *in51 = *on c write sflctl c write foot c Exfmt SflcTL c Eval *in50 = *off c Eval *in51 = *off c EndSR c*____________________________________________________ c SRUsr BegSR c Z-add 1 dummy c If *in05 = *off c Dow dummy = 1 c Readc sfldt c If %Eof c Leave c EndIf c Eval *in55 = *on c Eval *in77 = *on c update sfldt c Eval *in77 = *off c EndDo c EndIF c* c* Check if user wants to clear the hi-light c* User presses F5 to remove all hi-lights. c* c Eval *in55 = *off c If *in05 = *on c '05 on' dsply c Z-add 1 dummy c Dow dummy = 1 c Readc sfldt c If %Eof c Leave c EndIf c Eval *in55 = *off c*********** Eval *in77 = *on c update sfldt c 'remove' dsply c EndDo c Eval *in05 = *off c EndIF c EndSR
77
RPG-ILE LABS LAB :
SFLNXTCHG
Linkage : RPSFLNXT,DSSFLNXT CODE : FDSSFLNXT CF E WORKSTN SFILE(SFLDT:RRN) FPFBM IF E DISK C* Press F6 to see changed records and setof the MDT. C* Press F10 to see changed records and again SETON the MDT. C* C* drrn s 5i 0 inz(0) dCNTR s 5i 0 inz(0) dtemp s 5i 0 inz(1) dResetMDT s 5i 0 inz(1) C EXSR CLRSR C EXSR LDSR c DoW *in03=*off c EXSR DSPSR C EXSR USRSR C EndDO C Seton C Return C* C* C Clrsr BegSR C Eval *in52 = *on C Write SflCTL C Eval *in52 = *off C EndSR C* C* C LDSR BegSR c Read bm c Dow Not %EOF c Eval DCode = BCode c Eval DName = BName c Eval DPrice = BPrice c Eval RRN = RRN + 1 c Eval Cntr = Cntr + 1 c Write SFLDT c Read bm c EndDo c 'RRN :' Dsply c rrn Dsply c EndSR c* c* c DspSR BegSR c Eval *in50=*on c Eval *in51=*on c Exfmt SFLCTL c Eval *in50=*off c Eval *in51=*off c EndSR c* c* c UsrSR BegSR
lr
78
RPG-ILE LABS c c c c c* c c c c c c* c c c* c c c c* c* c* c* c c c* c c c c c* c c c* c c* c c c c c
ChgSR1
IF Eval Exsr EndIf
*in06=*on *in06=*off ChgSR1
IF Eval EXSR EndIF ENDSR
*in10=*on *in10=*off ChgSR2
BegSR Readc
DoW DCode Dsply DName Dsply --------------should we reset the MDT ? ---------------If Eval Switch on MDT Update Eval 'reset !' Dsply EndIf Readc EndDO
SFLDT
78
NOT *in78
ResetMDT = 1 *in77=*ON SFLDT *in77=*OFF
SFLDT
78
EndSR ChgSR2
BegSR eval Exsr eval EndSR
ResetMDT = 1 ChgSR1 ResetMDT = 0
DISPLAY FILE : DSSFLNXT A A A A A
R SFLDT
A A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) CA03(03) CF06(06) CF10(10) SFL
77
SFLNXTCHG DCODE DNAME DPRICE
R SFLCTL 50 51 52
4 20 7
0B B 2B
8 4COLOR(RED) 8 21COLOR(WHT) 8 48EDTWRD(' . ') COLOR(WHT) 8 59'Rs' SFLCTL(SFLDT) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0006) SFLPAG(0005) 2 18'Demo of SFLNXT Change'
79
RPG-ILE LABS A A A A A A A A A
4
5 7
4'Make changes to a record, ears the MDT but SFLNXTCHG ts the ' COLOR(WHT) 4'MDT to 1' COLOR(WHT) 4'Code Name Price' COLOR(WHT)
PF contents : Typical Book master OUTPUT
:
If 1,2 (or more) records are edited and F6 is pressed, the program shows us the records that have changed and resets their MDT. Press F6 again has no effect since the MDT of those records are now reset (ie set to 0). However, if F10 is pressed, the changed records are displayed but their MDTs are set back to 1. Pressing F10 again and again will re-display the same set of records since their MDTs are never set to zero. REMARKS : SFLNXT can be user to set ON MDT of a specific record. LAB :
Using CHAIN in subfiles.
Linkage : RPSFLCHAIN CODE : FDSSFLchainCF E WORKSTN SFILE(SFLDT:RRN) FPFBM IF E DISK c* C* Study the effect and application of CHAIN on subfile. C* Access bprice from user. All records with Bprice greater c* specified are hilighted. c* c* drrn s 5i 0 inz(0) dtemp s 5i 0 inz(1) dcntr s 5i 0 inz(1) C EXSR CLRSR C EXSR LDSR c DoW *in03=*off c EXSR DSPSR C EXSR USRSR C EndDO C Seton C Return C* C* C Clrsr BegSR C Eval *in52 = *on
lr
80
RPG-ILE LABS C Write C Eval C EndSR C* C* C LDSR BegSR c Read c Dow c Eval c Eval c Eval c Eval c Eval c Write c Read c EndDo c EndSR c* c* c DspSR BegSR c Eval c Eval c Exfmt c Eval c Eval c EndSR c* c* c UsrSR BegSR c Eval c IF c* ___________________ c*|access each record | c*|of the subfile. | c*|if the record has | c*|bprice greater than| c*|the one specified, | c*|Hilight it otherwis| c*|leave it. | c*|___________________| c Dow c temp Chain c* in77 is for SFLNXTCHG c* c if c Eval c Eval c Update c Eval c Eval c* else ! c else c Eval c Eval c Update c Eval c* c EndIf c Eval c EndDo
SflCTL *in52 = *off
bm Not %EOF DCode = BCode DName = BName DPrice = BPrice RRN = RRN + 1 Cntr = Cntr + 1 SFLDT bm
*in50=*on *in51=*on SFLCTL *in50=*off *in51=*off
temp=1 *in06=*on
temp< cntr SFLDT Dprice > DUsrPrc *in77 = *ON *in88 = *ON SFLDT *in77 = *Off *in88 = *Off *in88 = *off *in77 = *on SFLDT *in77 = *off temp=temp+1
81
RPG-ILE LABS c****************** Exsr c EndIf c ENDSR c HiLight BegSR c* 88 is for DSPATR(RI) c* c Eval c Write c Eval c c EndSR c*
HiLight
*in88 = *on SFLCTL *in88 = *off
DISPLAY FILE : DSSFLCHAIN A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A
R SFLDT 77 DCODE
4S 0B
8
88 DNAME
20A
B
8
7Y 2B
8
88 DPRICE 88 8 R SFLCTL 50 51 52 2 7 4 DUSRPRC
7
2B
4 6
DSPSIZ(24 80 *DS3) CA03(03) CF06(06) CF10(10) SFL SFLNXTCHG 4COLOR(RED) DSPATR(RI) 21COLOR(WHT) DSPATR(RI) 48EDTWRD(' . ') DSPATR(RI) COLOR(WHT) 59'Rs' SFLCTL(SFLDT) SFLSIZ(0006) SFLPAG(0005) SFLDSP SFLDSPCTL SFLCLR 18'Demo of SFLNXT Change' 4'Code Name Price' COLOR(WHT) 3'Enter upper limit for book ' COLOR(WHT) 40EDTWRD(' . ') COLOR(RED) 4'Press F6 to hi-light all r ith book prices greater tha rice' COLOR(TRQ)
PF contents : Usual PFBM file. OUTPUT
:
Enter a book price in the “Upper Limit” field. And press F6. All records where the book price is greater than the specified book price are highlighted. Reset of the records are not highlighted.
82
RPG-ILE LABS REMARKS : Principle : Scan each record in the subfile using chain. For each record check if DPRICE is greater than DUSRPRC (which is user specified price) if DPRICE is larger, switch on indicators for SFLNXTCHG and DSPATR(RI) and call UPDATE. This maeks the record active (in77) and hi-lights it (in88). Switch off both indicator. Proceed to the next record. In this manner all records are checked and MDT is set on for those who have bprice greater than specified. Hilighting is done only when SFLNXTCHG is on. If this is tried at other times, when SFLNXTCHG is off, there will be no effect.
STUDY PROGRAM For following program displays al records of the Book Master database file. It accepts book price from user and Displays all records where book price is 100 greater than specified book price in RI form.(reverse image) It displays records where bprice = specified bprice or upto specified bprice + 100 in Hi intensity (bname comes with a column sperator) Linkage : RPSFLCHAI1 Display file : DSSFLCHAI1 FDSSFLchai1CF E WORKSTN SFILE(SFLDT:RRN) FPFBM IF E DISK c* C* Study the effect and application of CHAIN on subfile. C* Access bprice from user. All records with Bprice greater c* specified are hilighted. c* c* drrn s 5i 0 inz(0) dtemp s 5i 0 inz(1) dcntr s 5i 0 inz(1) C EXSR CLRSR C EXSR LDSR c DoW *in03=*off c EXSR DSPSR C EXSR USRSR C EndDO C Seton C Return C* C* C Clrsr BegSR C Eval *in52 = *on C Write SflCTL C Eval *in52 = *off C EndSR C* C* C LDSR BegSR c Read bm c Dow Not %EOF c Eval DCode = BCode c Eval DName = BName
lr
83
RPG-ILE LABS c Eval c Eval c Eval c Write c Read c EndDo c EndSR c* c* c DspSR BegSR c Eval c Eval c Exfmt c Eval c Eval c EndSR c* c* c UsrSR BegSR c Eval c IF c* ___________________ c*|access each record | c*|of the subfile. | c*|if the record has | c*|bprice greater than| c*|the one specified, | c*|Hilight it otherwis| c*|leave it. | c*|___________________| c Dow c temp Chain c* in77 is for SFLNXTCHG c* c if c Eval c Eval c Update c Eval c Eval c Endif c if c Eval c Eval c Update c Eval c Eval c Endif c If c Eval c Eval c Eval c Update c Eval c* c EndIf c Eval c EndDo c****************** Exsr c EndIf
DPrice = BPrice RRN = RRN + 1 Cntr = Cntr + 1 SFLDT bm
*in50=*on *in51=*on SFLCTL *in50=*off *in51=*off
temp=1 *in06=*on
temp< cntr SFLDT (Dprice *in77 = *in88 = SFLDT *in77 = *in88 =
- DUsrPrc)> 100 *ON *ON
(Dprice *in77 = *in89 = SFLDT *in77 = *in89 =
- DUsrPrc)<=100 and Dprice >=dUsr *ON *ON
*Off *Off
*Off *Off
DPrice < DUsrPrc *in88 = *off *in89 = *off *in77 = *on SFLDT *in77 = *off temp=temp+1 HiLight
84
RPG-ILE LABS c ENDSR c HiLight BegSR c* 88 is for DSPATR(RI) c* c Eval c Write c Eval c c EndSR c*
*in88 = *on SFLCTL *in88 = *off
DISPLAY FILE : A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A LAB :
DSPSIZ(24 80 *DS3) CA03(03) CF06(06) CF10(10) SFL SFLNXTCHG
R SFLDT 77 DCODE
4S 0B
8
4
88 89
DSPATR(RI) DSPATR(UL) DNAME
20A
B
88 89 DPRICE
7Y 2B
88 89 R SFLCTL 50 51 52
DUSRPRC
7
2B
8 21 DSPATR(RI) DSPATR(CS) 8 48EDTWRD(' DSPATR(RI) DSPATR(HI)
.
')
8 59'Rs' SFLCTL(SFLDT) SFLSIZ(0006) SFLPAG(0005) SFLDSP SFLDSPCTL SFLCLR 2 18'Demo of SFLNXT Change' 7 4'Code Name Price' COLOR(WHT) 4 3'Enter upper limit for book ' COLOR(WHT) 4 40EDTWRD(' . ') COLOR(RED) 6 4'Press F6 to hi-light all r ith book prices greater tha rice' COLOR(TRQ)
Multiple active subfiles.
Linkage : rpmulti,dsmulti CODE : FDSMULTI FPFBM
CF IF
E E
WORKSTN SFILE(SFLDT1:RRN1) SFILE(SFLDT2:RRN2) DISK
85
RPG-ILE LABS FPFBIO IF dRRN1 dRRN2 C C C C C C C C C C C CLRSR1 C C C C C* C* C CLRSR2 C C C C C C LDSR1 C C C C C C C C C C C* C LDSR2 C C C C C C C C C C C* c DSPSR1 c c c c c c c* c DSPSR2 c
E s s EXSR EXSR EXSR EXSR DOW EXSR EXSR ENDDO EVAL Return Begsr Eval Write Eval EndSR Begsr Eval Write Eval EndSR Begsr Read Dow Eval Eval Eval Eval Write Read EndDo EndSR Begsr Read Dow Eval Eval Eval Eval Write Read EndDo EndSR BegSR Eval Eval Exfmt Eval Eval EndSR BegSR Eval
DISK 5i 0 5i 0 CLRSR1 CLRSR2 LDSR1 LDSR2 *IN03 = DSPSR1 DSPSR2
Prefix(x) inz(0) inz(0)
*OFF
*inlr = *on *in52 = *on SFLCTL1 *in52 = *off
*in62 = *on SFLCTL2 *in62 = *off
BM NOT %EOF DCode1 = BCode DName = BName DPrice = BPrice RRN1 = RRN1 + 1 SFLDT1 bm
Bio NOT %EOF DCode2 = xBCode DBin = XBin DBout = XBout RRN2 = RRN2 + 1 SFLDT2 bio
*in51=*on *in50=*on SFLCTL1 *in50=*off *in51=*off
*in61=*on
86
RPG-ILE LABS c c c c c
Eval Exfmt Eval Eval EndSR
DISPLAY FILE A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A
*in60=*on SFLCTL2 *in60=*off *in61=*off
:
R SFLDT1 DCODE1 DNAME DPRICE
4 20 7
0B B 2B
4 4 4 4
R SFLCTL1 50 51 52 1 3 R SFLDT2 DCODE2 DBIN DBOUT R SFLCTL2
4 4 4
0B 18 0B 18 0B 18
60 61 62
14 16
DSPSIZ(24 80 *DS3) CA03(03) SFL 5COLOR(WHT) 18COLOR(WHT) 43EDTWRD(' . ') COLOR(WHT) 53'Rs' SFLCTL(SFLDT1) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) 25'Book Master Information' COLOR(WHT) 6'Code Name Price' SFL 10 22 31 SFLCTL(SFLDT2) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0004) SFLPAG(0003) OVERLAY 12'Transaction Details' COLOR(RED) 11'Code IN OUT' COLOR(WHT)
PF contents : PFBM : book master PFBIO : Book I/O file. OUTPUT
:
Simple displays all records in the respective files in the respective subfiles. It is a simple display program. REMARKS : ---
LAB : Cursor location in the subfile. SFLCSRRRN Linkage : TESTRPG1, TESTSFL
87
RPG-ILE LABS CODE : ftestsfl cf e drrn s d* c c c c c* n is declared in c n c c c c* c* c Clrsr c c c c c* c* c LDSR c c c c c c c c c* c DSPSR c c c c c c DISPLAY A A A A A A A A A A A A A A A
workstn sfile(sfldt:rrn) 5i 0 inz(0) Exsr clrsr Exsr ldsr Dow *in03=*off exsr dspsr display file as a SFLCSRRRN variable. dsply EndDo Eval *inlr=*on Return BegSR Eval Write Eval EndSR BegSR do Eval Eval Eval Eval Write Enddo EndSR BegSR Eval Eval Exfmt Eval Eval EndSR
*in52=*on SflCTL *in52=*off
10 DCode = rrn DName = 'aaa' DPrice = rrn * 5 rrn=rrn+1 SFLDT
*in50=*on *in51=*on SflCTL *in50=*off *in51=*off
FILE : R SFLDT DCODE DNAME DPRICE R SFLCTL
DSPSIZ(24 80 *DS3) CA03(03) SFL 4 20 7
0B B 2B
50 51 52
N
6 7 6 18 6 41EDTWRD(' . SFLCTL(SFLDT) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) SFLCSRRRN(&N)
')
5S 0H 3
7'test subfile'
88
RPG-ILE LABS PF contents : nil OUTPUT
:
SFLCSRRRN loads the rrn number of the record where cursor is present into the supplied variable : N. Thus if cursor is on the second page and second record (and page size is 5 ) then n=7. REMARKS : Can get direct access to exact rrn number of the subfile where the cursor is located. LAB : Use SFLCRSRRN,SFLRCDNBR to access record positions of a subfile and display transaction details of book in a transaction file. Linkage : TESTRPG2,sUBMOD, Display : TESTSFL CODE : TESTRPG2 : D* D* c c
Callb Eval
'SUBMOD' *inlr=*on
SUBMOD : FTestsfl cf e FPFBM IF E FPFbio IF E drrn s drrn1 s dtemp s d* Procedure prototypes dclrsr pr dldsr pr ddspsr pr dUsrsr pr dclrsr1 pr dldsr1 pr d ddspsr1 pr dShowSubfile pr d d* --------------d* Main Procedure. d* --------------c Eval c CAllp c Callp c Dow c Callp c* c If
workstn Disk Disk 5i 0 5i 0 4s 0
sfile(sfldt:rrn) sfile(sfldt1:rrn Prefix(x) inz(0) inz(0) inz(0)
5i 0 4s 0 4s 0
drecptr=1 clrsr ldsr *in03=*off dspsr *in06=*on
89
RPG-ILE LABS c Eval *in06=*off c callp UsrSR c EndIf c* c EndDo c Eval *inlr=*on c Return c* c* _____________________________________ c* PClrSR B dclrsr pi c Eval *in52=*on c Write SflCTL c Eval *in52=*off PClrSR E c* c* PLdSR B dLdsr pi c Read BM c dow Not %EOF c Eval DCode = BCode c Eval DName = BName c Eval DPrice = BPrice c Eval rrn = rrn + 1 c Write SFLDT c Read BM c Enddo PLdSR E c* c* PDspSR B DDspSR PR c Eval *in50=*on c Eval *in51=*on c if n <> 0 c Eval drecptr = n c EndIf c Exfmt SflCTL c Eval *in50=*off c Eval *in51=*off PDspSR E c* PUsrSR B DUsrSR PR dtemp s 4s 0 inz(0) c* check where the cursor is. c* if n is zero, cursor is not in the subfile at all. c* n is a parameter given to SFLCSRRRN in the subfile. c* c If n=0 c return c endIf c* read the subfile record where cursor is present c n chain sfldt c* c* -----------------------------------------c* show matching records in the transaction file in a new subfile. c Eval temp = dcode
90
RPG-ILE LABS c Callp ShowSubfile(temp) PUsrSR E c* c*=================================================== c* showsubfile displays the second subfile containing c* matching records from the transaction file. c* PShowSubFile B DShowSubFile PI dtheCode 4s 0 dretval s 5i 0 c*arg theCode contains the dcode, c callp clrsr1 c Eval retval = ldsr1(theCode) c* c If retval =-1 c* no records were loaded !!! c 'no records !'dsply c return c EndIf c* c callp dspsr1 c return PShowSubFile e PClrsr1 b dClrsr1 PI c Eval rrn1=0 c Eval *in62=*on c Write sflctl1 c Eval *in62=*off PClrsr1 e c* PLdsr1 b dLdsr1 PI 5i 0 dbkcode 4s 0 dretval s 5i 0 c 'filter :' dsply c bkcode dsply c Eval rrn1 = 0 c 1 Setll bio c Read bio c Dow Not %EOF c* c* pickup only records where bcode matches c If xBCode = bkcode c Eval DCode1 = xBCode c Eval DBin = xBin c Eval DBout = xBout c Eval RRN1 = RRN1 +1 c write Sfldt1 c EndIf c Read bio c Enddo c If rrn1=0 c* No records where loaded!!! c 'no rec !' dsply c Eval retval=-1 c return retval c else c Eval retval=1
91
RPG-ILE LABS c c c PLdsr1 PDspSR1 c c c c c PDspSR1
return
retval
EndIf E B Eval Eval Exfmt Eval Eval
*in60 = *in61 = Sflctl1 *in60 = *in61 =
*On *On *Off *Off
E
DISPLAY FILE : A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A A
R SFLDT DCODE DNAME DPRICE R SFLCTL
DSPSIZ(24 80 *DS3) CA03(03) CF06(06) SFL 4 20 7
0B B 2B
50 51 52 DRECPTR N
R SFLDT1 DCODE1 DBIN DBOUT R SFLCTL1 60 61 62
4S 0H 5S 0H
6 7 6 18 6 41EDTWRD(' . SFLCTL(SFLDT) SFLSIZ(0005) SFLPAG(0004) SFLDSP SFLDSPCTL SFLCLR SFLCSRRRN(&N) SFLRCDNBR
')
4 57'F6 : lookup Transaction' COLOR(BLU) 1 9'Book Master Records' COLOR(RED) SFL 4S 0B 17 10 4S 0B 17 20 4S 0B 17 29 SFLCTL(SFLDT1) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0005) SFLPAG(0004) OVERLAY 15 23'Transaction Details...' COLOR(RED) DSPATR(UL)
PF contents : Frist subfile displays all records records from PFBIO. The selection place cursor on a record and press and transaction records related to is displayed. OUTPUT
of the PFBM. Second subfile displays select criteria comes from the frist subfile. Use will F6. The dcode at the cursor location is scanned that bcode are loaded into the second subfile that
:
92
RPG-ILE LABS All contents of Book master, select contents of BIO table. (PFBM and PFBIO are accessed) REMARKS : --LAB : Window Subfile Linkage : DSWINSFL LAB :
Window Subfile.
Linkage : CODE : A A A A A A A A A A A A A A
R SFLDT DCODE DNAME DPRICE
4 20 7
0B B 2B
7 7 7 7
R SFLCTL 50 51 52
A
DSPSIZ(24 80 *DS3) CA03(03) SFL 10COLOR(RED) 19COLOR(WHT) 33EDTWRD(' . ') COLOR(WHT) 43'Rs' SFLCTL(SFLDT) SFLDSP SFLDSPCTL SFLCLR SFLSIZ(0011) SFLPAG(0007) .
WINDOW(2 2 16 60)
A A A A A A A A A
4 6 6 6
OVERLAY 18'Subfile Test' COLOR(WHT) 10'Code' COLOR(WHT) 20'Name' COLOR(WHT) 34'Price' COLOR(WHT)
Subfile code for RPG remains the same. PF contents :
OUTPUT
:
REMARKS :
93
RPG-ILE LABS
LAB : Introduction to Triggers. Database Trigger programming. STRUCTURE OF STUDENT MASTER (SM) PF : A R SMAS A SROLL 4S 0 A SNAME 10A CAUTION : FOLLOWING PROGRAM GIVES INCORRECT RESULTS FOR C
EVAL
VCD2=%TRIM(%SUBST(VCD1:NOFF:4))
SUITABLE FUNCTION TO CONVERT THE CHARECTER REPRESENTATION OF A STRING INTO NUMERIC IS REQUIRED. REST OF THE PROGRAM GIVES THE DATA IN THE RECORD SEND BY THE DB ENGINE TO THIS PROGRAM VIA COMMAND LINE ARGUMENTS. DPARM1 DS 130 DNOFF 65 68B 0 DPARM2 DS DLENG 1 40 DLEN1 S 4S 0 DVCD1 S 130A DVCD2 S 10A DROLLNO S 4F D* ___________________________________________________ C *ENTRY PLIST C PARM1 PARM PARM1 C PARM2 PARM PARM2 C NOFF DSPLY C* C EVAL VCD1=PARM1 C EVAL VCD2=%TRIM(%SUBST(VCD1:NOFF:4)) C VCD2 DSPLY C ADD 5 NOFF C EVAL VCD2=*BLANKS C EVAL VCD2=%SUBST(VCD1:NOFF:10) C VCD2 DSPLY C* 5STUDENT5 C EVAL *INLR=*ON C RETURN C*
94
RPG-ILE LABS LAB : Working with Procedures in the ILE program. Compilation procedure. Variable life time and scoping. Local and Global variables. Using procedure in the same application : Create the Following program : P1 TYPE : RPGLE. * --------------------------* * --------------------------DADDNUM pr 5i 0 dA1 5i 0 dA2 5i 0 DA s 5i 0 DB s 5i 0 DX s 5i 0 c eval A=5 c eval B=20 c eval x=ADDNUM(A:B) c X dsply c seton C* ____________________________________________ C* PADDNUM B DADDNUM PI 5I 0 DNUM1 5I 0 DNUM2 5I 0 DRES S 5I 0 C EVAL RES=NUM1+NUM2 C RETURN RES PADDNUM E
LR
Use option 15 to create a Module object. Then use command CRTPGM to create program object. For CRTPGM, specify the module as P1 and program object name as any name like , say, P1. this creates a P1 object in the current library.
95
RPG-ILE LABS LAB : PASS ARGUMENTS BY VALUE / PASS BY REFERENCE MODULE R0 CALLS PROCEDURES IN MODULES R1 (ILLUSTRATES CALL BY REF AND CALL BY VALUE ) DFN1 DX1 DFN2 DX2 DNUM1 DNUM2 C C C C C C C
PR 5I 0 PR 5I 0 VALUE 5I 0 INZ(10) 5I 0 INZ(10)
S S NUM1
DSPLY CALLP DSPLY DSPLY CALLP DSPLY SETON
NUM1 NUM2 NUM2
FN1(NUM1) FN2(NUM2) LR
MODULE R1 DEFINES MODULES : HNOMAIN DFN1 DA DFN2 DB
PR 5I 0 PR 5I 0 VALUE
PFN1 DFN1 DA C C C PFN1
B PI
PFN2 DFN2 DB C C C PFN2
B PI
EXPORT IF EVAL ENDIF
5I 0 A = 10 A = A + 1
E EXPORT IF EVAL ENDIF
5I 0 VALUE B = 10 B = B + 1
E
96
RPG-ILE LABS LAB : CALL SUBROUTINES FROM PROCEDURES. R0 CALL 1 PROCEDURE FROM THE R1 MODULE : LISTING OF R0 : DFN1 DX1 DNUM1 DNUM2 C NUM1 C C NUM1 C
PR 5I 0 5I 0 INZ(10) 5I 0 INZ(10)
S S DSPLY CALLP DSPLY SETON
FN1(NUM1) LR
R1 DEFINES THE PROCEDURES (ONE IS EXPORTED) LISTING OF R1 : HNOMAIN DFN1 DA DFN2 DB PFN1 DFN1 DA D* C C C C C* C SR1 C C PFN1 PFN2 DFN2 DB C C C PFN2
PR 5I 0 PR 5I 0 VALUE EXPORT
B PI
5I 0 IF CALLP ENDIF EXSR BEGSR EVAL ENDSR
A=10 FN2(A) SR1 A=A+5
E B PI IF EVAL ENDIF
5I 0 VALUE B = 10 B = B + 1
E
LAB : Calling CL (CLLE) Modules from the RPGLE program. Rpgle Source program that call the CLLE procedure : * ---------------------------------| CALLING BOUND CLLE PROCEDURE | * ---------------------------------DPROC1 PR C CALLB 'PROC1' C SETON
LR
CLLE Program called by the above RPGLE program :
97
RPG-ILE LABS 0001.00 pgm 0002.00 WRKSPLF 0003.00 endpgm
LAB : CALLB R0 : CLIENT APPLICATION : DFN1 DX1 DNUM1 C C NUM1 C C NUM1 C
PR S CALLB DSPLY CALLP DSPLY SETON
5I 0 5I 0 INZ(10) 'R1'
<-- DIRECT CALL TO R1
FN1(NUM1) LR
R1 MODULE HAS MAIN CODE : NOMAIN IS REMOVED. DFN1 PR DA 5I 0 DVAL1 S 5I 0 INZ(10) C CALLP FN1(VAL1) C 'MAINCODE END'DSPLY C SETON C*__________________________________________ PFN1 B EXPORT DFN1 PI DA 5I 0 D* C IF A=10 C EVAL A=A+10 C ENDIF PFN1 E
LR
98
RPG-ILE LABS LAB : *VARSIZE RPCLIENT : Main line code : DFn1 DStr1 dS1 dS2 dS3 c c C C C C C
PR 4a 3a 8a 1a
s s s Callp Callp Callp Eval Return
OPTIONS(*VARSIZE) inz('abc') inz('abcxyzmn') inz('a')
Fn1(s1) Fn1(s2) Fn1(s3) *inlr = *on
RPAVG : NOMAIN Module used by RPCLIENT H NOMAIN dMyds dLnNum dStatus d* dFn1 dstr PFn1 dFn1 dstr1 dRslt c c c rslt PFn1
sds 21 *status
28
PR 4a
OPTIONS(*VARSIZE) Export
4a 20a
OPTIONS(*VARSIZE)
B PI s Eval Dsply
Rslt = 'I Got : '+ str1
E
99
RPG-ILE LABS LAB : Creating Service programs. Accesing methods from client programs.bind by REFERENCE. CRTSRVPGM : SPECIFY NAME AS S1. MODULE : R1 CRTPGM : PROGRAM NAME : P2 MODULE : R0 SERVICE PROGRAM NAME : S1 CALL P2 TO TEST P2. LAB : Binder Directory. CRTBNDDIR : Create the B1 object. WRKBNDDIR : To Add entries select option 9. LAB : Importing and Exporting Procedures and Variables. R0 EXPORTS A VARIABLE TO BE ACCESSED AND CHANGED BY ANOTHER MODULE R1. LISTING OF RO : DFN1 DX1 DNUM1 DNUM2 C C C C C C C
PR 5I 0 5I 0 INZ(10) 5I 0 INZ(25)
S S NUM2 NUM2 NUM1 NUM1
DSPLY CALLB DSPLY DSPLY CALLP DSPLY SETON
EXPORT
'R1' FN1(NUM1) LR
R1 MODULE : H* DNUM2 S 5I 0 IMPORT DFN1 PR DA 5I 0 DVAL1 S 5I 0 INZ(10) C CALLP FN1(VAL1) C EVAL NUM2=NUM2+100 C NUM2 DSPLY C 'MAINCODE END'DSPLY C SETON C* C* ----------------------------------------PFN1 B EXPORT DFN1 PI DA 5I 0 D*
LR
100
RPG-ILE LABS C C C PFN1
IF EVAL ENDIF
A=10 A=A+10
E
OUTPUT : DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
25 125 MAINCODE END 125 10 20
Additions to ILE LABS : LAB : *NOPASS : optional parameter. Need not be passed. Will be passed only if the need is there. dP1 PR 2s 0 d 5i 0 d 5i 0 d 10a d 10a options(*NOPASS) d* dn1 s 5i 0 inz(100) dn2 s 5i 0 inz(8) ds1 s 10a inz('C') ds2 s 10a inz('ACAD') dRetVal s 2s 0 inz(0) C Eval RetVal=P1(N1:N2:S1) C Eval *INLR = *ON C Return C*-------------------------------------------------PP1 B dP1 PI 2s 0 dn1 5i 0 dn2 5i 0 ds1 10a ds2 10a Options(*NOPASS) // parameter with NOPASS should
dlocal s dParams s c 'Procedure' Dsply c Eval c If c 'all 4 passed'dsply c EndIf c If c '3 passed' dsply c EndIf c Eval c return PP1 E
// be at the last. 2s 0 5i 0 params = %PARMS() params = 4 params = 3 Local=18 Local
101
RPG-ILE LABS OUTPUT : DSPLY DSPLY
Procedure 3 passed
NOPASS should be at the end : last parameters should be no pass. Intermediate parameters cannot be NOPASS. ( Compare this with C++ : Argumentative polymorphism) Because parameters are positional, once you specify *NOPASS on a parameter, all parameters after that must be also be coded with *NOPASS. When the procedure is called, if an optional parameter is omitted, all parameters after that must also be omitted. A procedure can check if an optional parameter was passed by using the %PARMS built in function. %PARMS will be set to the number of parameters passed. Lab : *OMIT dP1 PR 2s 0 d 5i 0 d 5i 0 d 10a d 10a options(*OMIT) d* dn1 s 5i 0 inz(100) dn2 s 5i 0 inz(8) ds1 s 10a inz('C') ds2 s 10a inz('ACAD') dRetVal s 2s 0 inz(0) C Eval RetVal=P1(N1:N2:S1:*omit) C Eval *INLR = *ON C Return C*-------------------------------------------------PP1 B dP1 PI 2s 0 dn1 5i 0 dn2 5i 0 ds1 10a ds2 10a Options(*OMIT) dlocal s 2s 0 c 'Procedure' Dsply c Eval Local=18 c return Local PP1 E
LAB : *OMIT to avoid passing some intermediate parameters. dP1 d d
PR
d options(*OMIT) not be
2s 0 5i 0 5i 0
10a // this parameters may
102
RPG-ILE LABS
//
sent in some cases
d 10a d* dn1 s 5i 0 inz(100) dn2 s 5i 0 inz(8) ds1 s 10a inz('C') ds2 s 10a inz('ACAD') dRetVal s 2s 0 inz(0) C Eval RetVal=P1(N1:N2:*OMIT:S2) C Eval *INLR = *ON C Return C*-------------------------------------------------PP1 B dP1 PI 2s 0 dn1 5i 0 dn2 5i 0 ds1 10a Options(*OMIT) ds2 10a dlocal s 2s 0 dParams s 5i 0 c 'Procedure' Dsply c Eval params = %PARMS() // even when
a parameters is not sent,%PARM
// still returns 4 c If params = 4 c 'all 4 passed'dsply c EndIf c If params = 3 c '3 passed' dsply c EndIf c* c* S1 is not passed by the calling procedure,so S1's address c* will be *NULL c* c If %addr(S1) = *null c 'S1 omitted' dsply c EndIf c Eval Local=18 c return Local PP1 E
OUTPUT DSPLY DSPLY DSPLY
: Procedure all 4 passed S1 omitted
LAB : Major advantage of Binder Language.
We've seen up to this point that by using bind-by-reference rather than bind-by-copy we have a much simpler maintenance task. When simple changes are made to the procedures (for example,
103
RPG-ILE LABS to fix bugs), only the service program needs to be updated. The programs that are bound to the service program will automatically use the new procedure the next time they are called.
The problem is when we make a less superficial change to a module. If, for example, we add a new procedure to a module, or add optional parameters to an existing procedure, a different signature will get generated when we create the service program. All programs that are bound to that service program will need to be rebound, or they will get a signature violation error when called.
At first, this seems like a pretty major oversight. The reason signature checks were added to ILE was to prevent a program from calling a module with unknown changes, possible causing serious application errors. This is very similar in concept to level checks on database files.
Also like level checks, there is a way around the problem. By using binder language you can explicitly assign a signature to a service program which will override the system generated one.
LAB : Signature
Signatures When a service program is created, it is assigned a unique signature based on the procedure sequence and exports. When a program is bound to a service program, it is bound to the signature as well. If new procedures are added to the service program, or exports are re-arranged, a different signature will be generated. If the program is run against the new version of the service program without being re-bound, a run-time error will generate.
A signature in this sense is very similar to a record format level identifier. If a record format changes and the program is not re-compiled, you will get a level check error which is very similar to a signature violation.
By using a binder language you can explicity specify a signature and eliminate signature violations.
Lets assume we have a source member called PROC1 that has three procedures in it - DayOfWeek, Uppercase, and Lowercase. In our example, this source member will get compiled into a module, and a service program will get created from the module.
The binder source for the service program will look like this:
STRPGMEXP EXPORT EXPORT EXPORT ENDPGMEXP
PGMVAL(*CURRENT) SIGNATURE('PROC1a') SYMBOL('DayOfWeek') SYMBOL('Uppercase') SYMBOL('Lowercase')
104
RPG-ILE LABS When we create the service program with the following command:
CRTSRVPGM SRVPGM(library/PROC1) MODULE(PROC1) EXPORT(*SRCFILE) SRCFILE(library/sourcefile) SRCMBR(binder-source)
The service program will then be given a signature of "PROC1a" rather than a system generated one. If we make changes to the PROC1 module, we can determine ourselves if all programs using it need to be changed.
If we made simple changes, added procedures, or added optional parms to the end of a procedure interface, we could retain the existing signature.
If we made changes that we know will require modifications to the calling procedures, we can assign a new signature of "PROC1b". This will force us to change and re-bind our programs.
LAB : RTVSRVSRC : auto generate the binder language code for a given service program Create a service program from modules M1, M2, M3. Each modules exports 2 subprocedures, thus 6 procedures are exported. Some of these can be suppresed. Instead of writing the binder language member from sctracth, use RTVSRVSRC and provide name of the service program to it. The command prepares a member (of NO specific type) and writes export definations to it. Change type of this member to BND. Comment out all exports that you do not want to export and then re-create service prgoram using CRTSRVPGM. LAB : Type casting dP1 PR 2s 0 d 5i 0 d 4a d* dn1 s 5i 0 inz(100) d*s1 (cannot pass smaller size) 4a inz('C') ds1 s 6a inz('ABCDEF') dRetVal s 2s 0 inz(0) C Eval RetVal=P1(N1:S1) C Eval *INLR = *ON C Return C*------------------------------------------------PP1 B dP1 PI 2s 0 dn1 5i 0 ds1 4a dlocal s 2s 0 c s1 Dsply c Eval Local=18 c return Local PP1 E
105
RPG-ILE LABS Although the procedure expects an argument of size 4a, we pass 6a. (less will cause compiler error). Truncation will happen. Data is stored left justified.
Several important points about procedure parameter typecasting:
1. Automatic conversion will only occur if the expected parameter and the passes parameter are the same general type. For example, numeric data will not be converted to character.
2. Shorter than expected numeric fields can safely be passed to a procedure. Longer than expected numeric fields can also passed, however if a significant digit is truncated, you will get a run-time overflow error.
3.
Character strings of a greater length than expected may be passed. Right-side truncation will occur (similar to MOVEL).
4.
The keyword OPTIONS(*VARSIZE) may be coded on the D-specs of the procedure interface and prototype to allow shorter length than expected character strings.
LAB : Operational Descriptor keyword and the CEEDOD API (should be called to retrieve the length of the passed field which is controlled by *VARSIZE) Objective : To get length of data in the field passed as a VARSIZE parameter.
LAB : LAB :
LAB : supress the main procedure of a module in a service program using a binder language code,.
106
RPG-ILE LABS
107
RPG-ILE LABS
LAB : Binder Language and UPDSRVPGM. CLIENT APPLICATION CODE : LECLI1 IN LESRC SOURCE FILE. *
CALLING A PROCEDURE FROM SERVICE PROGRAM LESER2 * dADDNUM pr 5i 0 dA1 5i 0 dSUBNUM pr 5i 0 dA1 5i 0 D* __________________________________ Da s 5i 0 Db s 5i 0 Dx s 5i 0 c eval a=5 c eval b=20 c eval x=a+ADDNUM(B) c X dsply C* ------- ASKING FOR SOMETHING ILLEGAL... C EVAL X=A+SUBNUM(B) C X DSPLY c seton
lr
SERVER APPLICATION CODE : WE SHALL EXPORT ONLY THE ADNUM AND SUBNUM FUNCTIONS OUT OF THE TOTAL 4 FUNCTIONS DEFINED IN THE LESER1 MODULE. (IN THE LESRC SOURCE PF) HNOMAIN H* ____________PROTOTYPE SECTION ____________ H* __________________________________________ DADDNUM pr 5i 0 DA1 5i 0 DSUBNUM pr 5i 0 DA2 5i 0 DMULNUM pr 5i 0 DA2 5i 0 DDIVNUM pr 5i 0 DA2 5i 0 D* __________ PROTOTYPE SECTION ENDS __________ D* -------------------------------------------D* PADDNUM B export DADDNUM PI 5i 0 DA1 5i 0 Dresult S 5i 0 C eval result=A1+1 C 'ADDING**' DSPLY C return result PADDNUM e P* __________________________________________ PSUBNUM B export DSUBNUM PI 5i 0 DA2 5i 0 Dresult S 5i 0 C eval result=A2-1 C 'SUBTRACT*' DSPLY C return result PSUBNUM e
108
RPG-ILE LABS P* __________________________________________ PMULNUM B export DMULNUM PI 5i 0 DA2 5i 0 Dresult S 5i 0 C eval result=A2*2 C return result PMULNUM e P* __________________________________________ PDIVNUM B export DDIVNUM PI 5i 0 DA2 5i 0 Dresult S 5i 0 C eval result=A2/2 C return result PDIVNUM e THE BINDER LANGUAGE MEMBER NAME : S1 STRPGMEXP export export endpgmexp
TYPE : BND
PGMLVL(*CURRENT) SYMBOL(ADDNUM) SYMBOL(SUBNUM)
PROCEDURE : 1. Create the client application (LECLI1) that calls the procedures ADDNUM and SUBNUM. The prototypes of the procedures are given in the client application. Use option 15 to create the Module oBject of the client application. 2. Create the LESER1 server application as specified in the above code. It contains 4 procedures, but we wish to export only the 2 procedures : ADDNUM and SUBNUM. 3. Now create a Binder Language member s1 of the type BND and specify the above code in it. IT is clear that ADDNUM and SUBNUM are the only procedures exported. 4. Use CRTSRVPGM to create a service program. Specify the name of the Service program as S1, Export as *SRCFILE, Export source file as LESRC (all our program members are in LESRC) and export source member as S1. Since the Binder language code S1 is guiding th process of creation of the service program, onlu the exported procedures are now available to client applications. 5. Finally, use CRTPGM to specify LECLI1 as the module (PEP) and S1 as the service program. The program P1 is created and can be run using CALL P1. 6. Make a change in the LECLI module : Write SOME code that uses MULNUM function. (SOMETHING LIKE EVAL X = mulnum(B) or so…) After writing the code, convert the LECLI1 code to Module object by using option 15. The module creates OK with 00 severity. 7. Now try creating a program P2 using the LECLI1 Module and S1 service program (as we did while creating P1). The program is not created. This is because the Binder language code in the S1 (BND) object does not allow export of MULNUM procedure. Thus we need to make a change in the S1 Member. 8. Change the S1 Binder language member as follows : STRPGMEXP export export export endpgmexp
PGMLVL(*CURRENT) SYMBOL(ADDNUM) SYMBOL(SUBNUM) SYMBOL(MULNUM)
109
RPG-ILE LABS 9. Use Update Service program (UPDSRVPGM) to update this service program with the new Binder language definition (in addition, you also need to specify the LESER1 module object in the parameters of this command). 10. Use CRTPGM to create a program object P2 from LECLI1 And S1 service program.
110
RPG-ILE LABS LAB : Using CALLB to call main line code in a Module. Exchange data using IMPORT And EXPORT.
Calling Application Code : LEMNCLI TYPE : RPGLE *
________________________________________________________ * THIS MODULE CALLS THE LEMN MODULE WITH A CALLB OPCODE. * N1 AND N2 ARE EXPORTED WHILE LEMN EXPORTS THE AVGNUM VARIABLE * WHICH CONTAINS THE AVERAGE CACULATED BY LEMN. * ________________________________________________________ * * DN1 s 5i 0 EXPORT DN2 s 5i 0 EXPORT DAVNUM s 5i 0 IMPORT C eval N1=10 C eval N2=10 C CALLB 'LEMN' C AVNUM DSPLY C SETON LR
Called Application Code : LEMN TYPE : RPGLE ( Note
: Module name should be in CAPS. )
*
________________________________________________________ * THIS MODULE HAS MAIN LINE CODE THAT WILL BE CALLED * BY CLIENT APPLICATION USING CALLB OPCODE. * N1 N2 VALUES COME FROM THE CLIENT APPLICATION * WHILE THE COMPUTED VALUE OF AVNUM (AVERAGE) IS EXPORTED * BY THIS MODULE. * ________________________________________________________ * * DN1 s 5i 0 IMPORT DN2 s 5i 0 IMPORT DAVNUM s 5i 0 EXPORT C eval AVNUM=((N1+N2)/2) C SETON
LR
Creation : Use option 15 for both to create their respective module objects and then use CRTPGM to create a program out of those modules. * * *
111
RPG-ILE LABS
COMPARISON CHART RPG/400 OPM Model All variables global Subroutines for modularity Only 1 H specs 50 F specs FC for giving additional details HFELICO Dynamic calls OPM debugger Opcodes are 5 characters Data types : S,P,A,L etc C-specs for calculation No built-in functions Not ideal for huge projects and serious dead lines Poor readability Programs run in def act grp
ODP shared by programs tend to have problems with recordf pointer position 3 indicators to condition C-spec line Scaterred : declarations in I,C and E specs Indicators to know result of operations
RPG ILE ILE Model Global as well as local Subroutines, procedures and modules give very high degree of modularity and ease of of software Testing Many Many Keywords instead of FC HFDICOP Dynamic and Static calls ILE debugger 10 characters max D –specs CX : extended C specs : EVAL New opcodes : IF, DOW, SELECT, CALLB Large number of Built-in functions Very mature : ease of coding. Code reuse, modularity and ease of testing making development fasters Improved readability Can run in dft act grp (provided ILE extensions are not used) in a compatilbity mode. Can be run in separate activation groups (recommended) OPD shared by programs need not share same fil epointer if programs run in separate activation groups. Only 1 indicator. Multiple indicators converted to multiple lines. Structured and planned : All declarations go in D specs Indicatorless programming : Functions tell status.
112
RPG-ILE LABS
OPERATION EXTENDERS : RPG/400 READ BM
N 55
N is to read a record without locking the same ILE – RPG : READ(N)
BM 5
(H) : Half Adjust Result of calculation to be ROUNDED.(exceptions are DIV,MVR) (P) : Pad the resulting string on the RIGHT hand side rather than left hand side. Suppose S1 = “ABC” (size of this var is 3) Suppose S2 = “bbbbbbbb” ( 8 spaces ) MOVE S1 Causes a padding of S2 on left.
S2
S2 = “bbbbbABC” MOVE(P)
S1
S2
Causes a padding of S2 on the Right. Padding is done for MOVEA,MOVEL,SUBST,XLATE
113
RPG-ILE LABS CHEAT SHEET THE LIMITS CHEAT SHEET MAX RECORDS IN PF : 10,000 + 3000 MAX FIELDS IN PF : 7000 MAX KEYED FIELDS IN PF : 8 MAX LF BASED ON PF : 32 MAX DECIMAL POSITIONS FOR ZONED / PACKED : 30 MAX LENGTH OF CHARACTER FIELD : 32,767 MAX VALUES FOR SPACEA AND SPACEB : 255 FIELD / ARRAY NAME = DS NAME = FILE NAM = REC FMT NAME = 10 CONSTANT SIZE = 1024 DS SIZE = 32767 NO OF ARRAY ELEMENTS = 32767 NAMED CONSTANT = 1024 SEE PAGE 38 OF MOVING TO ILE
114
RPG-ILE LABS MORE ON SPECIFICATIONS F specs FX SPECS E SPECS L SPECS
: PROGRAM DECSRIBED FILES : EXTERNALLY DESCRIBED FILES. : EXTENSION SPECS : ELIMITED IN RPG ILE : LINE COUNTER SPECS : ELIMITED IN RPG ILE
Notes and TESTED programs : The Integrated Language Environment introduced with OS/400 Version 2 Release 3 and the new RPG IV language definition in Version 3 Release 1 writes the next chapter on RPG and AS/400 programming. The RPG 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12.
IV language: Re-formats and simplifies the RPG specifications forms and at the same time. Adds new functions, most of them to answer customer requests. Removes some of the column-orientation limitations and introduces the capability of free-format arithmetic expressions and built-in functions. Lifts the RPG file, field and array name length restrictions. Expands and removes some of the language limitations, such as the number of files, and the number and size of arrays. Allows usage of uppercase and lowercase in symbolic names. Offers better support for date and time operations. Adds new functions and improves some of the existing functions. Prepares the languages for future enhancements and growth. Allows participation in the new Integrated Language Environment (ILE).
115
RPG-ILE LABS CONVERSION CONSIDERATIONS CVTRPGSRC Source: details of the Source RPG file, member type, Soruce PF and library Target : Name of LE source physical file,Member name and library name. EXPAND COPY MEMBER EXPCPY: SET THIS TO *YES If you are using a /COPY in the source member. FREE and DEBUG operations in RPG /400 are not supported in RPG LE. H-SPEC KEYWORDS ALTSEQ CURSYM DATEDIT DATFMT DEBUG DECEDIT DFTNAME FORMSALIGN FTRANS
Forms alignment
Alternate collating sequence Currency symbol Date edit code Date format Debug option Decimal notation 80 Program or module identification File translation
116
RPG-ILE LABS Lab : Select a record format from a LF (amongst the multiple record formats) Create 2 physical files : BMAST and PMAST (book master and publisher master) Create a LF as follows : A A A A A A A A A
R BM BCODE BNAME BPRICE K *NONE R PM PCODE PNAME K *NONE
PFILE(BKMAST)
PFILE(PMAST)
The LF combines all fields in the 2 physical files as shown above. RUNQRY on the LF returns records only from the first record format. From ILE (or RPG) you can specify which record format is to be accessed as follows : FJOINLF IF C C BCODE C BNAME C BPRICE C PCODE C
E READ DSPLY DSPLY DSPLY DSPLY SETON
DISK JOINLF
INCLUDE(BM) 44
LR
RPG/400 EQUIVALENT -----------------FFILE1 F F F
UF DISK FMT1 KIGNORE FMT2 KIGNORE FMT3 KCOMMIT
E
This renaming of input database fields is not required in RPG IV since the limits have been increased.
117
RPG-ILE LABS
NEW / ENHANCED KEYWORDS KEYWORD{(VALUE)} COMMIT{(RPG-NAME)} DATFMT(format{seperator}) FORMLEN(number)
RPG/400 COMIT option in FC spec N/a Pos 18-19 on L-specs
FORMOFL(number)
Pos 20-22 on L specs
OFLIND(indicator) PLIST(Plist parameters)
Pos 33-34 PLIST option on continuation line
RECNO(fieldname) RENAME(ExtFmtNam:IntFmtNa m) SFILE(rcdFmtNam:RRN)
RECNO option on cont line RENAME option on cont line SFILE option on cont
TIMFMT(format{seperator})
N/a
USROPN
UC on pos 71-72
DESCRIPTION Commitment control Form length of PRINTER file Line number specified in overflow line Overflow indicator Parm list to be passed to program given in PGMLIST keyword DISK file processed by RRN To rename rec fmt of externally desc files. First param is SFLDT sec is RRN variable Default time format and optional time seperator User controlled open of file
118
RPG-ILE LABS Chapter 3 : RPG FUNCTIONS AND FEATURES (MOVING TO ILE) FOCUS : FUNCTIONAL ENHANCEMENTS. LAB : Study of RENAMED opcodes Some of them are RETURN, OCCUR,SETOFF,UNLOCK,WHENxx LAB : RENAMING a record format name FpfBMAST iF C C bcode C C
E Read Dsply Eval Return
DISK newBM
rename(bm:newbm) 88
*inlr =*on
119
RPG-ILE LABS
CHAPTER 3 : ILE ADVANCED CONCEPTS
LAB : Working with Date validation. Program to accept date as a simple number and test of it is valid or not. Program writes in Date value to a date variable only if the value is Valid. This is the best way of entering dates from the user. BEST PRACTICE : Input the date from the user as a sinple 6S 0 numeric value. Proper edit code and edit word should be used. Test this number (for example : 311204 using the TEST(D) opcode. Specify the proper Format (such as *DMY) in the factor 1 and check the state f the indicator in the LO section. Of the Indicator remains off, the date is correct. This,way, the onus of checking correctness of the date (including leap years and other factors) is on the system. Even the PSSR or ERRMSG is not required. Display file listing : DSDATE2 : A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) CA03(03) R RDATE 5 10'INPUT THE DATE YOU WISH TO TEST’ 8 10'===> ' COLOR(BLU) 6Y 0B 8 17EDTWRD(' / / ') EDTMSK(' & & ') 6 10'(Format : DD/MM/YY' 6 29')' 12 11'Press ENTER to check...' COLOR(BLU)
FLD001
INPUT THE DATE YOU WISH TO TEST (Format : DD/MM/YY ) ===> ________
Press ENTER to check...
RPGLE program : RPDATE2 : H DATFMT(*DMY) FDsdate2 CF E WORKSTN DDT1 S D D* fld001 IS A 6S 0 FIELD : SIMPLE NUMERIC FIELD BUT HAS APPEARANCE
120
RPG-ILE LABS D* OF DATE FIELD DUE TO EDIT WORD AND EDIT MASK. D* __________________________________________________________________ D* C DOW *IN03 = *OFF C MOVE *ZEROS fld001 C EXFMT RDATE C *DMY TEST(D) fld001 77 C IF *IN77 = *ON C EVAL *IN77 = *OFF C 'INVALID' DSPLY C ELSE C *DMY MOVE fld001 DT1 C DT1 DSPLY C ENDIF C ENDDO C SETON LR Lab : sample Data entry and validation program. Display file : DSDATAENT A*%%TS A*%%EC A A A A A A*%%TS A A A A A A A A A A A A 90 A A 91 A A 92 A A A A A A A
SD
20040704
073607
SAM2
REL-V3R7M0
5716-PW1
DSPSIZ(24 80 *DS3) CF10(10) CA12(12) CF07(07) SD
R RDATAENT 20040704 073607
SAM2 1 5 8 10 12
DCODE DNAME DPRICE
4S 0B 10A
8
B 10
7Y 2B 12 17 18
REL-V3R7M0 5716-PW1 8'BOOK MASTER DATA ENTRY' 2'SPECIFY THE DATA AND PRESS F10 TO SAVE' COLOR(BLU) 3'CODE : ' COLOR(WHT) 3'NAME : ' COLOR(WHT) 3'PRICE : ' COLOR(WHT) 12COLOR(WHT) DSPATR(RI) 12COLOR(WHT) DSPATR(RI) 12EDTWRD(' . ') DSPATR(RI) COLOR(WHT) 4'_________________________________________ ' COLOR(BLU) 5'F10:SAVE F12:CANCEL F7:VALIDATE' COLOR(BLU)
Module for validation : MVLD000001 HNOMAIN FPFBM5 UF A E F* D* --- VALIDATION --D*
DISK
121
RPG-ILE LABS DVLD_DT PR 4S 0 DDCODE 4S 0 VALUE DI1 1A DDNAME 10A VALUE DI2 1A DDPRICE 7S 2 VALUE DI3 1A D* --- SAVE DATA TO PFBM5 --D* DSAVE_DATA PR 4S 0 DDCODE 4S 0 VALUE DDNAME 10A VALUE DDPRICE 7S 2 VALUE P*1 PSAVE_DATA B EXPORT DSAVE_DATA PI 4S 0 DDCODE 4S 0 VALUE DDNAME 10A VALUE DDPRICE 7S 2 VALUE DRETVAL S 4S 0 INZ(1) C* DOES ALL SAVING TO PHYSICAL FILE C* C READ BM C EVAL BCODE=DCODE C EVAL BNAME=DNAME C EVAL BPRICE=DPRICE C WRITE BM C* CHECK WRITE ERROR C IF *IN77=*ON C EVAL RETVAL=0 C* WRITE WAS NOT SUCCESSFUL C* C ELSE C EVAL RETVAL=1 C* WRITE WAS SUCCESSFUL C ENDIF C RETURN RETVAL PSAVE_DATA E PVLD_DT B EXPORT DVLD_DT PI 4S 0 DDCODE 4S 0 VALUE DI1 1A DDNAME 10A VALUE DI2 1A DDPRICE 7S 2 VALUE DI3 1A DRETVAL S 4S 0 INZ(1) C* C* START VALIDATION FOR DCODE C* C IF ((DCODE<100) OR (DCODE > 700)) C EVAL I1 = '1' C ELSE C EVAL I1 = '0' C ENDIF C*C* C* START VALIDATION FOR DNAME C* C IF DNAME=*BLANKS
44
77
122
RPG-ILE LABS C EVAL I2 = '1' C ELSE C EVAL I2 = '0' C ENDIF C* C* START VALIDATION FOR DPRICE C* C IF DPRICE<0 C EVAL I3 = '1' C ELSE C EVAL I3 = '0' C ENDIF C* C* ATLEAST 1 INDICATOR IS ON IF DATA IS NOT VALID C* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ C IF ((I1 = '1') OR (I2 = '1') OR (I3 = '1')) C EVAL RETVAL=0 C ELSE C EVAL RETVAL=1 C ENDIF C* C RETURN RETVAL C* PVLD_DT E P* -----------------------------------------The Entry point module : RPDATAENT Displays the display file for user to input data. FDSDATAENT CF E WORKSTN ENTRY FILE F* D* ----------------------------------------DRETVAL S 4S 0 INZ(1) DRETARR S 4S 0 DIM(20) D* D* -----------------------------------------D* RETVAL,RETARR CONTAINS GENERAL ERROR CODE D* AND VARIABLE SPECIFIC ERROR CODE D* ----------------------------------------D* PROCEDURE PROTOTYPES BEGIN DVALIDATE_DATA PR 4S 0 DDCODE 4S 0 VALUE DDNAME 10A VALUE DDPRICE 7S 2 VALUE DVLD_DT PR 4S 0 DDCODE 4S 0 VALUE DI1 1A DDNAME 10A VALUE DI2 1A DDPRICE 7S 2 VALUE DI3 1A DSAVE_DATA PR 4S 0 DDCODE 4S 0 VALUE DDNAME 10A VALUE DDPRICE 7S 2 VALUE D* PROCEDURE PROTOTYPES END C DOW *IN12 = *OFF C EXFMT RDATAENT
DATA
MAIN
123
RPG-ILE LABS C*-( C C C C C C C C C C C C C C C
IF EVAL RETURN ENDIF IF EVAL EVAL EVAL EVAL IF EVAL ENDIF ENDIF ENDDO
*IN12 = *ON *INLR = *ON
MAIN
*IN07=*ON *IN90 = *OFF *IN91 = *OFF *IN92 = *OFF RETVAL=VLD_DT(DCODE:*IN90:DNAME:*IN91:DPRICE :*IN92) RETVAL = 1 RETVAL = SAVE_DATA(DCODE:DNAME:DPRICE)
124
RPG-ILE LABS
LAB : First program for Pointer operation DN1 DS1 DPtr1 C C C S1 C
S S S EVAL EVAL DSPLY EVAL
4S 0 inz(120) 4A * Ptr1 = %ADDR (N1) S1 = %Str(Ptr1) *inlr = *on
LAB : Second program on pointers DS1 S 4A inz('pqrs') DS2 S 4A DPtr1 S * C EVAL Ptr1 = %ADDR (S1) C EVAL S2 = %Str(Ptr1) C S2 DSPLY C*output : pqrs C EVAL S1 = *BLANKS C EVAL %Str(Ptr1:5) = 'abcd' C* In the above expr. abcd is loaded into the pointer C* from position 1 of abcd to position 4 abcd. Scanning stops at C* position 5. thus 5 is the number of characters read from the RHS C* expression. C* OUTPUT : abcd C S1 dsply C EVAL *inlr = *on LAB : Third program on pointers Pointer to a Data Structure. Later, this pointer can be passed as argument to a validation procedure. The procedure will write results of the validation to the data structure. DDS1 ds DS1 30A DS2 30A DS3 30A DPtr1 S * Dstr S 90A D*------------------------------------------C EVAL Ptr1 = %Addr(DS1) C eval str = 'CODE not between 100&700 C 'Name cannot be BLANK ' + C 'Price cannot be Negative' C EVAL %Str(Ptr1:(%Size(str)+1))=str C S1 DSPLY c S2 DSPLY c S3 DSPLY C EVAL *INLR = *ON LAB :
'
Pointers
Linkage : RPPOINTER
125
RPG-ILE LABS CODE : Ds1 s 5a inz('xyz') Ds2 s 5a inz(' ') Dps1 s * c Eval ps1 = %Addr(s1) c Eval %Str(ps1:4) = 'abc' c* _____________________________________________________________ c* |%Str(ps1:4) <- Load 'abc' into positions 1,2,3 of ps1. c* |4th pos is for the terminator which is added automatically. c* |____________________________________________________________ c s1 Dsply c Eval s2 = %Str(ps1) c s2 Dsply c Eval *inlr=*on PF contents :
OUTPUT
:
REMARKS :
LAB :
Pointer
Linkage : --CODE : Ds1 Dn1 Ds2 Dps1 c c
s s s s Eval Eval
5a inz(' 123') 5i 0 5a * ps1 = %Addr(s2) %STR(PS1:6) = S1
c* Populate the first 5 positions of the variables to which ps1 points c* with contents of s2.6th position is for the terminator. c s2 c c c n1 c C* OUTPUT : C* 123 C* 124
dsply Move Eval Dsply Eval
s2 n1 = n1 + 1
n1
*inlr=*on
PF contents :
126
RPG-ILE LABS
OUTPUT
:
REMARKS :
LAB :
Pointer oepration
Linkage : CODE : Linkage : RPPOINTER1 d* Illustrates passing a pointer as a argument to a function. d* Converting the text contents (actually '123') to numeric d* doing some processing on the numeric data and re-converting d* back to string and storing the result to pointer. d* dFn1 PR dp * d* Ds2 s 5a inz(' 107') Dps1 s * c Eval ps1 = %Addr(s2) c callp Fn1(Ps1) c s2 Dsply c Eval *inlr=*on c* ---------------------------------------c* PFn1 B DFn1 PI dpArg1 * dTemp s 5a dTempn s 5i 0 c Eval Temp = %Str(pArg1) c move Temp Tempn c Eval Tempn = Tempn + 1 c move Tempn Temp c Temp dsply c Eval %Str(pArg1:6) = Temp PFn1 E PF contents :
OUTPUT
:
REMARKS :
127
RPG-ILE LABS LAB : Return pointer to Data Structure 2 modules implemented as follows : M1 and M2 M1 Listing : H DATFMT(*DMY) DDs001 ds DDys 2a DMnt 2a DYrs 2a DFind_Difference PR DD1 d DD2 d Dpr * D*--------------------------------------------------DD1 s D INZ(D'27/01/04') DD2 S D INz(D'15/03/04') Dpr s * inz(*NULL) dTemp s 8a D* c EVAL pr = %Addr(Ds001) C CAllp Find_Difference(D1:D2:pr) c EVAL Temp = %Str(pr:7) c Temp dsply C Eval *inlr = *on C Return C* ------------------------------------------------------M2 Listing : H* Module TO CALCULATE THE TIME DIFFERENCE BETWEEN 2 date VALUES. h NOMAIN DATFMT(*DMY) DFind_Difference PR DD1 d DD2 d Dpr * D* ------------------------------------------------PFind_Difference B export DFind_Difference PI DD1 d DD2 d Dpr * D*--DYrs s 2s 0 inz(0) DMnt s 2s 0 inz(0) Ddys s 2s 0 inz(0) DYrs1 s 2a DMnt1 s 2a Ddys1 s 2a Dtemp s 8a C D2 SUBDUR D1 Yrs:*Y C D1 addDUR Yrs:*Y D1 C D2 SUBDUR D1 Mnt:*M C D1 addDUR Mnt:*M D1 C D2 SUBDUR D1 Dys:*D c movel yrs yrs1 c movel mnt mnt1 c movel dys dys1
128
RPG-ILE LABS c c C PFind_Difference
EVAL EVAL Return
temp = dys1+mnt1+yrs1 %STR(pr:7) = temp
E
Purpose is to calculate days,months and years between 2 dates. The calculation is done by a procedure in module M2 which is NOMAIN module. It recieves D1,D2 and PR (pointer to DS defined in M1) Values are assigned to pointer that causes data to load into the DS defiend in M1. LAB : Linkage : CODE : Linkage : RPPOINTER2 Listing : d* d* __________________________________________________________ d* Simple program to illustrate a pointer to a Data structure. d* The pointer to DS is passed as a argument to a procedure d* Processing can be done in the procedure. d* ___________________________________________________________ d* dFn1 PR dp * dDS001 DS Ds1 15a inz('This is') Ds2 15a inz('a test') D* Dps1 s * c Eval ps1 = %Addr(DS001) c callp Fn1(Ps1) c Eval *inlr=*on c* ---------------------------------------c* PFn1 B DFn1 PI dpArg1 * dTemp0 s 30a dTemp1 s 15a dTemp2 s 15a c Eval Temp0 = %Str(pArg1) c Eval Temp1 = %Subst(Temp0:1:15) c Eval Temp2 = %Subst(Temp0:16:15) c Temp1 dsply c Temp2 dsply PFn1 E PF contents :
OUTPUT
:
129
RPG-ILE LABS REMARKS :
LAB :
Pointer to a DS
Linkage : CODE : Pass a pointer to DS to it in strings of length Main thing here is that component of DS) can be
a function that will decipher the data in the DS and display 10. Multi occurances of DS can be any value. The length of s1 (a any value.
Only condition : Occurances * size of Base (s1 ) > = 10 d* d* __________________________________________________________ d* DS of any size can be passed. Only condition is as follows : d* (no of occurances * sizeof(s1) ) > 10 d* and should be a multiple of 10. d* ___________________________________________________________ d* TARGET : In the next program, show this data in a Window Subfile ! dFn1 PR dp * d 4s 0 d 4s 0 d***** dnOccurs s 4s 0 inz(40) d* // MUST contain no of occurances of the data structure. dnSize s 4s 0 inz(20) d* // MUST contain size of S1 which is the only member of the data d* // structure. dDS001 DS occurs(40) Ds1 20a inz('aaa') D* Dps1 s * c Eval ps1 = %Addr(DS001) c callp Fn1(Ps1:nOccurs:nSize) c Eval *inlr=*on c* ________________________________________ PFn1 B DFn1 PI dpArg1 * dnOccurs 4s 0 dnSize 4s 0 d*---------------------------------------dnLoops s 4s 0 dnStPos s 4s 0 dnCntr s 4s 0 inz(0) d*------------------------------------------dnBase s 4s 0 inz(10) d* nBase is always 10 !!! d*-------------------------------------------
130
RPG-ILE LABS d* var is the variable that will hold 10 positions of data from the input d* total data. dvar s 10a c Eval nLoops = (nOccurs * nSize)/10 c Do nLoops c Eval nStPos = (nBase * nCntr)+1 c Eval var = %Subst(%Str(pArg1):nStPos:nBase) c Eval nCntr = nCntr + 1 c var Dsply c EndDO c 'loops :' dsply c nLoops dsply PFn1 E PF contents : OUTPUT
:
REMARKS : Suppose Element s1 in DS001 is of the size 40. The number of occurances of the SD are 20. Total size = 40 * 20 = 800. WE wish to break this 800 into units of 10 since the variable that will hold the data will have a size of 10. Thus number of iterations for the loop that shows those 800 bytes are 800/10 = 80. WE access 10 positions at a time of this 800 characters long string by using substring(). Data type conversion LAB : Convert string to int Linkage : CODE : Linkage : RPCONV ds1 dn1 c c c c
s s Eval Eval dsply Eval
n1
5a inz('123') 5s 0 inz(108) n1 = %Int(s1) n1 = n1 + 1 *inlr = *on
PF contents :
OUTPUT
:
131
RPG-ILE LABS REMARKS :
132
RPG-ILE LABS
LAB : Simple Error handling dMyPsds sds dSts *status derr_line_no 21 28 dnsts s 4s 0 inz(0) dArg1 s 4s 0 inz(12) dArg2 s 4s 0 inz(0) dRslt s 4s 0 inz(0) dRtPoint s 6a dTemp s 4s 0 inz(0) c '-------' Dsply c 'Start..' dsply c '-------' Dsply c Opr1 Tag c Eval Rslt = Arg1 / Arg2 c Rslt Dsply c '--- ' Dsply c Eval *inlr = *on c Return c* c* c *pssr BEGSR c Move sts nsts c Move err_line_no Temp c* is the error divide by zero ? ie 102 ? c If nsts = 102 c Eval Arg2=2 c else c* error is not a divide by zero End program. c Eval RtPoint = '*CANCL' c Endif c If RtPoint <> '*CANCL' c goto Opr1 c Endif c Endsr RtPoint OUTPUT : DSPLY ------DSPLY Start.. DSPLY ------DSPLY 6
Program requests a Starting position outside the string length thus causing control to jump into the PSSR error handler. PSSR displays lot of information.
133
RPG-ILE LABS FDSERR CF E WORKSTN DString1 s 10a inz('abcdefghij') DStPos s 2s 0 inz(3) DNumOfChar s 2s 0 inz(4) DRslt s 10a D* DMyPSDS sds DErr_Status *status DErr_ProcName *Proc DErr_Routine *Routine DERr_LineNum 21 28 DErr_ExcpType 40 42 DErr_ExcpNum 43 46 DErr_PgmLib 81 90 DErr_ExcpData 91 170 DErr_ExcpID 171 174 DErr_Date 191 198 DErr_Year 199 200s 0 DErr_User 254 263 DErr_FileInfo 209 243 D*-----------------------------------------------------------------c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* output : cdef c Eval StPos = 10 c Eval NumofChar = 1 c Eval Rslt = *All' ' c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* output : j c* ------------------------------------c* Deliberately cause an error condition c* give an invalid starting position. c* c Eval StPos = 12 c Eval NumofChar = 4 c Eval Rslt = *All' ' c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* output : ? c 'Prg ENDED' DSPLY c Eval *inlr = *on c Return c* c* ===================================== c *PSSR BEGSR c movel Err_excpdata DExcpData c exfmt Rerr c 'pssr' DSPLY c 'Line number' dsply c Err_Linenum dsply c 'Err_Status' dsply c Err_Status dsply c 'Err_ProcName'dsply c Err_ProcName dsply c 'Err_Routine' dsply c Err_Routine dsply c 'Err_ExcpType'dsply c Err_ExcpType dsply c 'Err_ExcpNum' dsply
134
RPG-ILE LABS c Err_ExcpNum dsply c 'Err_PgmLib' dsply c Err_PgmLib dsply c* Err_ExcpData dsply c 'Err_ExcpID' dsply c Err_ExcpID dsply c 'Err_Date' dsply c Err_Date dsply c 'Err_Year' dsply c Err_Year dsply c 'Err_User' dsply c Err_User dsply c 'Err_FileInfo'dsply c Err_FileInfo dsply c EVAL StPos = 1 c EVAL NumOfChar = 3 c* c* c* GETIN causes control to start from the First C-spec line in the c* Program ! Cannot use GETIN c* GETIN actually stands for GET INPUT REC which reads next record c* from next run of the Logic Cycle. c* DETC also does same thing. Not specifying anything in the Factor 2 of c* ENDSR also does not solve the problem. The system error handler is c** displayed after PSSR executes of nothing is specified in Factor 2. C* solution to this problem can be found in the next lab. C* c* ENDSR '*GETIN' c* c ENDSR Output Error Data was displayed in a Display File : error data : Length or start position is out of range for the string operation. DSPLY cdef DSPLY j DSPLY pssr Err_Status Err_ProcName Err_Routine Err_ExcpType Err_ExcpNum Err_PgmLib Err_ExcpData Err_ExcpID Err_Date Err_Year Err_User Err_FileInfo
DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
100 RPSCAN *DETC RNX 0100 SAM2 07062004 20 SAM2
LAB : Error Handling *************** Beginning of data ********************************* 0001.00 D* Program demonstrates Exception handling.Program has
135
RPG-ILE LABS 0002.00 0003.00 0004.00 0005.00 0006.00 0007.00 0008.00 0009.00 0010.00 0011.00 0012.00 0013.00 0014.00 0015.00 0016.00 0017.00 0018.00 0019.00 0020.00 0021.00 0022.00 0023.00 0024.00 0025.00 0026.00 0027.00 0028.00 0029.00 0030.00 0031.00 0032.00 0033.00 0034.00 0035.00 0036.00 0037.00 0038.00 0039.00 0040.00 0041.00 0042.00 0043.00 0044.00 0045.00 0046.00 0047.00 0048.00 0049.00 0050.00 0051.00 0052.00 0053.00 0054.00 0055.00 0056.00 0057.00 0058.00 0059.00 0060.00 0061.00
D* 3 SubSt statements. any of them can have an error.Typical D* error condition is simulated by setting starting position D* for SubSt to an excessively large value. Thus a call D* to SubSt causes control to enter PSSR. The PSDS D* contains a important variable - Err_LineNum (u can change D* the name) that contains the line number of the code D* that caused the error. (this line number is the physical line D* number from the top of the code. Count lines occupied by Comment D* statement also !. D* Thus you can check against line number and cause a GOTO to D* appropriate position. D* D* ---------------------------------------------------------D* DString1 s 10a inz('abcdefghij') DStPos s 2s 0 inz(15) DNumOfChar s 2s 0 inz(4) DRslt s 10a DLineNum s 9s 0 inz(0) DMyPSDS sds DErr_Status *status DERr_LineNum 21 28 c OPR1 TAG c* Line number of following eval statement is 26. c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* c* delibrately cause and error c* c Eval StPos = 44 c Eval NumofChar = 4 c Eval Rslt = *All' ' c OPR2 TAG c* Line number of following eval statement is 36. c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* c* ------------------------------------c* Deliberately cause an error condition c* give an invalid starting position. c* c Eval StPos = 12 c Eval NumofChar = 4 c Eval Rslt = *All' ' c OPR3 TAG c* Line number of following eval statement is 48. c Eval Rslt = %SubSt(String1:StPos:NumOfChar) c Rslt Dsply c* c 'Prg ENDED' DSPLY c Eval *inlr = *on c Return c* c* c *PSSR BEGSR c 'pssr' DSPLY c 'Line number' dsply c Err_Linenum dsply c 'Err_Status' dsply c Err_Status dsply
136
RPG-ILE LABS 0062.00 0063.00 0064.00 0065.00 0078.00 0079.00 0080.00 0081.00 0082.00 0083.00 0084.00 0085.00 0086.00 0087.00 0088.00 0090.00
c* c* Convert to Numeric c* c Move c EVAL c EVAL c If c Goto c Endif c If c Goto c Endif c If c Goto c Endif c ENDSR
Err_LineNum LineNum StPos = 1 NumOfChar = 3 LineNum = 26 OPR1 LineNum = 36 OPR2 LineNum = 48 OPR3
Output : DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
pssr Line number 00000026 Err_Status 100 abc pssr Line number 00000036 Err_Status 100 abc pssr Line number 00000048 Err_Status 100 abc
LAB : Work on TESTN dNumericData s 4a inz('120') dCharData s 4a inz('abc') dBlankData s 4a d* c TESTN NumericData 777879 c* 78 becomes on since variable contains leading spaces. c* No indicator will be on if data is numeric and has no leading c* spaces. c* c exsr dspsr c TESTN CharData 777879 c* no indicator is on since data not numeric c exsr dspsr c TESTN BlankData 777879 c* Equal indicator on since data is blank. c exsr dspsr c Eval *inlr = *on c Return
137
RPG-ILE LABS c* c c c c c c c c
dspsr *in77 *in78 *in79
Begsr dsply dsply dsply Eval Eval Eval Endsr
*in77=*Off *in78=*Off *in79=*Off
138
RPG-ILE LABS LAB : Handling ESCAPE messages The RPGLe program calls a CLP program that sends a *PRV Pgm msg that is not displayed on the screen. Then it sends a PGM MSG of the type *ESCAPE which causes control to immediately return back into RPGLE (ignoring the WRKSPLF in the CLP) the control enters PSSR and displays various parameters of the error MSG thus received from the child application. If the parent application in this case was a CL program, it would have used program level monmsg . RPGLE Program : Fdserr cf e DMyPSDS sds DErr_Status *status DErr_ProcName *Proc DErr_Routine *Routine DERr_LineNum 21 DErr_ExcpType 40 DErr_ExcpNum 43 DErr_ExcpData 91 DErr_ExcpID 171 c 'Before' dsply c call c end1 Tag c 'After' dsply c Eval c Return c* c* c *PSSR BEGSR c 'pssr' DSPLY c move c exfmt c 'Line Number' DSPLY c Err_Linenum DSPLY c 'Err_Status' dsply c Err_Status dsply c 'Err_ProcName'dsply c Err_ProcName dsply c 'Err_Routine' dsply c Err_Routine dsply c 'Err_ExcpType'dsply c Err_ExcpType dsply c 'Err_ExcpNum' dsply c Err_ExcpNum dsply c Goto c ENDSR
workstn
28 42 46 170 174 'CLERR' *inlr = *on
err_excpdata rerr
dexcpdata
end1
CLERR Program : PGM SNDPGMMSG SNDPGMMSG WRKSPLF
MSG('THIS IS CLERR.') TOPGMQ(*PRV) MSGID(CAE0032) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDPGM OUTPUT : DSPLY Before DSPLY pssr
139
RPG-ILE LABS DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
Line Number 00000014 Err_Status 202 Err_ProcName RPSCAN2 Err_Routine CLERR Err_ExcpType CAE Err_ExcpNum 0032 After
I tried to see the step by step execution but could not add CLERR program since it is a OPM program ( Said *YES to OPM source level debugging as well as a *YES to updte production files) still I cannot add CLERR to the list of programs debugged. When the CALL statemnt was executed, STRDBG did not show the code or step by step execution of code in the CLERR program. CLERR was executed instantly and control went directly to PSSR. LAB : Error Handling in the procedure Program P1 created from 2 modules : RPCLIENT and RPAVG : Listing of RPCLIENT : (Main procedure) DRslt DFn1 DN1 DN2 DN3 DFn2 DN1 DN2 Da1 Da2 Da3 c c C C Rslt C C Rslt C C C C
s PR
4s 4s 4s 4s 4s 4s 4s 4s 4s 4s 4s
PR s s s Eval Dsply Eval Dsply Eval Return
0 0 0 0 0 0 0 0 0 inz(0) 0 inz(0) 0 inz(0)
Rslt = Fn1(a1:a2:a3) Rslt = Fn2(a1:a2) *inlr = *on
Listing of RPAVG ( NOMAIN Module) H NOMAIN dMyds dLnNum dStatus d*
sds 21 *status
28
140
RPG-ILE LABS dFn1 dx1 dy1 dz1 dFn2 dx2 dy2 dRslt PFn1 dFn1 dx1 dy1 dz1 c c c c c c* c c c c c c c c c PFn1 PFn2 dFn2 dx2 dy2 c c c c c* c c c c c c c PFn2
PR
PR s B PI
0 0 0 0 0 0 0 0
4s 4s 4s 4s
0 0 0 0
Export
z-add Eval Tag Return
cnt1 *Pssr 'Pssr1' LnNum Status
*zeros x1 Rslt = (x1+y1+z1)/x1
Begsr Dsply Dsply Dsply If Goto Endif Endsr
Rslt
LnNum = '00000021' cnt1
E B PI
Export 4s 0 4s 0 4s 0 *zeros x2 Rslt = (x2+y2)/x2
z-add Eval Tag Return
Cnt2 *Pssr 'Pssr2'
LAB :
4s 4s 4s 4s 4s 4s 4s 4s
Begsr Dsply If Goto Endif Endsr
Rslt
LnNum = '00000040' cnt2
E Testing correctness of date entered.
Linkage : DSDTDATE, RPDATETEST CODE : PROGRAM : RPDATETEST HDatfmt(*dmy-) FDsDtTest cf dCheckDate dto_be_tested
e PR
workstn 5i 0 6s 0
141
RPG-ILE LABS dretval s 5i 0 ddt s 6s 0 c*O c Dow *in03 = *off c Exfmt Rec1 c Eval dt = ddt001 c Eval RetVal = CheckDate(dt) c Select c when Retval = -1 c Eval dstat = 'Wrong !' c when Retval = 1 c Eval dstat = 'Correct' c other c 'huh ?!' dsply c endsl c EndDo c* -O c Eval *inlr = *on c return c* Check Date procedure c* ____________________________________________________ PCheckDate B DCheckDate PI 5i 0 dTestDate 6s 0 dRetVal s 5i 0 inz(0) c *DMY TEST(D) TestDate c if *in66=*on c Eval RetVal = -1 c Else c Eval RetVal = 1 c EndIf c Return RetVal PCheckDate E
66
Display file : DSDTTEST A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) R REC1
DDT001
6Y 0B
2 5 7 12
DSTAT
10
O 12
CA03(03) WINDOW(2 2 20 40) 13'Date Test Program' 5'Enter date to test :' 6COLOR(BLU) EDTWRD(' - - ') EDTMSK(' & & ') 7'Status :' COLOR(WHT) 18COLOR(WHT)
PF contents : nil OUTPUT
:
REMARKS :
142
RPG-ILE LABS
143
RPG-ILE LABS LAB : /COPY precompiler directive RP0001 Listing : This program is never compiled. Only used by RP0002 for its subroutines. c c c
sr1 'hello'
begsr dsply endsr
Notice : This is not a Code fragment but a complete program. RP0002 Listing : This program uses subroutines found in RP0001. Only RP0002 is compiled. c exsr c seton c return c/COPY SAM2/QRADLE,RP0001
sr1 lr
The /Copy should come exactly where you wish to have the code pasted. Since Subroutines come after SETON LR, I have placed the /COPY after Seton Lr and RETURN. LAB : Debugging a copy book. RP001 Listing : dn1 s d n2 s drslt s c Eval c rslt Dsply c Exsr c Eval c Return c/COPY train12/sameerr,rp002
5i 0 inz(8) 5i 0 inz(100) 5i 0 rslt = n1 + n2 SR001 *inlr = *on
RP002 Listing : c c c
SR001 'SR001!'
BegSr Dsply EndSR
Start debugging of RP001 normally.During compilation, set DEBUGGING VIEWS to *ALL or atleast *COPY. Use Shift + F3 to select views as COPY view. This will display the source of RP002 where the /COPY was present. You can not use F10 to step throu the code : even the code copied into the parent program by the /COPY.
144
RPG-ILE LABS
145
RPG-ILE LABS LAB : Use of Monitor Linkage : RPCHAR CODE : DN1 s 5i 0 inz(108) DS1 s 10a c* c* %Char converts int to character c* c Eval S1 = 'MECH' + %Char(N1) c S1 Dsply c* c* Int converts char to int. c* --------------------------c Monitor C* Eval statement will definitely cause problem since we are trying to C* convert non-numeric stuff to numeric. C* We cannot use (E) as error handler operation extender since C* E can be used with only those opcodes that allow error indicators (LO ) C* c Eval N1 = %Int(s1) c ON-ERROR c 'Error' Dsply c Endmon c* c* c N1 Dsply c Eval *inlr = *on c Return c* PF contents : --OUTPUT
:
Sensitive stuff (that can cause a run time error) should be placed inside MONITOR and ENDMON group.If a statement (inside MONITOR group ) fails, control goes into ON_ERROR and allows you to handle the error. REMARKS : MONITOR and ENDMON is a good replacement for *PSSR.
146
RPG-ILE LABS LAB : MONITOR and ENDMON: How it works. (this is the second lab) Linkage : RPMON CODE : da db dc ds c c c c c c* c* c* c* c c c c c c
s s s s
4p 0 inz(10) 4p 0 inz(2) 4p 0 inz(0) 4a
Monitor Eval c = a/b Eval s = 'c = ' + %Char(c) Eval b = 0 Eval c = a/b the above EVAL throughs an exception which is caught by ON_ERROR the next EVAL statement is never executed ----------------------------------------Eval s = 'c = ' + %Char(c) On-Error 'error !' Dsply EndMon 'Over' Dsply Eval *inlr = *on
PF contents : --OUTPUT
:
REMARKS : So long as the statements inside the MONITOR execute correctly, the execution proceeds step by step. If a statement has a problem, control goes directly into ONERROR skipping all the intermediate statements.
147
RPG-ILE LABS LAB : HUB coding snippets What is the output of the following code ? dnum1 c c c 'not 12' c c c jsrvar c c
s do If dsply z-add EndIf Dsply EndDo Eval
5i 0 inz(100) 2 jsrvar <>12 12
jsrvar
5 0
*inlr = *on
OUTPUT : DSPLY DSPLY DSPLY
not 12 12 12
LAB : HUB code sample dnum1 c c c 'not 12' c c c jsrvar c c OUTPUT : DSPLY not DSPLY DSPLY not DSPLY
s do If dsply z-add EndIf Dsply EndDo Eval
5i 0 inz(100) 2 jsrvar <>12 jsrvar
jsrvar
5 0
*inlr = *on
12 0 12 0
148
RPG-ILE LABS
149
RPG-ILE LABS
LAB : DataQ Programming dDQName dDQLib dDQLen dDQData dDQWait c P1 c c c c c c C* c c c c c c c 'recd : ' c DQData c c
s s s s s
10a inz('DTA2') 10a inz('SAM2') 5p 0 inz(10) 10a inz('JSR') 5p 0 inz(10) Plist Parm Parm Parm Parm Call Eval Call Parm Parm Parm Parm Parm Dsply Dsply Eval Return
DQName DQLib DQLen DQData 'QSNDDTAQ' P1 DQData = *all'*' 'QRCVDTAQ' DQName DQLib DQLen DQdata DQWait
DQName DQLib DQLen DQData DQWait
*inLr = *on
150
RPG-ILE LABS
LAB : WOKRING ON SPACEA CREATE A REPORT WITH NO SPACEA OR SPACEB FOR A RECORD FORMAT. WRITE A PROGRAM TO DO MULTIPLE WRITE STATEMENTS TO THE RECORD FORMAT, YOU WILL FIND THAT THE LINES WILL BE OVERWRITTEN.RLU DOES NOT AUTOMATICALLY PUT A LINE BETWEEN 2 WRITE OPERATIONS WHEN IT COMES TO RECORD FORMAT OF A REPORT FRL001 C C C C C C C
O
E WRITE WRITE WRITE WRITE WRITE EVAL RETURN
PRINTER RREC1 RREC1 RREC1 RREC1 RREC1 *INLR = *ON
LISTING OF THE REPORT FILE : A A A A A A
R RREC1 SPACEA(1) 4 'THIS IS A TEST' +8 'ONE MORE'
SPACEA CAN BE USED AT THE RECORD LEVEL AS WELL AS FIELD LEVEL.
Lab : Working on SKIPA Report DDS : A A A A A
R RREC1 4'THIS IS A TEST' SPACEA(1) SKIPA(15) +8'ONE MORE'
After This is a TEST is printed on paper, a 1 line space is put. After that, the paper slips straight to line 15, if LINE 15 found on the same page printing continues on that page. If line 15 is already passed, system ejects current page and continues printing from line 15 on the next page. LAB : Writing codes to printer files (Hex) FRLHEX C C
O
E write SETON
PRINTER RHEX LR
RLHEX Listing : A
R RHEX
151
RPG-ILE LABS A A A A A
3 ' ' SPACEA(1) 15DFT(X'33') TRNSPY 17DFT(X'7C') TRNSPY
NOTE :
X’33 produces a block
X’7C’ produces @ sign. LAB :
Printing a Line in report A A
R RHEX LINE(6.0 6.1 2 *HRZ 1)
Compile using Printer type as *SFPDS (Advanced Function Printer Data Stream) not IPDS (intelligent Printer Data Stream) LAB : Page rotation A A A
R RHEX
PAGRTT(90) 5'HELLO' 11'WORLD'
R RHEX
LPI(9) 5'HELLO' 11'WORLD'
Lab : CPI A A A
LAB : Resetting the Page number A A A A A A A A A A A
R RDETL SPACEA(001) 3 ' ' PFLD1 R RPAGE
4S 0
16 70 'PG ' 75
78
PAGNBR EDTCDE(Z)
Program To reset page numbers every 5 pages : (you’ll never get page #6, it will always be 1 2 3 4 5 1 2 3 4 5 etc) FRLHEX O DCntr DPageNumber d* c c c C c
E
PRINTER OFLIND(*in77) 4s 0 inz(0) 4s 0 inz(0)
s s Do Eval Eval write If
668 Cntr = Cntr + 1 PFLD1 = cntr RDetl *in77= *on
152
RPG-ILE LABS c c c c c c c c c c c C
Eval Eval If Eval Write Eval else Write endif Endif Enddo SETON
*IN77 = *off PageNumber = PageNumber + 1 PageNumber > 5 *in78 = *on RPage *in78 = *off RPage
LR
LAB : POSITION keyword to place text at the right place on the paper FRLpos dps dpos1 dpos2 c c c c C
O
E s s s Eval Eval Eval write SETON
PRINTER 4s 0 inz(12) 5s 3 inz(2.00) 5s 3 inz(3.00) rfld1=ps fld1=pos1 fld2=pos2 rpos LR
Report : A A A A
R RPOS RFLD1 FLD1 FLD2
4S 0 5S 3P 5S 3P
POSITION(&FLD1 &FLD2)
Please compile the report file with the device option set to *AFPDS (Adv printing Function Data Stream) OUTPUT : File . . . . . : RLPOS Page/Line 1/12 Control . . . . . Columns 1 - 78 Find . . . . . . *...+....1....+....2....+....3....+....4....+....5....+....6....+....7. 0012
LAB : Specify Font QFNTCPL/QSYS A A A A A A A A A A
R RDETL CDEFNT(QFNTCPL/X0BITR) SPACEA(001) 3 ' ' PFLD1 R RPAGE
4S 0
16 70 'PG ' 75
153
RPG-ILE LABS A A
78
PAGNBR EDTCDE(Z)
RPG pprogram listing remains the same. Device type should not be anything other that AFPDS. LAB : Specify font and point size A A A A A A A A A A A
R RDETL
FONT(16951 (*POINTSIZE 10)) SPACEA(001) 3
PFLD1 R RPAGE
' ' 16FONT(222)
4S 0
70 'PG ' 75 78
PAGNBR EDTCDE(Z)
LAB : indara Functionally no effect of Indara on display file record format. A A A A A* A A A A A* A A A
DSPSIZ(24 80 *DS3) INDARA CA03(03) R RINDARA OVERLAY CF07(07) 4 10'INDARA REC FMT' COLOR(WHT) R RINDARA1
FDSIndara CF E c c c*** c c c* c c c c C C C* C ChkSR c 'INDARA :' C c '07 ' c C
OVERLAY CF07(08) 8 10'INDARA 1 ' COLOR(RED)
Dow Write Write Read Exsr Write Write Read Exsr Enddo Eval Return Begsr dsply if dsply Endif if
WORKSTN *in03 = *off Rindara Rindara1 Rindara ChkSR Rindara Rindara1 Rindara1 ChkSR1
55
55
*inlr = *on
*in07 = *on *in08 = *on
154
RPG-ILE LABS c c c* c* c c* C c C c c C c c c* c* c
'08 '
dsply Endif Eval Eval Endsr
ChkSR1 'INDARA 1 :'
Begsr dsply if dsply Endif if dsply Endif Eval Eval Endsr
'07 ' '08 '
*in07=*off *in08=*off
*in07 = *on *in08 = *on *in07=*off *in08=*off
Tried adding and removing indara but no change in beh. Both rec fmt share the indicators. If 07 is ONed when one rec fmt is displayed, it is ON for the second rec fmt as and when it is displayed. Here I swicthed ON ind 07 when RINDARA was displayed, when I did EXFMT for rINDARA1, 07 was ON. If I again press F7 for RINDARA1, 08 becomes ON (in addition to 07) If you press ENTER (and not any of the mapped function key), all indicators are turned off. IN the next interation, both 07 and 08 are automatically OFF (don’t have to be turned of explicitly).
LAB : Working with POSITION Keyword A A A A A A*
FRLpos dn1 dn2 d* c c c c c c c c c c C
R RPOS PCHAR
4A POSITION(&FLD1 &FLD2)
FLD1 FLD2
O
E
5S 3P 5S 3P
PRINTER 5s 3 inz(1) 5s 3 inz(1)
s s Eval Eval Eval Eval write Eval Eval Eval Eval write SETON
n1 = n2 = fld1 fld2 rpos n1 = n2 = fld1 fld2 rpos
n1 + 1 n2 + 0.5 = n1 = n2 n1 + 1 n2 + 0.5 = n1 = n2 LR
155
RPG-ILE LABS This worked , but no Preview or spool file is displayed although it is created. The system gives error message that the spool file contains Graphics data which cannot be displayed. Only sol is to take a physical printout.
156
RPG-ILE LABS
LAB : Dynamic positioning of window using Program-to-system fields FDSWINTRY cf DStartLine DStartPosition DTempNum D* C C C C C C C C C C
E
workstn 3s 0 inz(3) 3s 0 inz(3) 3s 0 inz(0)
s s s
Display file
Eval Eval exfmt Eval Eval Eval Eval Exfmt Eval Return
StLine = StartLine StPos = StartPosition Rwin StartLine = 3 StartPosition = 30 StLine = StartLine StPos = StartPosition Rwin *inlr = *on
A A A A A A A A A A A
: DSPSIZ(24 80 *DS3) R RWIN WINDOW(&STLINE &STPOS 9 9) STLINE STPOS FLD001 FLD002 FLD003 FLD004
3S 3S 4 4 4 4
0P 0P B 0B B 0B
2 4 6 8 1
2 2 2 2 2'test Scr' DSPATR(UL)
LAB : RMVWDW : remove previously displayed windows when displaying current window. A A A A A A A A A A A A FDSWINTRY cf DStartLine DStartPosition DTempNum D* C C C C
DSPSIZ(24 80 *DS3) R RWIN WINDOW(&STLINE &STPOS 9 9) RMVWDW STLINE STPOS FLD001 FLD002 FLD003 FLD004 E
3S 3S 4A 4S 4A 4S
0P 0P B 0B B 0B
2 4 6 8 1
2 2 2 2 2'test Scr' DSPATR(UL)
workstn 3s 0 inz(3) 3s 0 inz(3) 3s 0 inz(0)
s s s Eval Eval exfmt Eval
StLine = StartLine StPos = StartPosition Rwin StartLine = 3
157
RPG-ILE LABS C C C C C C
Eval Eval Eval Exfmt Eval Return
StartPosition = 30 StLine = StartLine StPos = StartPosition Rwin *inlr = *on
Student Example : Moving the window leftwards when F1 is pressed fdstry dn1 c c c c c c c c c c c c A A A A A A A A A
cf
e s Eval Eval Dow write exfmt if Eval Eval Endif Enddo Eval Return
workstn 4s 0 inz(1) stpos = 4 stlin = 3 *in03=*off rwin rnormal *in01 = *on stpos = stpos +1 *in01 = *off *inlr = *on DSPSIZ(24 80 *DS3) WINDOW(RWIN) CF01(01) CA03(03) 6 15'this is a normal record format’
R RNORMAL
R RWIN WINDOW(&STLIN &STPOS STLIN STPOS
19 45)
3S 0P 3S 0P
LAB : How to display a Display file record format without the mandatory READ operation on its record format PART 1 : FDSB00 CF C C 'HELO' C C C
E WRITE DSPLY WRITE SETON RETURN
WORKSTN RB00 RB00 LR
The above code actually displays the display file record format, although there is no READ operation. This is possible by setting the DFRWRT = *NO (defer write) during Display file compilation. PART 2 : Same effect can be achieved by using FRCDTA (Force data) record level keyword. A A A
DSPSIZ(24 80 *DS3) R RBASE CA03(03)
158
RPG-ILE LABS A A A A A A A A A A A A A A A A A
FLD1 FLD2 FLD3 FLD4 FLD5 R RWIN
4S 0B 20A B 30A B 30A B 30A B
4 7 9 11 7 9 11 12 13
FRCDTA 9'THIS IS A TEST OF BOO' 10'CODE :' 10'NAME :' 10'ADDRESS : ' 21 21 21 21 21 CA12(12) WINDOW(4 50 9 9) OVERLAY
FLD001 FLD002 FLD003
3 3 2
B 0B 0B
1 3 4
2 2 2
Rpgle : FDSB00 C C C C C C C
CF
E WRITE EXFMT WRITE WRITE READ SETON RETURN
WORKSTN RBASE RWIN RBASE RWIN RBASE
44 LR
LAB : csrloc TO POSITION THE CURSOR WHEN THE RECORD FORMAT IS BIEND DISPLAYED FDSB00 C C C C C
CF
E EVAL EVAL EXFMT SETON RETURN
WORKSTN L = 9 P = 21 RBASE LR
DISPLAY FILE LISTING : A A A A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) CSRLOC(L P) CA03(03) FRCDTA
R RBASE L P
FLD1 FLD2 FLD3 FLD4 FLD5
3S 0H 3S 0H
4S 0B 20A B 30A B 30A B 30A B
4 7 9 11 7 9 11 12 13
9'THIS IS A TEST OF BOO' 10'CODE :' 10'NAME :' 10'ADDRESS : ' 21 21 21 21 21
159
RPG-ILE LABS LAB : CHECK(ER) to make Field Exit key work like ENTER key It is recommended to use CHECK(ER) on the last field of the Display file. After data entry operator has typed data into the last data field and pressed Field exit, he need no press ENTER again to pass control into RPG. Then Field Exit is pressed for the last field, it is works like ENTER because this field has CHECK(ER). A A A A A A A A A A A A fdserase cf c c fld001 c c fld001 c c fld001 c c
DSPSIZ(24 80 *DS3) CA03(03) R RERASE
FLD001 FLD002 FLD003 FLD004
4S 0B 10A B 40A B 40A B
FLD005
1A B workstn RErase
e Exfmt dsply Exfmt dsply Exfmt dsply Eval Return
5 7 9 5 7 9 10 18 18
RErase RErase *inlr = *on
code :
2
Name :
AMIT
Address :
4,KNABLE LANE, TRAVOSE CALIFORNIA
SAVE ?
7'code : ' 7'Name :' 7'Address :' 19 19 19 19 4'SAVE ? ' 19CHECK(ER)
Y
When User enters Y in the Save field, control immediately returns to RPG for further operation.
Lab : CHECK(VN) TO VALIDATE A SIMPLE NAME. CHECK(VNE) TO VALIDATE A NAME (EXTENDED) A A A A
DSPSIZ(24 80 *DS3) CA03(03) R RERASE 5
7'code : '
160
RPG-ILE LABS A A A A A A A A A fdserase cf c c fld001 c c fld001 c c fld001 c c
FLD001 FLD002
4S 0B 10A B
FLD003 FLD004
40A 40A
FLD005
1A B workstn RErase
e Exfmt dsply Exfmt dsply Exfmt dsply Eval Return
B B
7 7'Name :' 9 7'Address :' 5 19 7 19 CHECK(VN) 9 19 10 19 18 4'SAVE ? ' 18 19CHECK(ER)
RErase RErase *inlr = *on
CHECK(VN) is for validation of NAME of a object / person : It checks basic things like : 1. Name cannot contain symbols except # 2. Name should not contain embedded spaces. LAB : Overlapping record formats & application of CLRL. Display file listing (pay attention to the positions of the lines of the 2 record formats. You will se that the the record formats overlap. Depending on need, one or both can be displayed although only 1 will be in the READ mode) CLRL (2) is specified for R1 record format.When R1 is displayed, All lines occupied by R1 are first cleared. Since value specified CLRL is 2, a minimum of 2 lines will be cleared. This last portion (last 2-3 lines) of RERASE is dislpayed Even when an EXFMT is done to R1. CLRL(*END) will clear all lines after 1st line of R1.
A A A A A A A A A A A A A A A A A A
DSPSIZ(24 80 *DS3) CA03(03) R RERASE
FLD001 FLD002 FLD003 FLD004 FLD005 R R1
4S 0B 10A B 40A B 40A B 1A
B
OVERLAY 7'code : ' 7'Name :' 7'Address :' 19TEXT('CODE VALUE') 19CHECK(VNE) 19 19 4'REC FMT 1' 4'SAVE ? ' 19CHECK(ER) CLRL(2) OVERLAY 9 7'XXXXXXX' COLOR(RED)
5 7 9 5 7 9 10 17 18 18
161
RPG-ILE LABS A A A A A A A A A A RPGLE: fdserase cf c c c fld001 c c c fld001 c c c fld001 c c
10 11 FLD1
40A
B 12
FLD2
40A
B 13 14
e
7'YYYYYYY' COLOR(RED) 7'ZZZZZZZ' COLOR(RED) 19 COLOR(RED) 19 COLOR(RED) 4'REC FMT 2' COLOR(RED)
workstn r1 RErase
exfmt Exfmt dsply exfmt Exfmt dsply exfmt Exfmt dsply Eval Return
r1 RErase r1 RErase *inlr = *on
OUTPUT : code :
1
Name :
ANIL
XXXXXXX YYYYYYY ZZZZZZZ TEST DATA REC FMT 2 REC FMT 1 SAVE ?
Y
LAB : Study of CHANGE keyword A A A A A A A A A A A
DSPSIZ(24 80 *DS3) R RCHANGE CA03(03) 6'ARG1 : ' COLOR(BLU) 8 6'ARG2 : ' COLOR(BLU) 10 6'ARG3 :' COLOR(BLU) 0B 6 16COLOR(WHT) CHANGE(20) 6
DARG1
4
162
RPG-ILE LABS A A A A FDSCHANGE CF C C C *in20 C *in21 C *in22 C C C C
DARG2
4
DARG3
4
E Dow Exfmt Dsply Dsply Dsply Setoff Enddo Eval Return
0B
8 16COLOR(WHT) CHANGE(21) 0B 10 16COLOR(WHT) CHANGE(22)
WORKSTN *in03 = *off rchange
202122 *inlr= *on
CHANGE Indicator is set on when : 1. Field Exit is pressed in a field 2. Some data is typed followed by field exit 3. existing data is changed
LAB : Detailed work on edit code | 4.1.1.5 %EDITC (Edit Value Using an Editcode) | | | | | |
%EDITC(numeric : editcode {: *ASTFILL | *CURSYM | currency-symbol}) This function returns a character result representing the numeric value edited according to the edit code. In general, the rules for the numeric value and edit code are identical to those for editing numeric values in output specifications. The third parameter is optional, and if specified, must be one of:
| *ASTFILL | | |
Indicates that asterisk protection is to be used. This means that leading zeros are replaced with asterisks in the returned value. For example, %EDITC(0012.5 : 'K' : *ASTFILL) returns '***12.5-'.
| *CURSYM | | | | |
Indicates that a floating currency symbol is to be used. The actual symbol will be the one specified on the control specification in the CURSYM keyword, or the default, '$'. When *CURSYM is specified, the currency symbol is placed in the the result just before the first significant digit. For example, %EDITC(0012.5 : 'K' : *CURSYM) returns ' $12.5-'.
| currency-symbol Indicates that floating currency is to be used with the | provided currency symbol. It must be a 1-byte character constant | (literal, named constant or expression that can be evaluated at | compile time). | | | | |
Float expressions are not allowed in the first parameter (you can use %DEC to convert a float to an editable format). The edit code is specified as a character constant; supported edit codes are: 'A' - 'D', 'J' - 'Q', 'X' - 'Z', '1' - '9'. The constant can be a literal, named constant or an expression whose value can be determined at compile time. Subtopics
163
RPG-ILE LABS 4.1.1.5.1 %EDITC Examples 4.1.1.5 - 1 %EDITC Examples | 4.1.1.5.1 %EDITC Examples -------------------------------------------------------------------------| |
D msg D salary
| | | | | | |
S S
100A 9P 2
* * * *
If the value of salary is 2451.53, then the value of salary * 12 is 29418.36. The edited version of salary * 12 using the A edit code with floating currency is ' $29,418.36 '. The value of msg is 'The annual salary is $29,418.36' EVAL msg = 'The annual salary is ' + %trim(%editc(salary * 12 :'A': *CURSYM))
* * * *
If the value of salary is 2451.53, then the value of salary * 12 is 29418.36. The edited version of salary * 12 using the A edit code with floating currency is ' $29,418.36 '. The value of msg is 'The annual salary is &29,418.36' EVAL msg = 'The annual salary is ' + %trim(%editc(salary * 12 :'A': '&'))
C C C
| | | | | | |
C C C
| | | | |
* In the next example, the value of msg is 'Salary is $***29,418.36' * Note that the '$' comes from the text, not from the edit code. C EVAL msg = 'Salary is $' C + %trim(%editc(salary * 12 C :'B': *ASTFILL))
| | |
C C
* In the next example, the value of msg is 'The date is 1996/06/27' EVAL msg = 'The date is ' + %trim(%editc(*date : 'Y'))
-------------------------------------------------------------------------| Figure 125. %EDITC Example 1 | A common requirement is to edit a field as follows: | _ | _
Leading zeros are suppressed Parentheses are placed around the value if it is negative
| The following accomplishes this using an %EDITC in a subprocedure: -------------------------------------------------------------------------| | | | |
D D D D D
neg pos editparens val editedVal
S S PR
| | | |
C
| | | | |
*--------------------------------------------------------------* Subprocedure EDITPARENS *--------------------------------------------------------------P editparens B D editparens PI 50A
S
5P 2 5P 2 50A 30P 2 10A
inz(-12.3) inz(54.32) value
EVAL editedVal = editparens(neg) * Now editedVal has the value '(12.30) ' C EVAL editedVal = editparens(pos) * Now editedVal has the value ' 54.32 ' 4.1.1.5.1 - 1 %EDITC Examples
164
RPG-ILE LABS | | | |
D val D lparen D rparen D res
30P 2 1A 1A 50A
| | | | |
C C C C
| | | | | |
* Return the edited value * Note that the '1' edit code does not include a sign so we * don't have to calculate the absolute value. C RETURN lparen + C %editc(val : '1') + C rparen
|
P editparens
S S S
value inz(' ') inz(' ')
* Use parentheses if the value is negative IF val < 0 EVAL lparen = '(' EVAL rparen = ')' ENDIF
E
LAB : Indicator Data structure
FMySUBFILE4 CF D RRN DDSINF001 DKEYIN DENTER
E
WORKSTN INFDS(DSINF001) S DS
5 369
C
0
369 CONST(X'F1')
: : :
C C
IF // Code
KEYIN = ENTER
165
RPG-ILE LABS Example program : FDSINDDS CF DDS001 DINKEY DENTER DF3 DF4 DF5 C C C 'ENTER' C C* C C 'F3 ' C C
E
WORKSTN INFDS(DS001) DS 369 C C C C
369 CONST(X'F1') CONST(X'33') CONST(X'34') CONST(X'35')
EXFMT IF DSPLY Endif
R1 INKEY = ENTER
IF DSPLY Endif IF
INKEY = F3 INKEY = F4
REF : *********************************************************** D F1 C CONST(X'31') D F2 C CONST(X'32') D F3 C CONST(X'33') D F4 C CONST(X'34') D F5 C CONST(X'35') D F6 C CONST(X'36') D F7 C CONST(X'37') D F8 C CONST(X'38') D F9 C CONST(X'39') D F10 C CONST(X'3A') D F11 C CONST(X'3B') D F12 C CONST(X'3C') D F13 C CONST(X'B1') D F14 C CONST(X'B2') D F15 C CONST(X'B3') D F16 C CONST(X'B4') D F17 C CONST(X'B5') D F18 C CONST(X'B6') D F19 C CONST(X'B7') D F20 C CONST(X'B8') D F21 C CONST(X'B9') D F22 C CONST(X'BA') D F23 C CONST(X'BB') D F24 C CONST(X'BC') D CLEAR C CONST(X'BD') D ENTER C CONST(X'F1') D HELP C CONST(X'F3') D ROLLDN C CONST(X'F4') D ROLLUP C CONST(X'F5') D PRINT C CONST(X'F6') D RCBKSP C CONST(X'F8') D AUTENT C CONST(X'3F') D WSDS DS D functionKey 369 369 END
166
RPG-ILE LABS LAB : KA and KB indicators Listing :-
FDStestF cf e c c c 'KA on !' c c c c 'KB on !' c c
Exfmt If dsply Endif If dsply Endif eval
workstn R1 *inka = *on
*inkb = *on *inlr = *on
The display file DSTestF has CA01(01) and CA02(02) at the file level. When user presses F1, the corresponding indicator KA is switched on.Similarly for F2 and KB. END
167
RPG-ILE LABS
LAB : CHECKMSGID FOR VALIDATION OF DATA INPUT BY USER. First Give A CHECK or RANGE condition for validation, then follow that by a CHECKMSGID (<msg id> /<msg file name>) First create a Message File called MSGF1 in SAM2 and add 2 messages with IDs MSG001 and MSG002. DISPLAY FILE LISTING A A A A A A A A A
DSPSIZ(24 80 *DS3) R RVLD CA03(03) 5 17'ENTER A VALUE BETWEEN 100 & 200’ 7 17'DATA : ' 4S 0B 7 27COLOR(WHT) RANGE(100 200) CHKMSGID(MSG0001 SAM2/MSGF1) 1A B 11 18
FLD001 FLD002
RPGLE LISTING FDSVLD C C C
CF
E EXFMT SETON RETURN
WORKSTN RVLD LR
LAB : ERRMSGId FDSVLD CF E C c* 10 corresp to c* ERRMSGID c* c C C C
EXFMT
Eval EXFMT SETON RETURN
WORKSTN RVLD
*in10 = *on RVLD LR
Display Message File : A A A A A A A A A
DSPSIZ(24 80 *DS3) R RVLD
FLD001 10 FLD002
CA03(03) 17'ENTER A VALUE BETWEEN 100 17'OR BETWEEN 400 AND 500' 17'DATA : ' 4S 0B 27COLOR(WHT) ERRMSGID(MSG0002 *LIBL/MSGF1) 1A B 11 18 5 6 8 9
AS SETON 10 and EXFMT is done, the Error Message is loaded from the Message File and displayed on the screen. The keyboard is locked and waits for Reset key to be pressed.
168
RPG-ILE LABS LAB : SENDING PROGRAM VARIABLES IN PRE-DEFINED MESSAGES IN THE MESSAGE FILE MSGF1 ADD A MESSAGE MSG0003 AS FOLLOWS : THE VALUE OF N IS &1 IN THE NEXT SCREEN SPECIFY THE FIRST DATA VARIABLE AS *CHAR WITH LEN 4 AND DEC POS 0 (!) SAVE AND EXIT THE FOLLOWING CL PROGRAM WRITES RUN TIME VALUES INTO THE PRE-DEFINED MESSAGE. : PGM DCL &N TYPE(*DEC) LEN(4 0) VALUE(123) DCL &SN TYPE(*CHAR) LEN(4) CHGVAR VAR(&SN) VALUE(&N) SNDPGMMSG MSGID(MSG0003) MSGF(SAM2/MSGF1) MSGDTA(&SN) ENDPGM RPGLE EQIUIVALENT : The Display file contains CHKMSGID (MSG0003 SAM2/MSGf1 &CNTR) The Message MSG0003 has 1 variable field ( identified as &1 ) which was defined as *CHAR with size 4 and dec pos 0 . here the RPGLE program specifies this message in the CHKMSGID keyword. RPGLE makes sure that value of the variable CNTR is et to some valid value before record format is displayed on the screen. Message File listing : MSGID MSGF MSG
> MSG0003 > MSGF1 > SAM2 'the value of N is &1'
Message data fields formats: FMT Data type . . . . . . . . . . Length . . . . . . . . . . . . *VARY bytes or dec pos . . . . + for more values
*CHAR 4 0 _
If you press + in the underline above, you can specify more fields. Dislpay File Listing : A A A A A A A A
DSPSIZ(24 80 *DS3) R RVLD CA03(03) CNTR
FLD001
4A
P
4S 0B
5 6 8 9
17'ENTER A VALUE BETWEEN 100 17'OR BETWEEN 400 AND 500' 17'DATA : ' 27COLOR(WHT)
169
RPG-ILE LABS A A A
RANGE(100 200) CHKMSGID(MSG0003 SAM2/MSGF1 &CNTR) FLD002
FDSVLD c C C C C
CF
1A
E
B 11 18 WORKSTN CNTR='123' RVLD
EVAL EXFMT SETON RETURN
LR
LAB : Multiple values displayed on Pre-defined messages Message details : Tried to put many variables into 1 message but wont work with ERRMSGID. ERRMSGID can take ERRMSGID(MSG0099 MSGF1 &STR) But not ERRMSGID(MSG0099 MSGF1 &x &y &z) ie ERRMSGID does not take more than 1 variables as values to the keyword. I wanted to display something like this : A = 10 B = 12 . their Sum is 22. For putting the 3 values, I initially created a message with 3 variable, but knowing the limitation of ERRMSGID, I created a general purpose Message : MSG0099 that simply dislpays 1 string as follows : Message ID . . . . . . . . . : Message file . . . . . . . . : Library . . . . . . . . . :
Field &1
Data Type *CHAR
MSG0099 MSGF1 SAM2 Decimal Positions
Length 75
this message contains no text only 1 variable : &1 which I s*CHAR and 75 in length (roughly 1 row ) What ever u wish to write as a message is dumped into this variable. The message is displayed via ERRMSGID as seen clearly in the following display file listing : Display file details : A A A A A A A A
DSPSIZ(24 80 *DS3) R RVLD CA03(03) STR
75A
P 8 17'DATA : ' 9 27COLOR(WHT) ERRMSGID(MSG0099 MSGF1 &STR) B 11 18
FLD001
4S 0B
FLD002
1A
10
RPGLE program :
170
RPG-ILE LABS
FDSVLD DN1 DN2 DTOTAL DSN1 DSN2 DSTOTAL d* c C C C c c C C C C C
CF
E
WORKSTN 4S 0 INZ(122) 4S 0 INZ(16) 7s 0 inz(0) 4a 4a 7a
S S s s s s EVAL Movel Movel Movel Eval EXFMT Eval EXFMT SETON RETURN
TOTAL = N1 + N2 Total sTotal N1 sN1 N2 sN2 Str = 'A = ' + SN1 + ' B = ' + SN2 + ' .' + 'Their Sum : ' + STotal RVLD *in10 = *ON RVLD LR
STR is a program to system variable which is passed to the MSG0099. RPGLE program writes suitable text into this STR string and sets ON indicator 10. In the next WRITE operation, the message is displayed on the screen. The message goes when RESET (left CTRL key) is pressed.
* * *
171
RPG-ILE LABS
LAB : PSDS : General purpose Error DS DArg1 s 4s 0 inz(-2) DArg2 s 4s 0 inz(0) DRslt s 4s 0 inz(0) D D D SDS D* --------------------------------------D* FOR PROCEDURE NAME/PROG NAME D* YOU CAN SPECIFY EITHER 1 TO 10 OR *PROC D* --------------------------------------DPGMNAM *PROC DSTS *STATUS DSRCLIN 21 28 DNUMPAR 37 39 DEXCTYP 40 42 DEXCNUM 43 46 DLIBNAM 81 90 DSRCFNAM 304 313 DSRCLIB 314 323 DSRCMEM 324 333 DPRONAM 334 343 DMODNAM 344 353 c c 'aaa' Dsply c Eval Rslt = Arg1/Arg2 c cnt1 Tag c 'bbb' Dsply c Eval *inlr = *on c Return c c *PSSR Begsr C PGMNAM DSPLY C STS DSPLY C PGMNAM DSPLY C STS DSPLY C SRCLIN DSPLY C NUMPAR DSPLY C EXCTYP DSPLY C EXCNUM DSPLY C LIBNAM DSPLY C SRCFNAM DSPLY C SRCLIB DSPLY C SRCMEM DSPLY C PRONAM DSPLY C MODNAM DSPLY c Goto cnt1 C Endsr Variable PGMNAM STS PGMNAM SRCLIN NUMPAR
Value RPBMAST 102 RPBMAST 00000025 000
Remarks Devide by Zero Devide by zero occurred on line 25 of source code Number of parameters provided to this program when it was called
172
RPG-ILE LABS EXCTYP EXCNUM LIBNAM SRCFNAM SRCLIB SRCMEM PRONAM
MCH 1211 SAM2 QRADLE002 SAM2 RPBMAST RPBMAST
MODNAM
RPBMAST
Exception Type (MCH for Machine Exception) Exception number Lib in which this prog is running Source PF of the source code of this program Procedure name in which this procedure is present (not applicable here) (Module name in which this procedure is present)
LAB : Status codes displayed by PSDS Following program illustrates the error codes for 2 aritmentic errors : DIV by ZERO And SQRT of a NEGATIVE NUMBER DErrNum s 6s 0 inz(0) DArg1 s 6s 0 inz(-4) DArg2 s 6s 0 inz(0) DRslt s 6s 0 inz(0) DSErrNum s 6a D D D SDS D* --------------------------------------D* FOR PROCEDURE NAME/PROG NAME D* YOU CAN SPECIFY EITHER 1 TO 10 OR *PROC D* --------------------------------------DPGMNAM *PROC DSTS *STATUS DSRCLIN 21 28 DEXCTYP 40 42 DEXCNUM 43 46 c c '1.' Dsply c Eval Rslt = Arg1/Arg2 c cnt1 Tag c '2. ' Dsply c SQRT Arg1 Rslt c cnt2 Tag c '---------' Dsply c Eval *inlr = *on c Return c c *PSSR Begsr C STS DSPLY C SRCLIN DSPLY C EXCTYP DSPLY C EXCNUM DSPLY c Select c When SrcLin='00000020' c Goto Cnt1 c When SrcLin='00000023' c Goto Cnt2 c EndSl c EndSR
173
RPG-ILE LABS OUTPUT : DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
1. 102 00000020 MCH 1211 2. 101 00000023 RNX 0101 ---------
LAB : PSDS : More error codes H DatFmt(*DMY) D* D* Mydate is an impossible date D* ---------------------------DMydate S 6s 0 INZ(310204) DMyDate1 s D inz(D'12/04/04') D D D SDS D* --------------------------------------DSTS *STATUS DSRCLIN 21 28 DEXCTYP 40 42 DEXCNUM 43 46 c c c* This data area does not Exist c* ----------------------------c C *DTAARA DEFINE DataArea1 c c c '1.' Dsply c *DMY Move MyDate MyDate1 c cnt1 Tag c '2. ' Dsply c Call 'NoExist' c cnt2 Tag c '3.' Dsply c *LOCK IN DataArea1 c OUT DataArea1 c UnLock Dataarea1 c cnt3 Tag c Eval *inlr = *on c Return c c *PSSR Begsr C STS DSPLY C SRCLIN DSPLY C EXCTYP DSPLY C EXCNUM DSPLY c Select c When SrcLin='00000024' c Goto Cnt1
5
174
RPG-ILE LABS c c c c c c
When Goto When Goto EndSl EndSR
SrcLin='00000027' Cnt2 SrcLin='00000030' Cnt3
OUTPUT : DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
1. 112 00000024 RNX 0112 2. 211 00000027 MCH 3401 3. 401 00000030 CPF 1015
Error Code 00100 00101 00102 00112 00122 00211 00222 00401 00411 00412 00414 00421 00431 00432 00907 00803 00804 00802 09999
Description Out of range Attempted SQRT of a negative number Div by zero Invalid date , time or timestamp OCCUR outside range Error calling program/procedure Pointer/Parameter error Data area specified in the IN/OUT oprn not found Data area type/len does not match Data area not locked for O/P Not authorised to use data area Error on UNLOCK oprn Data area previously locked by another program Data area previously locked by program in the same process Decimal data error Rollback Failed Commit Failed Commitment control not active Internal failure
LAB : INFDS Data for a DISK file Following program creates error condition by tring to open a file twice.Proggram also illustrates how the error can be corrected. FPFBMAST F DMsg d* DDsBMast
UF
E
DISK s
USROPN infds(dsBMast) infsr(srBMast)
50a
DS
175
RPG-ILE LABS DIsOpn 9 9 DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST 77 C If *IN77 C 'CANNOT OPEN' DSPLY C Eval *inlr = *on C Return C Endif C* ---------------------------------------------c* Try to open again. Will obviously Fail. c* ---------------------------------------------C Open pfBMAST 77 c If *in77 = *on c EXSR srBMAST c Select c When Status=1215 c* Attempt to open twice c Eval Msg = 'Attempt made to open a file twice c + ' Problem corrected.' c Msg Dsply c* More such WHEN statements ... c* c Endsl c Endif C '----------' Dsply c* Perform Mandatory READ c Read BM 55 c* Do some database c* processing here... c* C Close pfBMAST C Eval *inlr=*on C Return C C srBMAST Begsr C 'IsOpen ?' Dsply c IsOpn Dsply c 'Is EOF ?' Dsply c IsEOF Dsply c 'Status :' Dsply c Status Dsply c 'Op code :' Dsply c opCode Dsply c 'Message :' Dsply c MsgNbr dsply c ENDSR OUTPUT : DSPLY OPEN NOW... DSPLY IsOpen ? DSPLY 1 DSPLY Is EOF ? DSPLY 0
176
RPG-ILE LABS DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
Status : 1215 Op code : OPEN F Message : Attempt made to open a file twice. Problem corrected.
LAB : Error handling a READ Statement : EXCLUSIVE LOCK ( *EXCL) SAM3 locks the PFBMAST for exclusive access. SAM2 tries to open it in Update mode. Attempt fails : STATUS code is 1271 : Attempt to access a locked object. SAM3 runs the following program in his own login :Program Name : CLLOCK Type : CLP The OPM program locks and opens the PFBMAST in exclusive mode. It then waits with a SNDPGMMSG indefinitely. In the mean time SAM2 runs the RPFIDS2 program (RPGLE) which tries to open PFBMAST in Update Mode. Attempt fails and is handled by indicator in the LOW section. The error type is clear in the STATUS variable which contains value 1217 ie attempt to access Locked object. SAM3’s program : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ OVRDBF FILE(PFBMAST) RCDFMTLCK((BM *EXCL)) + OVRSCOPE(*JOB) OPNDBF FILE(SAM2/PFBMAST) OPTION(*ALL) OPNSCOPE(*JOB) /* WAIT TILL USER PRESSES ENTER KEY */ SNDPGMMSG MSG('record locked') TOPGMQ(*EXT) CLOF OPNID(PFBMAST) DLTOVR FILE(PFBMAST) LVL(*JOB) ENDPGM SAM2’s Program : FPFBMAST UF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Read BM c* Do some database c* processing here... c*
77
55
177
RPG-ILE LABS C C C
Close Eval Return
pfBMAST *inlr=*on
OUTPUT : DSPLY DSPLY DSPLY
OPEN NOW... CANNOT OPEN 1217
LAB : ERror handling a READ Statement : *SHRRD Shared for READ (*SHRRD) lock is when one user locks the pf so that he can read it. But others can only read and update it. SAM3 locks PFBMAST as *SHRRD. SAM2 tries to open the file in the mean tim ein update mode. This is what happens : SAM2 opens it successfully ! SAM3’s program : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ OVRDBF FILE(PFBMAST) RCDFMTLCK((BM *SHRRD)) + OVRSCOPE(*JOB) OPNDBF FILE(SAM2/PFBMAST) OPTION(*ALL) OPNSCOPE(*JOB) /* WAIT TILL USER PRESSES ENTER KEY */ SNDPGMMSG MSG('SHARE READ ') TOPGMQ(*EXT) CLOF OPNID(PFBMAST) DLTOVR FILE(PFBMAST) LVL(*JOB) ENDPGM SAM2 ‘s program : FPFBMAST UF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Read BM c* Do some database c* processing here... c* C Close pfBMAST C Eval *inlr=*on C Return
77
55
178
RPG-ILE LABS LAB : ERror handling a READ Statement : *SHRUPD Share update (*SHRUPD) lock is when one user locks the pf so that he can update and read it. But others can read and update it. SAM3 locks the file first. SAM2 can access the file in *UPDATE mode. LAB : Handling READ errors for SHRNUP locks. SAM3 locks PF with *SHRNUP : SAM2 tries to open file in UPDATE Mode. SAM2 gets the following response : OUTPUT : DSPLY OPEN NOW... DSPLY CANNOT OPEN DSPLY 1217 What if SAM2 tries to open the PFBMAST in INPUT mode ? The file is opened successfully. LAB : Handling error in EXCLRD (EXCLUSIVE ALLOW read) lock Sam3 locks the PFBMAST in *EXCLRD.Sam3 tries to open in update mode : Result : SAM2 cannot open pf in UPDATE mode. DSPLY DSPLY DSPLY
OPEN NOW... CANNOT OPEN 1217
SAM2 successfully opens the file in INPUT mode Lab : Normal record locks. SAM3 overrides pfbmast so that when it is opened, it gets a record format lock (as done prevoisly) as *EXCL. With sam3’s program running, call rpfids2 for sam2. This program cannot open pf in update mode. SAM2 cannot open this file in INPUT mode either. Code of sam3 : CLlock : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ OVRDBF FILE(PFBMAST) RCDFMTLCK((BM *EXCL OVRSCOPE(*JOB) /* CALL RPFIDS3 WHICH READS PFBMAST IN UPDATE MODE*/ CALL RPFIDS3 DLTOVR FILE(PFBMAST) LVL(*JOB) ENDPGM
)) +
RPFIDS3 (sam3’s program) FPFBMAST DMsg
uF
E s
DISK 50a
USROPN
infds(dsBMast)
179
RPG-ILE LABS d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Read BM c* Do some database c* processing here... c 'ENDING' DSPLY C Close pfBMAST C Eval *inlr=*on C Return
77
55
SAM2’s program : FPFBMAST iF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Read BM c* Do some database c* processing here... c 'ENDING 2' DSPLY C Close pfBMAST C Eval *inlr=*on C Return
77
55
Sam3’s screen : DSPLY OPEN NOW... DSPLY ENDING
180
RPG-ILE LABS Sam2’s screen : (for both modes : READ FOR Update as well as READ FOR Input) DSPLY OPEN NOW... DSPLY CANNOT OPEN DSPLY 1217 Lab : Effect of File locking in the same job In the same job, at the same level, a program can open a Exclusively locked file : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ OVRDBF FILE(PFBMAST) RCDFMTLCK((BM *EXCL)) + OVRSCOPE(*JOB) SHARE(*NO) OPNDBF FILE(SAM2/PFBMAST) OPTION(*INP) OPNID(I4) + OPNSCOPE(*JOB) /* CALL RPFIDS3 WHICH READS PFBMAST IN UPDATE MODE*/ CALL RPFIDS3 CLOF OPNID(I4) DLTOVR FILE(PFBMAST) LVL(*JOB) Here RPFIDS3 has successfully opened the pf in Update mode. ENDPGM LAB : Locking excl in sam3a activation group and then opening a file in update mode in sam3b act grp is possible Listing of CLLOCK compiled to run in the SAM3A activation group : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ OVRDBF FILE(PFBMAST) RCDFMTLCK((BM *EXCL)) + SECURE(*YES) OVRSCOPE(*ACTGRPDFN) SHARE(*NO) OPNDBF FILE(SAM2/PFBMAST) OPTION(*INP) OPNID(I4) + OPNSCOPE(*ACTGRPDFN) /* CALL RPFIDS3 WHICH READS PFBMAST IN UPDATE MODE*/ CALL RPFIDS3 CLOF OPNID(I4) DLTOVR FILE(PFBMAST) LVL(*ACTGRPDFN) ENDPGM Results of DSPJOB : 2 different data paths generated for PFBMAST : PFBMAST SAM2 PFBMAST *ACTGRPDFN 0000033071 SAM3A PFBMAST SAM2 PFBMAST *ACTGRPDFN 0000033110 SAM3B RPFIDS3 is compiled to run in the SAM3B activation group. LAB : Handling normal record locking A program tries to read for update, if the READ fails, displays the error (satus code) If RPGFIDS3 is started first, it opens the PFBMAST in update mode. A READ operation is performed. This is READ FOR UPDATE since the open mode was UPDATE. Now that a READ for UPDATE has bnen done,the record is locked.
181
RPG-ILE LABS At this time of RPFIDS2 is started, it may open the file in Update mode (since we have not enabled any object level locking, the database file is for anyone to use and open in any mode as desired) The RPFIDS2 has no problems opening thie file, but when it tries to read this fie (READ FOR UPDATE) it cannot because the first record is already locked by RPFIDS3. Had RPFIDS2 tried to read the second or any other record (apart from rec 1) it would have succeeded. The first record is locked by RPFIDS3. The lock is released only when RPFIDS3 does an explicit UNLOCK operation or reads another record for update. Output from RPFIDS2 DSPLY DSPLY DSPLY
OPEN NOW... CANNOT read 1218
RPFIDS2 opened the file in update mode but could not read record #1. It waited 60 secs (record wait time) and then switched on the indicator in the LO section. We check state of this indicator and display the STATUS value which comes out to be 1218 ! Code for RPFIDS2 : FPFBMAST uF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Eval *in55 = '1' c dow *in55 = '1' c Read BM C If *IN66 C 'CANNOT read' DSPLY c status dsply c else c* Do some database c* processing here... c 'RPFIDS 2' dsply c bcode dsply c bname dsply c bprice dsply c endif c enddo c 'ENDING 2' DSPLY c
77
6655
182
RPG-ILE LABS C C C
Close Eval Return
pfBMAST *inlr=*on
Code for RPFIDS3 : FPFBMAST uF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on C Return c Endif c Read BM c* Do some database c* processing here... c bcode dsply c bname dsply c bprice dsply c 'ENDING' DSPLY C Close pfBMAST C Eval *inlr=*on C Return
77
55
RPFIDS2 will have no problems opening the file in Input mode.In the input mode the READ opcode causes a READ FOR INQUIRY that does not lock a record. LAB : Handling READ of UPDATE failures Program RPFIDS2 tries to perform a READ for Update for 3 times, if all 3 attempts fail, it does a read for inquiry and display data in the record. When RPFIDS2 is doing all this, RPFIDS3 has already locked the first record of the PFBMAST with a READ for UPDATE. Code for RPFIDS3 remains the same : opens PFMAST in Update mode and reads the first record as READ for UPDATE. Then it stops with something displaed using DSPLY. Code for RPFIDS2 : FPFBMAST DMsg d* DDsBMast DIsEOF DStatus
uF
E
DISK 50a
s
USROPN
infds(dsBMast)
DS 10 11
10 15
0
183
RPG-ILE LABS DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on c Return c Endif c Eval *in66 = '1' c* This loop goes on till atleast 1 successful c* READ operation is done. c* c dow *in66 = '1' c Read BM c* will wait 60 seconds c* If record still not available c* will switch on 66 c* C If *IN66 C 'CANNOT read' DSPLY c status dsply c Iter c else c* Do some database c* processing here... c 'RPFIDS 2' dsply c bcode dsply c bname dsply c bprice dsply c endif c enddo c 'ENDING 2' DSPLY c C Close pfBMAST C Eval *inlr=*on C Return
77
6655
OUTPUT of RPFIDS2: DSPLY DSPLY DSPLY
OPEN NOW... CANNOT read 1218
LAB : Locking PF with ALLOC SAM3 runs following program : PGM /* LOCK THE PFBMAST FILE TOTALLY. LET NO ONE OPEN */ ALCOBJ OBJ((SAM2/PFBMAST *FILE *EXCL *FIRST)) WAIT(5) SNDPGMMSG MSG('Object is Alocated *EXCL.') TOPGMQ(*EXT) DLCOBJ OBJ((SAM2/PFBMAST *FILE *EXCL PFBMAST)) ENDPGM
184
RPG-ILE LABS SAM2
runs the following program shortly after SAm3 ran his program :
FPFBMAST uF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* c* -----------------------------------------C 'OPEN NOW...' DSPLY C Open pfBMAST C If *IN77 C 'CANNOT OPEN' DSPLY c status dsply C Eval *inlr = *on c Return c Endif c Eval *in66 = '1' c* This loop goes on till atleast 1 successful c* READ operation is done. c* c dow *in66 = '1' c Read BM c* will wait 60 seconds c* If record still not available c* will switch on 66 c* C If *IN66 C 'CANNOT read' DSPLY c status dsply c Iter c else c* Do some database c* processing here... c 'RPFIDS 2' dsply c bcode dsply c bname dsply c bprice dsply c endif c enddo c 'ENDING 2' DSPLY c C Close pfBMAST C Eval *inlr=*on C Return
77
6655
OUTPUT as recd by SAM3 : Object is Alocated *EXCL. This msg is displayed till ENTER is pressed. OUTPUT as seen by SAM2 : DSPLY DSPLY DSPLY
OPEN NOW... CANNOT OPEN 1217
185
RPG-ILE LABS ALCOBJ can be used for all Modes : *EXCL, *SHRRD, *SHRUP, *SHRNUP. LAB : Error Handling a DELETE operation Program of SAM3 : RPFIDS3 Opens pfbmast in Update mode and reads first record and stops with a DSPLY. Thus the first record is effectively locked. Program of SAM2 : RPFIDS2 FPFBMAST uF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* C 'OPEN NOW...' DSPLY C Open pfBMAST c Read BM c Read BM c 1 Setll BM c 'Will DLT now'Dsply c* -----------------------------------------------------------c* -----------------------------------------------------------c*| Run RPFIDS3 now. RPFIDS3 reads the First rec and locks it. c*| Can RPFIDS2 delete this record now ? c* -----------------------------------------------------------c c Delete bm c If *in88 = *on c Eval *in88 = *off c 'Canot delete'Dsply c Status Dsply c Else c 'dlt done !' Dsply c Endif c 'ENDING 2' DSPLY c C Close pfBMAST C Eval *inlr=*on C Return
55 55
88
OUTPUT : DSPLY DSPLY DSPLY DSPLY
OPEN NOW... Will DLT now Canot delete 1221
Run RPFIDS2 first. When it displays “Will DLT now”, run RPFIDS3. RPFIDS3 reads first record in the PFBMAST and shows bcode value.Keep RPFIDS3 just at this point and press
186
RPG-ILE LABS enter to continue running RPFIDS2. Now RPFIDS2 tries to DELETE record #1 but cannot since RPFIDS3 has locked it. This the 77 indicator of the DELETE opcode becomes ON. Display the Value of Status which comes out to be 1221 (unable to DELETE !) NOW try the same trick with UPDATE : Code for SAM2 is changed as follows : FPFBMAST uF E DISK USROPN infds(dsBMast) DMsg s 50a d* DDsBMast DS DIsEOF 10 10 DStatus 11 15 0 DOpCode 16 21 DMsgNbr 46 52 c* C 'OPEN NOW...' DSPLY C Open pfBMAST c Read BM c Read BM c 1 Setll BM c 'Will UPD now'Dsply c* -----------------------------------------------------------c*| Run RPFIDS3 now. RPFIDS3 reads the First rec and locks it. c*| Can RPFIDS2 delete this record now ? c* -----------------------------------------------------------c Eval Bcode = 122 c Eval BName = 'ACAD' c Eval BPrice= 180 c Update bm c If *in88 = *on c Eval *in88 = *off c 'Canot Update'Dsply c Status Dsply c Else c 'UPD done !' Dsply c Endif c 'ENDING 2' DSPLY c C Close pfBMAST C Eval *inlr=*on C Return
55 55
88
OUTPUT : DSPLY DSPLY DSPLY DSPLY
OPEN NOW... Will UPD now Canot Update 1221
Importance of POST opcode : The fields from position 1 to position 66 in the file feedback section of the INFDS are always provided and updated even if INFDS is not specified in the program. The fields from position 67 to position 80 of the file feedback section of the INFDS are only updated after a POST operation to a specific device.
LAB : Handling database WRITE errors
187
RPG-ILE LABS Unique (Primary key) violation : Following program tries to load duplicate record. BCODE has a Primarky Key constraint and hence the WRITE operation fails. The status code is displayed. COUTION : The BKMAST2 file must be Journaled before the following program can run. Listing : FpfBMAST2 UF A E DISK InfDS(DSBMAST) dDSBMAST DS dStatus *status f* c c Open pfBMAST2 c If *in77 c status Dsply c Eval *inlr = *on c Return c EndIF c c Read BM c* ------------------------------------------------c Eval Bcode = 101 c Eval BName = 'xxx' c Eval BPrice = 100 c* c* WRITE operation will fails. c* Hence use indicator in LO indicator. c* c Write BM c If *in77 = *on c* error inwrite c 'cannot write'Dsply c Status Dsply c Eval *in77 = *off c Endif c c c Close pfBMAST2 c Eval *inlr = *on c Return
77
55
77
Record cannot be written since 1 record already has this BCODE value. STATUS CODE : 1215 Referential Intregity Constraint Violation : LAB :Handling referential integrity errors. Pre-Requisites : 2 Physical files : 1 master database and 1 Transaction database must be available. Th Master database file (PFBMAST) contains BCODE,BNAME and BPRICE. Another database file BTRANS contains BCODE, BQTY,BMODE. The BCODE in Master file PK constraint and bcode in transaction file has FK constraint. The followign program tries to write invalid record to the Transaction file. The status code is displayed. (1022)
188
RPG-ILE LABS F*fBMAST2 IF E DISK FpfTRANs UF A E DISK Prefix(x:1) INFDS(dstrans) USROPN dDSTRANS DS dStatus *status f* f* PfTran has fields with the same name as in PFBMAST. f* If you use prefix for pfTRAN, all fields and record format also f* can be referenced by replaceing their first letter by x. For f* example, a field in BTrans is BCode.It becomes xCode. f* c c Open PFTRANS c c Read BTrans 55 c* put a invalid value for xcode. there is no book inthe Book Master c* table with this name. Since the 2 tables are linked by referential c* Integrity, the record cannot be written to BTrans c* ------------------------------------------------c Eval xcode = 7777 c Eval xQty= 7777 c Eval xMode = 'I' c* c* WRITE operation will fails. c* Hence use indicator in LO indicator. c* c Write BTrans 77 c If *in77 = *on c* error inwrite c 'cannot write'Dsply c Status Dsply c Eval *in77 = *off c Endif c c c Close PFTRANS c Eval *inlr = *on c Return OUTPUT : DSPLY DSPLY
cannot write 1022
LAB : Inserting NULL values into database fields Database file : A A A A A A
UNIQUE(*EXCNULL) R BM BCODE BNAME BPRICE K BCODE
4S 0 30A 7S 2
ALWNULL
UNIQUE(*EXCNUL) allows duplicate NULL values. UNIQUE constraint is not applied to NULL values entered.
189
RPG-ILE LABS By saying ALWNUL to BCODE, we can enter NULL values into BCODE. Program Write 1 Null to BCODE and XML to BNAME. Then it reads all records form start and disdplays records where BCODe is NULL. Listing : FpfBMAST UF A E DDSBMAST DS DStatus *status D* c c Open c If c status Dsply c Eval c Return c EndIF c c Read c* ---Set Bcode to NULL using c Eval c Eval c Eval c* c Write c If c* error inwrite c 'cannot write'Dsply c Status Dsply c Eval c Endif c c 1 Setll c Dow c Read c If c Leave c Endif c If c 'Null !' Dsply c BName Dsply c EndIf c Enddo c Close c Eval c Return
DISK
InfDS(DSBMAST) UsrOpn
pfBMAST *in77
77
*inlr = *on
BM NULL Indicator --------%NullInd(bcode) = '1' BName = 'XML' BPrice = 177 BM *in77 = *on
55
77
*in77 = *off BM '1' Bm *in77
77
%NullInd(BCode)
pfBMAST *inlr = *on
Compilation : 14 then F4 specify *USRCTL to Allow Null Fields option.Pree ENTER. c
If
%NullInd(BCode)
This line checks if Value of BCOde for currently read record is Null or Not. If it IS null, the %NULLIND function returns a TRUE.
OUTPUT
:
190
RPG-ILE LABS DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
Null ! name1 Null ! name1 Null ! XML Null ! XML
During compilation you get following errors /warnings if *USRCTL is not specified for BCODE : Msg id Sv Number Seq Message text *RNF7150 00 1 000100 Record BM in file PFBMAST contains null capable fie *RNF7420 30 19 001500 %NULLIND cannot be used when ALWNULL(*USRCTL) is no specified. *RNF7420 30 37 003300 %NULLIND cannot be used when ALWNULL(*USRCTL) is no specified. OUTPUT of RUNQRY on PFBMAST : BCODE BNAME -
Hee XML XML XML
BPRICE 120.00 177.00 177.00 177.00
191
RPG-ILE LABS Flat Physical file Use CRTPF to create a flat physical file. Don’t specify the source PF or member name. Only specify the record format length, and press ENTER. RPG listing to access the flat physical file : fpfflat if c c xpfflat c
e Read dsply Eval
disk r1
rename(pfflat:r1) prefix(x)
*inlr = *on
192
RPG-ILE LABS LAB : Overriding a member of Database file fPFMEM IF E dQCMDEXC PR darg1 darg2 dcmd001 s dcmdLen s c Open c Read c bcode dsply c bname dsply c Close c* c Eval c eval c callp c Open c 1 Setll C Read c 66'read err' dsply c BCode Dsply c BName Dsply c close c* c Eval c eval c callp c Eval c eval c callp c Open C Read c BCode Dsply c BName Dsply c Close c Eval c Return
DISK
usropn ExtPgm('QCMDEXC')
50a 15p 5 50a 15p 5 pfmem bm
44
PFMEM cmd001 = 'OVRDBF file(PFMEM) MBR(JAN)' cmdLen = %Len(%trim(cmd001)) QCMDEXC(cmd001:cmdlen) PFMEM bm BM 6655
pfmem cmd001 = 'dltovr file(PFMEM)' cmdLen = %Len(%trim(cmd001)) QCMDEXC(cmd001:cmdlen) cmd001 = 'OVRDBF file(PFMEM) MBR(FEB)' cmdLen = %Len(%trim(cmd001)) QCMDEXC(cmd001:cmdlen) PFMEM BM 55 PFMEM *inlr = *on
The Physical file PFMEM has 3 members
: PFMEM , JAN and FEB
The data in JN and FEB can be displayed using above program. ODP
193
RPG-ILE LABS
ENBEDDED SQL : LAB : Embedded SQL : basics dnCode s 4s 0 inz(0) dnTemp s 7s 2 inz(45.00) d d d* I have made sure that only 1 record is returned. d* d* c/EXEC SQL c+ Select bcode into :nCode from pfbmast where c+ bprice = :nTemp c/END-EXEC c nCode Dsply c Eval *inlr = *on c Return c* c* NOTES : 1. 1.
Type of the program should be SQLRPGLE. Do option 14 and press F4. Specify *NONE to commitment control.
LAB : Implement a Cursor dnCode s 4s 0 inz(0) dsName s 10a dnTemp s 7s 2 inz(45.00) d d c/EXEC SQL c+ DECLARE C1 Cursor For select bcode,bname from pfbmast c+ where bcode IS NULL c/END-EXEC c/EXEC SQL c+ Open C1 c/END-EXEC c c* Start reading the data c* ---------------------c Dow '1' c/EXEC SQL c+ Fetch from C1 into :nCode,:sName c/END-EXEC c*c If SQLCOD = 100 c Leave c Endif c*-c c nCode Dsply c sName Dsply c Enddo c c* -------Now close the cursor ----------
194
RPG-ILE LABS c/EXEC SQL c+ Close C1 c/END-EXEC c c c* c*
Eval Return
*inlr = *on
LAB : Implementing a Scroll cursor Accept the relative position from the current cursor pointer position and display the record. If too high a relative position is specified, the SQLCOD is set to 100 (position exceeeds the last record in the cursor) The pointer remains at the current record. Relative works this way : Suppose of cursor pointer position is rec #4. If you specify RELATIVE :n where n is 2, the pointer goes like : 5,6 and stops at 6 since that is the second record from the 4th record. IF you specify Relative :n where nis – 2, the pointer goes back 2 records ie. To the second record. Listing : dnCode s 4s 0 inz(0) dsName s 10a dnRecNum s 4s 0 inz(-2) d d c/EXEC SQL c+ DECLARE C1 scroll Cursor For select bcode,bname from pfbmast c+ where bcode <110 c/END-EXEC c/EXEC SQL c+ Open C1 c/END-EXEC c c* Start reading the data c* ---------------------c Dow '1' c/EXEC SQL c+ Fetch relative :nRecNum from C1 into :nCode,:sName c/END-EXEC c*-c c nCode Dsply c sName Dsply c SqlCod Dsply c SqlWrn Dsply c 'Pos :(0:End)'Dsply nRecNum c If nRecNum = 0 c Leave c Endif c c Enddo c c* -------Now close the cursor ---------c/EXEC SQL c+ Close C1 c/END-EXEC c Eval *inlr = *on
195
RPG-ILE LABS c c* c*
Return
OUTPUT : DSPLY DSPLY DSPLY DSPLY DSPLY 1 DSPLY DSPLY DSPLY DSPLY DSPLY
108 EXCEL 100 Pos :(0:End)
2
108 EXCEL 100 Pos :(0:End)
1
Type reply, press Enter. Reply . . . __________________________________
LAB : Implementing a Dynamic scroll cursor Program displays the first record in the cursor (which contains all records). It asks for position and sets pointer to that position. Actually, it asks if the current record is to be updateed or not before positioning to the requested record. After updating , it points to the new record requested. dnCode s 4s dsName s 10a dnRecNum s 4s dsDecide s 1a d d c/EXEC SQL c+ DECLARE C1 DYNAMIC scroll Cursor c+ from pfbmast c/END-EXEC c/EXEC SQL c+ Open C1 c/END-EXEC c c* Start reading the data c* ---------------------c Dow '1' c/EXEC SQL c+ Fetch relative :nRecNum from C1 c/END-EXEC c*-c 'DATA READ :-'Dsply c nCode Dsply c sName Dsply c 'Code/Warn :' Dsply c SqlCod Dsply c SqlWrn Dsply
0 inz(0) 0 inz(1) inz('n')
For select bcode,bname
into :nCode,:sName
196
RPG-ILE LABS c 'Pos :(9:End)'Dsply nRecNum c If nRecNum = 9 c Leave c Endif c c c 'Update ?' dsply sDecide c*002 c If sDecide = 'y' Or sDecide = 'Y' c 'New Code :' dsply nCode c c/exec sql c+ update pfbmast set BCode =:nCode Where Current of C1 c/End-Exec c 'UPD CD/WRN :'Dsply c SqlCod Dsply c Sqlwrn Dsply c Sqlwn0 Dsply c EndIf c*002 c Enddo c c* -------Now close the cursor ---------c/EXEC SQL c+ Close C1 c/END-EXEC c Eval *inlr = *on c Return c* c* Output :
LAB : Error Handling : watching values of SQLCOD and SQLERR for insert/update errors
In the following program, the first iteration of the DOW loop tries to load 120value into to the BCODE field. This violates PK constraint on the BKMAST since oen of the records already has BCODE as 120. Study the values of SQLCOD and SQLERR : dnCode s 4s 0 inz(120) dsName s 10a dnPrice s 7s 2 inz(100) dsDecide s 1a inz('n') dnTemp s 7s 2 inz(45.00) dCntr s 4s 0 inz(0) d* ---------------------------------------------------------------------D* SQL Communications area :automatically added,hence I commented it out. d* ---------------------------------------------------------------------D*SQLCA DS D* SQLAID 1 8A D* SQLABC 9 12B 0 D* SQLCOD 13 16B 0 D* SQLERL 17 18B 0 D* SQLERM 19 88A
197
RPG-ILE LABS D* SQLERP 89 96A D* SQLERRD 97 120B 0 DIM(6) D* SQLERR 97 120A D* SQLER1 97 100B 0 D* SQLER2 101 104B 0 D* SQLER3 105 108B 0 D* SQLER4 109 112B 0 D* SQLER5 113 116B 0 D* SQLER6 117 120B 0 D* SQLWRN 121 131A D* SQLWN0 121 121A D* SQLWN1 122 122A D* SQLWN2 123 123A D* SQLWN3 124 124A D* SQLWN4 125 125A D* SQLWN5 126 126A D* SQLWN6 127 127A D* SQLWN7 128 128A D* SQLWN8 129 129A D* SQLWN9 130 130A D* SQLWNA 131 131A D* SQLSTT 132 136A c c c Dow '1' c/EXEC SQL c+ Insert into pfbmast values (:nCode,:sName,:nPrice) c/END-EXEC c*c 'Code :' Dsply c nCode Dsply c 'Price :' dsply c nPrice Dsply c 'sqlcod' Dsply c sqlcod Dsply c*-c 'sqlerr' Dsply c sqlerr Dsply c*-c 'sqlwrn' Dsply c sqlwrn Dsply c*-c 'sqlwn0' Dsply c sqlwn0 Dsply c*-c Eval nPrice = nPrice * 2 c Eval nCode = nCode - 1 c 'Exit ?' Dsply sDecide c If sDecide = 'y' OR sDecide = 'Y' Leave c Endif c Enddo c c Eval *inlr = *on c Return c* c* OUTPUT : For error in input :
198
RPG-ILE LABS DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY DSPLY
Code : 120 Price : 10000 sqlcod 803sqlerr 50345009 sqlwrn
This is actually 100.00
sqlwn0 Exit ?
n
Type reply, press Enter. Reply . . . ________________________________________ SQLCOD is –803 when the PK constraint in violated. OUTPUT : For valid input : DSPLY Code : DSPLY 119 DSPLY Price : DSPLY 20000 DSPLY sqlcod DSPLY 0 DSPLY sqlerr DSPLY DSPLY sqlwrn DSPLY DSPLY sqlwn0 DSPLY DSPLY Exit ? n
7956
Type reply, press Enter. Reply . . . ________________________________________ LAB : Prepared statement
199
RPG-ILE LABS
LAB : QCMDEXC dStrCommand dCmdLen c c c c 'Done' c c
s s call Parm Parm dsply Eval Return
7a inz('WRKSPLF') 15p 5 inz(7) 'QCMDEXC' StrCommand CmdLen *inlr = *on
Interactive Comand Execution by promting : d* Program demostrates command prompting. The program will run d* CrtLIb command and display the command on screen, since d* ? is used, prompting for the entire command starts. d* Provide a lib name, type and press ENTER. d* If you press F3, (refuse to run the command) a message is d* recieved. Use PSSR to handle error. d* dStrCommand s 90a dCmdLen s 15p 5 inz(7) c Eval StrCommand = '?CRTLIB' c call 'QCMDEXC' c Parm StrCommand c Parm CmdLen c End1 Tag c 'Done' dsply c Eval *inlr = *on c Return c *PSSR Begsr c Goto End1 c Endsr
200
RPG-ILE LABS
PAGE : 253 ADDITIONS TO THE MAIN COVERAGE BEGIN HERE (ADDILE5 ) LAB : Work in VARSIZE (passign a pramater lesser than expected size as a prameter to procedure)
201
RPG-ILE LABS LAB : /free DateDue = %date (DUEDATE: *ISO); DaysLate = %diff (CurDate: DateDue: *d);
LAB : %Char %Int Convert a char to int , int to char, char to float float to char LAB : D D D D
CharToNum PI 30P 9 string 100A CONST VARYING decComma 2A CONST OPTIONS(*NOPASS) currency 1A CONST OPTIONS(*NOPASS)
/free // override defaults if optional parameters were passed if %parms > 1; decPoint = %subst(decComma : 1 : 1); comma = %subst(decComma : 2 :1); endif; if %parms > 2; cursym = currency; endif; // initialization len = %len(string); // begin reading the integer part pNumPart = %addr(intPart); // loop through characters for i = 1 to len; c = %subst(string : i : 1); select; // ignore blanks, digit separator, currency symbol when c = comma or c = *blank or c = cursym; iter; // decimal point: switch to reading the decimal part when c = decPoint; pNumPart = %addr(decPart); iter; // sign: remember the most recent sign when c = '+' or c = '-'; sign = c; iter; // more signs: cr, CR, () are all negative signs when c = 'C' or c = 'R' or c = 'c' or c = 'r' or c = '(' or c = ')'; sign = '-'; iter; // a digit: add it to the current build area other; eval numPart = numPart + c; endsl; endfor; // copy the digit strings into the correct positions in the // zoned variable, using the character overlay
202
RPG-ILE LABS decStart = %len(result) - %decPos(result) + 1; intStart = decStart - %len(intPart); eval %subst(resChars : intStart : %len(intPart)) = intPart; eval %subst(resChars : decStart : %len(decPart)) = decPart; // if the sign is negative, return a negative value if sign = '-'; return -result; // otherwise, return the positive value else; return result; endif; /end-free pe
LAB : Example of a recursive call to a sub-procedure (A data item that is defined in a subprocedure uses automatic storage unless the STATIC keyword is specified for the definition.) LAB : Embeded SQL code in ILE program to be convered to Module and Bound to main line module using : CRTPGM and CGTBNGRPG (see page 80 of ilerpg) LAB : working with compiler reports You can control the spacing and pagination of the compiler listing through the use of the /EJECT and /SPACE compiler directives. The /EJECT directive forces a page break. The /SPACE directive controls line spacing within the listing. For more information on these directives refer to the ILE RPG Reference.
LAB : RPG cycle program with Match fields LAB : A status Module that contains error data structure. Any module / procedure hasa problem, it updates the data structure. This is useful when a second procedure wishes to see the resultts of execution of the last procedure. Module is a NOMAIN and has only error data structure. LAB : Running 2 programs in same actgrp and in commitment env. If 1 commits, can the other rollback ? LAB : Running 2 programs in same actgrp and in commitment env. If 1 program reads a rec, can some other job access the record ? (is it locked ? ) How is locking done in commitment control ? LAB : Demonstrate power of UPDSRVPGM : by independantly updating a single module in a service program and running the client application without any re-compilation. LAB : 2 Modules export procedure of the same name, it that OK ? If a client calls the procedure, which one will be called ?
203
RPG-ILE LABS LAB : A main line program declares a global int i. A bound module exports an int i. The main line module get which I ? the imported one or the local one ? LAB : Debugging a LE program that uses /COPY to include external source code fragments LAB : using CHGPGM, UPDPGM, DSPPGM,DSPPGMREF,WRKPGM In general, you can update a program by replacing modules as needed. For example, if you add a new procedure to a module, you recompile the module object, and then update the program. You do not have to re-create the program. UPDPGM can be used to update Module objects. To update a program created by CRTBNDRPG command, you must ensure that the revised module is in the library QTEMP. This is because the temporary module used when the CRTBNDRPG command was issued, was created in QTEMP. Once the module is in QTEMP, you can issue the UPDPGM command to replace the module. To change the optimization level of a program, use the CHGPGM command. DSPMOD : displays the optimisation level of the Module.
LAB : observability
Removing Observability
Observability involves the kinds of data that can be stored with an object, and that allow the object to be changed without recompiling the source. The addition of this data increases the size of the object. Consequently, you may want to remove the data in order to reduce object size. But once the data is removed, observability is also removed. You must recompile the source and recreate the program to replace the data. The types of data are: Create Data Represented by the *CRTDTA value. This data is necessary to translate the code to machine instructions. The object must have this data before you can change the optimization level. Debug Data Represented by the *DBGDTA value. This data is necessary to allow an object to be debugged. Profiling Data Represented by the *BLKORD and *PRCORD values. This data is necessary to allow the system to re-apply block order and procedure order profiling data. Use the CHGPGM command or the CHGMOD command to remove some or all the data from a program or module respectively. Removing all observability reduces an object to its minimum size (without compression). It is not possible to change the object in any way unless you re-create it. Therefore, ensure that you
86
ILE RPG Programmer’s Guide
have all source required to create the program or have a comparable program object with CRTDATA. To re-create it, you must have authorization to access the source code.
Reducing an Object’s Size
The create data (*CRTDTA) associated with an ILE program or module may make up more than half of the object’s size. By removing or compressing this data, you will reduce the secondary storage requirements for your programs significantly.
Changing a Module or Program Page 105
204
RPG-ILE LABS LAB : DSPSRVPGM : To display procedures (services) exported by the service procedure. LAB : working with service program
Changing A Service Program
You can update or change a service program in the same ways available to a program object. In other words, you can: v Update the service program (using UPDSRVPGM) v Change the optimization level (using CHGSRVPGM) v Remove observability (using CHGSRVPGM) v Reduce the size (using CPROBJ) For more information on any of the above points, see “Changing a Module or Program” on page 84.
Related CL commands
The following CL commands are also used with service programs: v Change Service Program (CHGSRVPGM) v Display Service Program (DSPSRVPGM) v Delete Service Program (DLTSRVPGM) v Update Service Program (UPDSRVPGM) v Work with Service Program (WRKSRVPGM) LAB : using operation descriptors The service program makes use of operational descriptors, which is an ILE construct used when the precise nature of a passed parameter is not known ahead of time, in this case the length. The operational descriptors are created on a call to a procedure when you specify the operation extender (D) on the CALLB operation, or when OPDESC is specified on the prototype. To use the operational descriptors, the service program must call the ILE bindable API, CEEDOD (Retrieve Operational Descriptor). This API requires certain parameters which must be defined for the CALLB operation. However, it is the last parameter which provides the information needed, namely, the length. For more information on operational descriptors, see “Using Operational Descriptors” on page 135. *=================================================================* * CvtToHex - convert input string to hex output string *=================================================================* H COPYRIGHT('(C) Copyright MyCompany 1995') D/COPY RPGGUIDE/QRPGLE,CVTHEXPR *-----------------------------------------------------------------* * Main entry parameters * 1. Input: string character(n) * 2. Output: hex string character(2 * n) *-----------------------------------------------------------------* D CvtToHex PI OPDESC D InString 16383 CONST OPTIONS(*VARSIZE) D HexString 32766 OPTIONS(*VARSIZE) *-----------------------------------------------------------------* * Prototype for CEEDOD (Retrieve operational descriptor) *-----------------------------------------------------------------* D CEEDOD PR D ParmNum 10I 0 CONST D 10I 0 D 10I 0 D 10I 0 D 10I 0 D 10I 0 D 12A OPTIONS(*OMIT) * Parameters passed to CEEDOD D DescType S 10I 0
205
RPG-ILE LABS D DataType S 10I 0 D DescInfo1 S 10I 0 D DescInfo2 S 10I 0 D InLen S 10I 0 D HexLen S 10I 0 *-----------------------------------------------------------------* * Other fields used by the program * *-----------------------------------------------------------------* D HexDigits C CONST('0123456789ABCDEF') D IntDs DS D IntNum 5I 0 INZ(0) D IntChar 1 OVERLAY(IntNum:2) D HexDs DS D HexC1 1 D HexC2 1 D InChar S 1 D Pos S 5P 0 D HexPos S 5P 0 Figure 42. Source for Service Program CvtToHex (Part 1 of 2) Chapter 8. Creating a Service Program 93
*-----------------------------------------------------------------* * Use the operational descriptors to determine the lengths of * * the parameters that were passed. * *-----------------------------------------------------------------* C CALLP CEEDOD(1 : DescType : DataType : C DescInfo1 : DescInfo2: Inlen : C *OMIT) C CALLP CEEDOD(2 : DescType : DataType : C DescInfo1 : DescInfo2: HexLen : C *OMIT) *-----------------------------------------------------------------* * Determine the length to handle (minimum of the input length * * and half of the hex length) * *-----------------------------------------------------------------* C IFInLen > HexLen / 2 C EVAL InLen = HexLen / 2 C ENDIF *-----------------------------------------------------------------* * For each character in the input string, convert to a 2-byte * * hexadecimal representation (for example, '5' --> 'F5') * *-----------------------------------------------------------------* C EVAL HexPos = 1 C DO InLen Pos C EVAL InChar = %SUBST(InString : Pos :1) C EXSR GetHex C EVAL %SUBST(HexString : HexPos : 2) = HexDs C EVAL HexPos = HexPos + 2 C ENDDO *-----------------------------------------------------------------* * Done; return to caller. * *-----------------------------------------------------------------* C RETURN *=================================================================* * GetHex - subroutine to convert 'InChar' to 'HexDs' * ** * Use division by 16 to separate the two hexadecimal digits. * * The quotient is the first digit, the remainder is the second. * *=================================================================* C GetHex BEGSR C EVAL IntChar = InChar C IntNum DIV 16 X1 5 0 C MVR X2 5 0 *-----------------------------------------------------------------* * Use the hexadecimal digit (plus 1) to substring the list of * * hexadecimal characters '012...CDEF'. * *-----------------------------------------------------------------*
206
RPG-ILE LABS C EVAL HexC1 = %SUBST(HexDigits:X1+1:1) C EVAL HexC2 = %SUBST(HexDigits:X2+1:1) C ENDSR Figure 42. Source for Service Program CvtToHex (Part 2 of 2)
Sample Service Program 94 ILE RPG Programmer’s Guide When designing this service program, it was decided to make use of binder language to determine the interface, so that the program could be more easily updated at a later date. Figure 44 shows the binder language needed to define the exports of the service program CVTTOHEX. This source is used in the EXPORT, SRCFILE and SRCMBR parameters of the CRTSRVPGM command. The parameter SIGNATURE on STRPGMEXP identifies the interface that the service program will provide. In this case, the export identified in the binder language is the interface. Any program bound to CVTTOHEX will make use of this signature. The binder language EXPORT statements identify the exports of the service program. You need one for each procedure whose exports you want to make available to the caller. In this case, the service program contains one module which contains one procedure. Hence, only one EXPORT statement is required. *=================================================================* * CvtToHex - convert input string to hex output string * * Parameters * 1. Input: string character(n) * 2. Output: hex string character(2 * n) *=================================================================* D CvtToHex PR OPDESC D InString 16383 CONST OPTIONS(*VARSIZE) D HexString 32766 OPTIONS(*VARSIZE) Figure 43. Source for /COPY Member with Prototype for CvtToHex STRPGMEXP SIGNATURE('CVTHEX') EXPORT SYMBOL('CVTTOHEX') ENDPGMEXP Figure 44. Source for Binder Language for CvtToHex
Sample Service Program
LAB : system reply list Use the Change Job (CHGJOB) command (or other CL job command) to indicate that your job uses the reply list for inquiry messages. To do this, you should specify *SYSRPYL for the Inquiry Message Reply (INQMSGRPY) attribute. The reply list is only used when an inquiry message is sent by a job that has the Inquiry Message Reply (INQMSGRPY) attribute specified as INQMSGRPY(*SYSRPYL). The INQMSGRPY parameter occurs on the following CL commands: v Change Job (CHGJOB) v Change Job Description (CHGJOBD) v Create Job Description (CRTJOBD) v Submit Job (SBMJOB). You can also use the Work with Reply List Entry (WRKRPYLE) command to change or remove entries in the system reply list. For details of the ADDRPYLE and WRKRPYLE commands, see the CL and APIs section of LAB : Run a program in DFTACTGRP or a named ACTGRP , do not seton the LR Are the files opened ? does RCLRSC close the files.
207
RPG-ILE LABS Isthis why a parent program uses FREE opcode ? to free the resources of a child that ended normally without setting On the LR ? When a program does not do a seton lr and ends, and suppose it runs in a named act grp, then the files opened by the program remain open. Do RCLRSC (mostly) to close files or do a RCLACTGRP to delete the act grp : this cleans up any resources loced up and closes open files.
LAB : Parent handles the *ESCAPE message sent by the child. d LAB : RCLRSC
Reclaim Resources Command
The Reclaim Resources (RCLRSC) command is designed to free the resources for programs that are no longer active. The command works differently depending on how the program was created. If the program is an OPM program or was created with DFTACTGRP(*YES), then the RCLRSC command will close open files and free static storage. For ILE programs or service programs that were activated into the OPM default activation group because they were created with *CALLER, files will be closed when the RCLRSC command is issued. For programs, the storage will be re-initialized; however, the storage will not be released. For service programs, the storage will neither be re-initialized nor released. For ILE programs associated with a named activation group, the RCLRSC command has no effect. You must use the RCLACTGRP command to free resources in a named activation group. LAB :
Creating a Program for Source Debugging In this example you create the program EMPRPT so that you can debug it using the source debugger. The DBGVIEW parameter on either CRTBNDRPG or CRTRPGMOD determines what type of debug data is created during compilation. The parameter provides six options which allow you to select which view(s) you want: v *STMT — allows you to display variables and set breakpoints at statement locations using a compiler listing. No source is displayed with this view. v *SOURCE — creates a view identical to your input source. v *COPY — creates a source view and a view containing the source of any /COPY members. v *LIST — creates a view similar to the compiler listing. v *ALL — creates all of the above views. v *NONE — no debug data is created. The source for EMPRPT is shown in Figure 28 on page 56.
208
RPG-ILE LABS 1. To create the object type: CRTBNDRPG PGM(MYLIB/EMPRPT) DBGVIEW(*SOURCE) DFTACTGRP(*NO)
209
RPG-ILE LABS
Chapter 12 : debugging programs
LAB : Debugging a ILE program Prepare your ILE RPG program for debugging • Start a debug session • Add and remove programs from a debug session • View the program source from a debug session • Set and remove breakpoints and watch conditions • Step through a program • Display and change the value of fields • Display the attributes of fields • Equate a shorthand name to a field, expression, or debug command You can prevent database files in production libraries from being modified unintentionally by using one of the following commands: v Use the Start Debug (STRDBG) command and retain the default *NO for the UPDPROD parameter
LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB :
210
RPG-ILE LABS
LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : LAB : Compiler listing as a very useful source of documentation (esp for program maintenance). Specify debugging and line no options in the compiler commandoptions toinclude all them in the compiler listing. SEE PAGE 89 LAB : Debugging : All options of debugging views etc. to get most out of debugger. Debug commands. Lab : page 89 Both the CRTBNDRPG and CRTRPGMOD (see “Using the CRTRPGMOD Command” on page 74) commands create and update a data area with the status of the last compilation. This data area is named RETURNCODE, is 400 characters long, and is placed into library QTEMP.
SECTION 3 : SHARING ODP,OVERRIDE, OPENDBF ,ACTIVATION GROUP LAB : STUDY OF SHARED OPEN DATA PATH AND SCOPING.
211
RPG-ILE LABS LISTING OF CL001 : CALL RP01 CALL RP02 OUTPUT : 1 2 1 2 RP01 AND RP02 READ 2 RECORDS FROM FILE PFBM2. 9TYPICAL BCODE,BNAME BPRICE FILE) OUTPUT SHOWS BCODES AS 1 2 1 2. THIS IS BECAUSE WHEN RP01 IS STARTED, IT OPENS THE FILE PFBM2 AND SETS UP AN ODP. Reads 2 records and thus displays 1 2. RP01 ends and closes the ODP. RP02 starts and sets up a new ODP. It does the same thing : reads 2 records and displays bcode : thus output is 1 2. See the following listing of the CL001 program : PGM OVRDBF OPNDBF SNDPGMMSG CALL RP01 CALL RP02 CLOF DLTOVR SNDPGMMSG
FILE(PFBM2) SECURE(*NO) OVRSCOPE(*CALLLVL) + SHARE(*YES) FILE(SAM2/PFBM2) OPTION(*ALL) OPNSCOPE(*ACTGRP) MSG('OUTPUT WHEN THE OVERRIDE WAS APPLIED ') + TOPGMQ(*EXT) OPNID(PFBM2) FILE(PFBM2) LVL(*) MSG('______OVERRIDE REMOVE_______ ') + TOPGMQ(*EXT)
CALL RP01 CALL RP02 ENDPGM OUTPUT : The ovrdbf specifies that file PFBM2 will be opened in the SHARE mode and that this override is scoped to the CALL LEVEL. The currnet CL001 program sets up a call level. All RPG programs called from this CL001 will run in that call level. Scope of the the SHARE (*YES) is ACTGRPDFN level. Since all the programs will run in the DEFAULT ACTIVATION group (they are RPG/400 programs) the ODP is shared by call applications from this and higher call levels. Thus RP01 RP02 and RP003 will share the ODP setup by the OPNDBF command. Listing of RP01 : FPFBM2 C C C C C C C
IF
E 'RP01' BCODE BCODE
DISK DSPLY READ BM DSPLY READ BM DSPLY CALL 'RP003' SETON
33 33 LR
212
RPG-ILE LABS Listing of RP003 : FPFBM2 C C C C C C
IF
E 'RP003' BCODE BCODE
DISK DSPLY READ BM DSPLY READ BM DSPLY SETON
33 33 LR
Listing of RP02 : FPFBM2 C C C C C C
IF
E 'RP02' BCODE BCODE
DISK DSPLY READ BM DSPLY READ BM DSPLY SETON
33 33 LR
RP01 calls RP003 which is run at a higher scoping level. RP003 continues to use the shared ODP since the shared ODP is scoped to ACTGRPDFN. Lab : CL001 calls the programs RP01,RP02 and RP01 calls RP003. CL001 also calls CL002 which sinply calls RP05 and RP06. CL002 does not say anything about override which CL001 has setup an override at the activation group level. Will override apply to the cl002 program ? all are running in the same activation group. YES CL002 calls Rp05 and rp06 and shows that ODP is shared. Listing of CL001 :PGM OVRDBF OPNDBF SNDPGMMSG
FILE(PFBM2) SECURE(*NO) OVRSCOPE(*CALLLVL) + SHARE(*YES) FILE(SAM2/PFBM2) OPTION(*ALL) OPNSCOPE(*ACTGRP) MSG('OUTPUT WHEN THE OVERRIDE WAS APPLIED ') + TOPGMQ(*EXT)
CALL RP01 CALL CL002 CALL RP02 CLOF OPNID(PFBM2) DLTOVR FILE(PFBM2) LVL(*) SNDPGMMSG MSG('______OVERRIDE REMOVE_______ ') + TOPGMQ(*EXT) CALL RP01 CALL RP02 ENDPGM CL002 listing : PGM SNDPGMMSG CALL RP01 CALL RP02 SNDPGMMSG
MSG('CHILD CL002 PROGRAM STARTED. TOPGMQ(*EXT)
') +
MSG('______CL002 DONE_______ ') + TOPGMQ(*EXT)
213
RPG-ILE LABS ENDPGM LAB : Override a OVERRIDE which was applied at the prevous call level. Cl002 LISTING : PGM SNDPGMMSG OVRDBF CALL RP01 CALL RP02 SNDPGMMSG DLTOVR
MSG('CHILD CL002 PROGRAM STARTED.NO SHARING') + TOPGMQ(*EXT) FILE(PFBM2) SHARE(*NO) OPNSCOPE(*ACTGRPDFN) MSG('______CL002 DONE_______ ') + TOPGMQ(*EXT) FILE(PFBM2)
ENDPGM CL002’S OVRDBF HAS NOT WORKED. THE FILE SHARE MODE STILL REMAINS *YES/ THEREFORE, RP01 AND RP02 (CALLED IN CL002) SHOWED THE RECORDS 56 AND 78 RATHER THAN 1 2 1 2 AS EXPECTED. MAYBE CL002 WILL HAVE TO RUN IN ANOTHER ACTIVATION GROUP IN ODER TO GET A SEPARATE ODP. SINCE CL002 IS A CHILD OF CL001 WHICH ALREADY IMPLEMENTED AN OVERRIDE SCOPED TO THE ACTGRPLEVEL, CL002 COMES AT A HIGHER LEVEL AND BELONGS TO THE SAME ACTIVATION GROUP AND IS THUS INFLUENCED BY THE PARENTS OVERRIDE SETTING. LAB : GETTING
A SEPARATE ODP FOR CHILD PROGRAM CL002.
HOW TO GET A SEPARATE ODP FOR CL002 WHICH IS A CHILD OF CL001 ? HERE HOW … LISTING OF CL002 : PGM SNDPGMMSG OVRDBF CALL RP01 CALL RP02 SNDPGMMSG DLTOVR
MSG('CHILD CL002 PROGRAM STARTED.NO SHARING') + TOPGMQ(*EXT) FILE(PFBM2) SECURE(*YES) SHARE(*NO) + OPNSCOPE(*ACTGRPDFN) MSG('______CL002 DONE_______ ') + TOPGMQ(*EXT) FILE(PFBM2)
ENDPGM MAKE SURE SECURE OPTION IS SET TO YES. THIS SECURES THE OVERRIDE FROM OTHER OVERRIDES. FINAL LISTING OF ALL THE FILES : CL001,CL002,RP01,RP02,RP003 IS AS UNDER : CL001 : PGM OVRDBF OPNDBF SNDPGMMSG
FILE(PFBM2) SECURE(*NO) OVRSCOPE(*CALLLVL) + SHARE(*YES) FILE(SAM2/PFBM2) OPTION(*ALL) OPNSCOPE(*ACTGRP) MSG('OUTPUT WHEN THE OVERRIDE WAS APPLIED ') + TOPGMQ(*EXT)
CALL RP01
214
RPG-ILE LABS CALL CL002 CALL RP02 CLOF OPNID(PFBM2) DLTOVR FILE(PFBM2) LVL(*) SNDPGMMSG MSG('______OVERRIDE REMOVE_______ ') + TOPGMQ(*EXT) CALL RP01 CALL RP02 ENDPGM CL002 : PGM SNDPGMMSG OVRDBF
MSG('CHILD CL002 PROGRAM STARTED.NO SHARING') + TOPGMQ(*EXT) FILE(PFBM2) SECURE(*YES) SHARE(*NO) + OPNSCOPE(*ACTGRPDFN)
CALL RP01 CALL RP02 SNDPGMMSG DLTOVR
MSG('______CL002 DONE_______ ') + TOPGMQ(*EXT) FILE(PFBM2)
ENDPGM RP01 : FPFBM2 C C C C C C C
IF
E 'RP01' BCODE BCODE
DISK DSPLY READ BM DSPLY READ BM DSPLY CALL 'RP003' SETON
33 33 LR
RP003 : FPFBM2 C C C C C C RP02 : FPFBM2 C C C C C C
IF
E 'RP003' BCODE BCODE
IF
E 'RP02' BCODE BCODE
DISK DSPLY READ BM DSPLY READ BM DSPLY SETON
33 33 LR DISK
DSPLY READ BM DSPLY READ BM DSPLY SETON
33 33 LR
OUTPUT : OUTPUT WHEN THE OVERRIDE WAS APPLIED DSPLY RP01 DSPLY 1 DSPLY 2
215
RPG-ILE LABS DSPLY RP003 DSPLY 3 DSPLY 4 CHILD CL002 PROGRAM STARTED.NO SHARING DSPLY RP01 DSPLY 1 DSPLY 2 DSPLY RP003 DSPLY 1 DSPLY 2 DSPLY RP02 DSPLY 1 DSPLY 2 ______CL002 DONE_______ DSPLY RP02 DSPLY 5 DSPLY 6 ______OVERRIDE REMOVE_______ DSPLY RP01 DSPLY 1 DSPLY 2 DSPLY RP003 DSPLY 1 DSPLY 2 DSPLY RP02 DSPLY 1 DSPLY 2 SCOPING : I HAD TO KEEP THE SCOPING AS *CALLLVL FOR OVRDBF AND *ACTGRP FOR DOES THIS MEAN THAT OVRDBF WILL BE EFFECTIVE FOR THE CURRENT CL001 PROGRAM ? THEN WHY IS THERE ONE MORE OPTION FOR SCOPING FOR SHARE OPTION ? HOW COME OPTION HAS NO CALLLVL SCOPING ? WHY ARE WE FORCED TO SPECIFY *ACTGRPDFN OR SHARE = *YES OPTION ?
SHARE=YES (CALLLVL) SHARE *JOB FOR
LAB : OPNQRY FILE CLQRYST CALLS CLQRY WHICH USES OPNQRYF AND CALLS RP001. THE ODP IS SHARED SO THAT RP001 DOES NOT GET ALL RECORDS OF PF001,ONLY RECORDS WHERE BCODE < 4. THIS IS A MOST COMMONLY USED TECHNIQUE. LISTING OF CLQRYST : PGM DCL &S *CHAR 40 'BCODE < 4' CALL CLQRY PARM(&S) ENDPGM LISTING OF CLQRYF : PGM PARM(&QRYSTR) DCL &QRYSTR *CHAR 40 OVRDBF FILE(PFBM2) SHARE(*YES) OPNSCOPE(*ACTGRPDFN) OPNQRYF FILE((SAM2/PFBM2)) OPTION(*ALL) QRYSLT(&QRYSTR) /* SHOW ALL RECORDS */ CALL RP001 CLOF PFBM2 DLTOVR FILE(PFBM2) ENDPGM
216
RPG-ILE LABS LISTING OF RP001 : FPFBM2 C C C C C C* C
IF
E *IN03 BCODE
DISK SETOF DOWEQ*OFF READ BM DSPLY ENDDO
03
SETON
LR
03
OUTPUT : 1 2 3 Heirarchy : JOB Contains ACTIVATION GROUP Has CALL LEVELS
217
RPG-ILE LABS
LAB : External indicator (The job switch)
Linkage : RPIND in samlesrc. CODE : * * * * * * *
RPIND. Demostrates external indicators. First set U1 to *ON. then do WRKJOB to see the job atributes. See the job Switch. Notice that it becomes 1000 0000 The first '1' corresponds to U1 indicator.
c c c c c
Eval If Dsply Endif Eval
'test'
*inU1 = *on *inU1 = *ON *inlr = *on
PF contents : nil OUTPUT
:
The job switch changes to 1000 0000 since U1 is turned ON. REMARKS : U1,…U8 are called external indicators since other CL /RPG programs can access the state oof those indicators. LAB : Time opcode dT1 c c c
s T1
T time dsply Eval
T1 *inlr = *on
LAB : Display a block on the screen / Working with Hex characters. DCon2 C Const(X'10') c Con2 dsply c Eval *inlr = *on c Return c*
LAB : RT indicator as against LR indicator.
218
RPG-ILE LABS CODE : * RPIND1. * Demostrates RT indicator. * set up an impossible condition for the LR indicator. * In the following code, LR is never turned ON. * So program never properly terminates. * * But after executing the last C instruction, the program * returns control to OS and seems to end.This is since RT is 1 * If RT is not 1, program will loop infinetely or till LR * becomes 1. * The program actually does not end since calling it agains * displays value of 'a' incremented by 1. * da s 5i 0 inz(10) c Eval *inRT = *on c 'a = ' dsply c a dsply c Eval a = a + 1 c* c* set up an impossible condition c* c if a <0 c Eval *inlr = *on c Endif PF contents : nil OUTPUT
:
Since LR is never turned on, program does not terminate but displays increasing values of a every time it is called. REMARKS : Setting RT to ON
allows program to return control to OS without ending.
LAB : The DEFINE option in the CRTBNDRPG command. Linkage : RPDEFUN CODE : c
'Starting...' DSPLY /if defined(myvar1) c 'ya ! defined'Dsply /else c 'Nop!' Dsply /endif c Eval
*inlr=*on
PF contents :
219
RPG-ILE LABS nil OUTPUT
:
REMARKS : Compile the RPDEFUN program with option 14. and run the program. Output is NOP ! since the MYVAR1 varaible is not defined. Now type 14 to compile the same program again and press F4 and F10 for extended prompting. In the DEFINE parameter specify the name MYVAR1 to #define this variable.Press Enter to Compile . Run the program now. Output is is Ya! Defined. Since now myvar1 is defined to the program. This is called conditional compilation.
220
RPG-ILE LABS LAB :
Random number generation (one possible way).
Linkage : RPRANDOM CODE : dVar1 dVar2 dSysTime c c c* SysTime c c c Var1 c c c Var1 c c
s s s
6s 0 6s 0 z do time Dsply Extrct Eval Dsply Extrct Eval Dsply EndDo Eval
3 SysTime SysTime:*ms Var1 Var1 = Var1/10000 SysTime:*s Var2 Var1 = %abs(Var1 - Var2) *inlr = *on
Random numbers will be generated between 0 and 99. 12.52.00.993000
99 will be generated
12.52.00.000000
2005 2005 2005 2005 2005 2005 2005 2005 2005 2005 2005 2005
03 03 03 03 03 03 03 03 03 03 03 03
24 24 24 24 24 24 24 24 24 24 24 24
0 will be generated
12.52.53.613000 12.52.54.865000 12.52.56.514000 12.53.38.244000 12.53.39.537000 12.53.41.114000 12.54.53.157000 12.54.55.002000 12.54.57.313000 12.56.45.359000 12.56.46.807000 12.56.48.153000
Number generated |53-61| = 8 32 5 14 14 30 38 55 26 10 34 33
Alternative approach : Pick up the MS (milli sec) part, at any time, it will be random between 000 to 999. PF contents :
OUTPUT
:
REMARKS :
221
RPG-ILE LABS LAB : Test cases Concept : A nomain module contains a FNTEST procedure that accepts 3 arguments. The arguments are lenghts of sides of a triangle. If the lenghts are same, the triangle is a equilateral triangle. In that case, a 3 is returned. If any 2 sides have equal length, a 2 is returned (isosceles triangle). If none of the sides are equal, a 0 is returned. We design a test program to test the procedure against some coded into the test program. Name of the stub program : RPTEST.
test data which we hard
It is bound with the RPTEST1 to form JSRP1 *PGM object. Before running JSRP1, use CHGJOB to modify the SWITCH of your job to 1000 000. This makes U1 ON. RPTEST will produce output only if U1 is ON. Linkage : RPTEST (stub program to test FNTEST proc in RPTEST1 module) RPTEST1 (no main contains FNTEST procedure) Both RPTEST and RPTEST1 are Bound by copy to form JSRP1 program object. Run JSRP1 to start the test. CODE : RPTEST Listing : This is the PEP module. dFNTest PR 5i 0 d 5i 0 value d 5i 0 value d 5i 0 value d***** dRetVal s 5i 0 inz(0) dSide1 s 5i 0 inz(10) dSide2 s 5i 0 inz(10) dSide3 s 5i 0 inz(10) c* c* Test Case #1. c* Check for EQUILATERAL TRIANGLE. c* c U1'EQUILA :3' Dsply c Eval RetVal = FNTest(Side1:Side2:Side3) c U1RetVal Dsply c* c* Test Case #2. c* Check for ISOSCELES TRIANGLE. c* c Eval Side1 = 5 c Eval RetVal = FNTest(Side1:Side2:Side3) c U1'ISOSCE : 2' Dsply c U1RetVal Dsply c* c* Test Case #3. c* Check for other than ISO and EQUI. c* c Eval Side2 = 4 c Eval RetVal = FNTest(Side1:Side2:Side3) c U1'None :0' Dsply c U1RetVal Dsply c Eval *inlr = *on
222
RPG-ILE LABS RPTEST1 Listing : This is the nomain module. H* HNomain H* FNTEST return values H* 3 : Equilateral triangle H* 2 : Isosceles triangle H* 0 : None of the above H* H* dFNTEST PR d d d pFNTEST B dFNTEST PI dsd1 dsd2 dsd3 dRetVal s c* c if c Eval c return c EndIf c* c if c Eval c return c* isosceles triangle c EndIf c* c if c Eval c return c* isosceles triangle c EndIf c* c PFNTEST E
5i 5i 5i 5i 5i 5i 5i 5i 5i
0 0 value 0 value 0 value export 0 0 value 0 value 0 value 0 inz(-2)
(sd1=sd2) and (sd1=sd3) and (sd2=sd3) Retval = 3 RetVal (sd1 = sd2 ) or (sd1 = sd3) or ( sd2 = sd Retval = 2 RetVal
(sd1 <>sd2 ) or (sd1 <>sd3) or ( sd2 <>sd Retval = 0 RetVal
PF contents : nil OUTPUT
:
3 sets of test data produce 3 expected results. We are not testing for invalid data (either numeric or otherwise). REMARKS : Other testing areas such as Boundary level testing, validation testing are not covered in this Lab. LAB :
Test case. Program crash because of data overflow.
Program tries to calculate take home amount using formula for compound interest.
223
RPG-ILE LABS Linkage : RPOFL CODE : dth droi damt dyrs c c c
s s s s Eval dsply Eval
th
5i 0 inz(0) 5i 0 inz(10000) 5i 0 inz(10000) 5i 0 inz(50) th = amt * (1 + roi/100) ** yrs *inlr=*on
PF contents : nil OUTPUT
:
The target for a numeric operation is too small to hold the result (C G D F) Message . . . . : Application error. MCH1212 unmonitored by RPDELME at statement 0000000005, instruction X'0000'. Cause . . . . . : The application ended abnormally because an exception occurred and was not handled. The name of the program to which the unhandled exception is sent is RPDELME RPDELME RPDELME. The program was stopped at the high-level language statement number(s) 0000000005 at the time the message was sent. If more than one statement number is shown, the program is an optimized ILE program. Optimization does not allow a single statement number to be determined. If *N is shown as a value, it means the real value was not available. REMARKS : Program is not robust enough to handle overflow errors. EVAL needs to do Error handling. Better solution : The programmer who wrote the procedure should generate Tech specifications of the procedure and design the procedure to accept argument values only within certain sensible ranges. The procedure should set retval variables to some negative values to indicate invalid data values. The tech specs can be handed over to the testor who will build the test cases around the tech specs.
224
RPG-ILE LABS
LAB :
Free and End-Free
Linkage : RPFREE CODE : Linkage : RPFREE ds1 dn1 dn2 dn3 d** /free
s s s s
4 inz('abc') 4s 0 inz(1) 4s 0 inz(2) 4s 0 inz(3)
eval n3 = n1 + n2; dsply 'N1 : ' ; dsply N1 ; dsply 'N2 : '; dsply N2; dsply 'N3 : '; dsply N3; eval *inlr = *on; /End-Free PF contents :
OUTPUT
:
REMARKS :
LAB : Simple program to access records of PFBM. Linkage : RPDSREAD Code : Fdsdbread cf e Fpfbm if e dtemp s /free Read bm; Eval DCode = BCode; Eval DName = BName; Eval DPrice = BPrice; Dow *in03 = *off; Exfmt R1;
Workstn Disk 4s 0
if (*in04 = *on); *in04 = *off; readp bm;
225
RPG-ILE LABS if %Eof; Setll 1, bm; Read bm; EndIf; EndIf ;
//
if (*in05 = *on); *in05 = *off; read bm; If %Eof; setll *hival, bm; EndIf; EndIf ;
DOES NOT WORK !!!
Eval DCode = BCode; Eval DName = BName; Eval DPrice = BPrice; EndDo; Eval *inlr = *on; /End-Free
226
RPG-ILE LABS
227
RPG-ILE LABS FDsmemori CF E Workstn usropn D* D* ___Prototype section begin___ D* DReverse PR D 6s 0 DPGenerate PR DN1 6s 0 DN2 6s 0 DN3 6s 0 DComputeScore Pr d 6s 0 d 6s 0 d 6s 0 d 3s 0 D* __Prototype section End__ DW0N1 s 6s 0 DW0N2 s 6s 0 DW0N3 s 6s 0 DW0Score s 3s 0 C* Main procedure__ c Dow *IN03 = *OFF c Eval *in25 = *OFF c* ____________________________________ c* Dont Show The 'Enter data ' message. c* -----------------------------------c Callp PGenerate(W0N1:W0N2:W0N3) c Eval F1 = W0N1 c Eval F2 = W0N2 c Eval F3 = W0N3 c ExFmt Rmemori c 03 Eval *inlr = *on c 03 Return c Eval F1 = *Zeros c Eval F2 = *Zeros c Eval F3 = *Zeros c Eval *in25 = *on c* Enter Data___ c ExFmt RMemori c* c 03 Eval *inlr = *on c 03 Return c Callp ComputeScore (W0N1:W0N2:W0N3:W0Score) c eval DScore = W0Score c EndDo c Eval *inlr = *on c Return c* c* Main Procedure End c* c* Sub-Procedure Section Begin c* Procedure to generate 3 random numbers. PPGenerate B DPgenerate PI DN1 6s 0 DN2 6s 0 DN3 6s 0 DSysTime s z DTemp s 6s 0 D*
228
RPG-ILE LABS c Time c Extrct c Callp c Extrct c Eval c Eval c Eval c C open(e) c If c* do nothing c EndIf c Time c Extrct c Callp c Extrct c Eval c Eval c Eval c* c* C close C open c Time c Extrct c Callp c Extrct c Eval c Eval c Eval c* c* PPGenerate E P* P* Calculates the score P* PComputeScore B dComputeScore PI dW0N1 dW0N2 dW0N3 dW0Score d* c If c Eval c EndIf c If c Eval c EndIf c If c Eval c EndIf c If c Eval c EndIf PComputeScore E PReverse b dReverse Pi dArg1 dTemp s
SysTime SysTime:*ms N1 Reverse(N1) Systime:*s temp temp = temp * 10 N1 = %Abs(temp-N1) F1 = N1 dsmemori %error() SysTime SysTime:*ms N2 Reverse(N2) Systime:*s temp temp = temp * 10 N2 = %Abs(temp-N2) F2 = N2 dsmemori dsmemori SysTime SysTime:*ms N3 Reverse(N3) Systime:*s temp temp = temp * 10 N3 = %Abs(temp-N3) F3 = N3
6s 6s 6s 3s
0 0 0 0
(F1 = W0N1) AND (F2=W0N2) AND (F3=W0N3) W0Score = 100 (F1 = W0N1) AND (F2=W0N2) and (F3<>W0N3) W0Score = 60 (F1 = W0N1) and (F2<>W0N2) and (F3<>W0N3) W0Score = 30 (F1 <>W0N1) and (F2<>W0N2) and (F3<>W0N3) W0Score = 0
6s 0 6s 0
229
RPG-ILE LABS dStr dCounter dCounter1 dArrStr c c c c c c c c c c c c c c c PReverse
s s s s Eval Eval Do Eval Eval Eval EndDo Eval Eval Do Eval Eval EndDo move Eval
6a 3s 0 inz(1) 3s 0 inz(6) 1a Dim(6) str = %trim(%char(Arg1)) temp = %len(str) 6 ArrStr(counter) = %subst(str:counter1:1) Counter1 = counter1 -1 Counter = counter +1 Counter1 = 6 Counter = 1 6 %subst(str:counter:1)=arrStr(Counter) Counter = counter +1 str Arg1 = Temp
Temp
e
230