|
midrange.com
Code overview:
AG03 - Subfile pgm to show a list of members
Will accept option to print a member
AG01CL - Does overrides and calls AG01
AG01 - Print a source member. Presumes that
the member is pointed to by a prior
OVRDBF
AG02 - "List members" API
The intent is to model somebody converting some OPM code to RPG IV and
starting to build a "WRKMBRPDM" like tool. Currently it accepts only "P" to
print the source. The code is purposely traditional looking.
DDS for AG03
A DSPSIZ(24 80 *DS3)
A CHGINPDFT(HI CS)
A CF03(03 'Exit')
A*
A R MBRSFL SFL
A WOPT 1A B 7 2TEXT('Input option')
A WMBR 10A O 7 6TEXT('Member')
A WTEXT 50A O 7 17TEXT('Text')
A*
A R MBRCTL SFLCTL(MBRSFL)
A SFLSIZ(0010)
A SFLPAG(0010)
A INDTXT(30 'ALARM')
A INDTXT(40 'SFLCLR')
A INDTXT(41 'SFLDSP')
A INDTXT(42 'SFLDSPCTL')
A 30 ALARM
A BLINK
A 40 SFLCLR
A 41 SFLDSP
A 42 SFLDSPCTL
A 1 2DATE
A EDTCDE(Y)
A 1 11TIME
A 1 29'File listing'
A DSPATR(HI)
A DSPATR(UL)
A 1 53SYSNAME
A TMNAME 10A O 1 62TEXT('Terminal name')
A 1 73'MDLDSPC'
A 3 6'File name '
A DSPATR(UL)
A 3 17'Library '
A DSPATR(UL)
A WNAME 10A B 4 6TEXT('File name')
A WLIB 10A B 4 17TEXT('Library')
A 6 1'Opt'
A DSPATR(UL)
A 6 6'Member '
A DSPATR(UL)
A 6 17'Text
-
A '
A DSPATR(UL)
RPG for AG03
* Work with a single page of source members
h debug dftactgrp(*yes) option(*srcstmt: *nodebugio)
* dbgview(*list)
fag03 cf e workstn
f SFILE(mbrsfl:dspRRN)
d dspRRN s 4s 0
d array s 60 dim(10)
d i s 10i 0
d sds
d tmname 244 253
* initial display
c seton 42
sfldspctl
c setoff 41
sfldsp
c setoff 30
alarm
c exfmt mbrctl
* continue to display
c dow *in03 = *off
c exsr loadSfl
c exfmt mbrctl
* see what option was chosen
c if *in41 = *on
sfldsp
c do 10 dspRRN
c dspRRN chain mbrsfl
c if %found
c select
c when wopt = 'P'
c call(e) 'AG01CL'
c parm wname
c parm wlib
c parm wmbr
c endsl
c eval wopt = *blank
c update mbrsfl
c endif
c enddo
c endif
c exfmt mbrctl
c enddo
c seton lr
c loadSfl begsr
* clear the existing page
c setoff 42
sfldspctl
c seton 40
sflclr
c write mbrctl
c setoff 40
sflclr
c setoff 41
sfldsp
c seton 42
sfldspctl
c eval dspRRN = 0
* get the list
c call 'AG02'
c parm wname
c parm wlib
c parm array
* load a single page - artificially stupid to make the code simple
c do 10 i
c eval dspRRN = dspRRN + 1
c movel array(i) wmbr
c move array(i) wtext
c write mbrsfl
c seton 41
sfldsp
c enddo
c endsr
CL for AG01CL
/* This is in AG(*DAG) */
pgm (&file &lib &mbr)
dcl &file *char 10
dcl &lib *char 10
dcl &mbr *char 10
ovrdbf qrpglesrc &lib/&file mbr(&mbr)
call ag01
endpgm
RPG for AG01
* Print a source member (80-80 list)
h debug dftactgrp(*YES)
* dbgview(*list)
fqrpglesrc ip f 112 disk infds(srcInfds)
fqsysprt o f 132 printer oflind(*inof)
dsrcInfds ds
d FILE_NAM 83 92
d FILE_LIB 93 102
d FILE_MBR 129 138
d NUM_RCDS 156 159I 0
d SRC_IND 163 163
d OPEN_COUNT 207 208I 0
iqrpglesrc aa 01
I 13 112 srcdta
oqsysprt h 1p 2 03
o or of
o udate y 8
o 64 'Source listing'
o 127 'AG01 Page'
o page z 132
o h 1p 2 03
o or of
o FILE_NAM
o FILE_LIB + 2
o FILE_MBR + 2
o NUM_RCDS j + 2
o OPEN_COUNT j + 2
o SRC_IND + 2
o d 01 1
o srcdta 100
RPG for AG02
* Get an array of members using the list member API
h debug dftactgrp(*yes) option(*srcstmt: *nodebugio)
* dbgview(*list)
d* These "D" specs were copied from the IBM library QSYSINC
d* and then modified
D*******************************************************************
D*Type Definition for the Input Parameter Section of the user
D*space in the QUSLMBR API.
D*******************************************************************
DQUSQLI00 DS
Qdb Ldbm Input
D QUSSPACE00 1 10
Userspace
D QUSULIB00 11 20
Userspace Library
D SPC 1 20
combined
D QUSFN03 21 28
Format Name
D QUSFILN00 29 38
File Name
D QUSFILLN00 39 48
File Library Name
D QUSMN 49 58
Member Name
D QUSRRIDE00 59 59
Override
D*
D*******************************************************************
D*Type Definition for the MBRL0200 format of the userspace in the
D*QUSLBMR API.
D*******************************************************************
DQUSL0200 DS
Qdb Ldbm MBRL0200
D QUSMN01 1 10
Member Name
D QUSST 11 20
Source Type
D QUSCDT 21 33
Creation Date Time
D QUSLSDT 34 46
Last Source Date Tim
D QUSMD 47 96
Member Description
D QUSCCSID05 97 100i 0
Member Description C
D*
* Generic header
d GENHDR DS INZ
d USRARA 1 64
d SIZGEN 65 68i 0
d RLSLVL 69 72
d UFMTNM 73 80
d APIUSE 81 90
d DATTIM 91 103
d INFSTS 104 104
d SIZUSE 105 108i 0
d OFFINP 109 112i 0
d SIZINP 113 116i 0
d OFFHDR 117 120i 0
d SIZHDR 121 124i 0
d OFFLST 125 128i 0
d SIZLST 129 132i 0
d NUMLST 133 136i 0
d SIZENT 137 140i 0
d* Error code
d ERRRTC ds INZ
d ERRSIZ 1 4i 0 Inz(%size(ERRRTC))
d ERRAVL 5 8i 0
d ERRID 9 15
d SSTART s 10i 0
d SLEN s 10i 0
d inpFile s 10
d inpLib s 10
d qualFile s 20
d i s 10i 0
d return s 60 dim(10)
c *entry plist
c parm inpFile
c parm inpLib
c parm return
c* Name of space to hold list
c MOVEL(P) 'QUSLMBR ' QUSSPACE00
c MOVEL(P) 'QTEMP' QUSULIB00
c* Create user space to hold list
c CALL 'QUSCRTUS'
c PARM SPC
c PARM *BLANKS SPCATR 10
c PARM 100000 SPCSZE 10 0
c PARM x'00' SPCINT 1
c PARM '*ALL ' SPCAUR 10
c PARM *BLANKS SPCTXT 50
c PARM '*YES ' SPCRPL 10
c PARM ERRRTC
c* Check for errors
c If ErrID<>*Blanks
c Dump
c Goto EndofPgm
c Endif
c* Set up parms for spooled file list API
c eval QUSFN03 = 'MBRL0200'
c eval qualFile = inpFile + inpLib
c eval QUSMN = '*ALL'
c eval QUSRRIDE00 = '0'
c* Put the list into the space
c CALL 'QUSLMBR'
c PARM SPC
c PARM QUSFN03
c PARM QualFile
c PARM QUSMN
c PARM QUSRRIDE00
c PARM ERRRTC
c* Check for errors
c If ErrID<>*Blanks
c Dump
c Goto EndofPgm
c Endif
c* Determine how many entries,
c* where they begin
c* by examining the generic header
c*
c Z-ADD 1 SSTART
c Eval SLEN=%size(GENHDR)
c*
c CALL 'QUSRTVUS'
c PARM SPC
c PARM SSTART
c PARM SLEN
c PARM GENHDR
c PARM ERRRTC
c* Check for errors
c If ErrID<>*Blanks
c Dump
c Goto EndofPgm
c Endif
* Did the list fit in the space? (list complete)
c if INFSTS <> 'C'
c 'Not complete'Dump
c Goto EndofPgm
c endif
c* Working offset will be changed in the loop, but for the start, point
to the list and
c* retrieve "list entry size" bytes
c OFFLST ADD 1 SSTART
c eval slen = SIZENT
* Did the API return more data than my structure can hold?
* maybe the API returns more information in this release...
c if SIZENT > %size(QUSL0200)
c 'API struc' Dump
c endif
c* Extract list from user space 1 at a time
c DO NUMLST i
c CALL 'QUSRTVUS'
c PARM SPC
c PARM SSTART
c PARM SLEN
c PARM QUSL0200
c PARM ERRRTC
c* Check for errors
c If ErrID<>*Blanks
c Dump
c Goto EndofPgm
c Endif
* Load as far as the array and no farther
c if i <= %elem(return)
c movel QUSMN01 return(i)
c move QUSMD return(i)
c else
c leave
c endif
c* Next entry
c ADD SIZENT SSTART
c ENDDO
c EndofPgm Tag
c Eval *InLR=*On
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
