|
midrange.com
Here you go Phil, copied to the list for the archives.
command: RGZLIB LIBR(library) DELREC(10) DELPCT(1) LIST(Y)
file member is reorged if deleted records exceeds DELREC parm
file member is reorged if percentage of deleted to active exceeds DELPCT
parm
prints a list of all physical file members in library - and the status of
reorg attempt if LIST parm = "Y"
allocates file *excl, waits 10 secs - if successful, reorgs file.
Does not trap for any other errors during file reorg - it only reports that
it was unsuccessful.
reorgs KEYFILE(*FILE) if file is keyed.
Compile everything with default values
source file(member): QDDSSRC(RGZLIBPR) SRCTYPE(PRTF)
REF(QAFDMBR )
R PAGHDG
SKIPB(002)
1'Report:'
9'RGZLIBR'
38'Periodic Data File
Reorganization'
110'Run Date:'
120DATE
EDTCDE(Y)
SPACEA(001)
1'Page#:'
9PAGNBR EDTCDE(Z)
110'Run Time:'
120TIME
SPACEA(002)
1'Library:'
$LIB 10A +2
+6'Record Threshold:'
$DREC 9S 0 +1EDTCDE(Z)
+6'Percentage Threshold:'
$DPCT 3S 0 +1EDTCDE(Z)
SPACEA(002)
30'Active'
45'Deleted'
54'Deleted'
SPACEA(001)
1'File Name'
12'Member Name'
30'Records'
45'Records'
54'Percent'
63'Reorganization Status'
SPACEA(001)
1'---------'
12'-----------'
30'-------'
45'-------'
54'-------'
63'---------------------'
SPACEA(001)
R DTLLIN
MBFILE R O 1
MBNAME R O 12
MBNRCD R O 24EDTCDE(J)
MBNDTR R O 39EDTCDE(J)
$PCT 3S 0O 56EDTCDE(J)
$MSG 60 O 63
SPACEA(001)
--------End of source member----------
source file(member): QRPGLESRC(RGZLIBR) SRCTYPE(RPGLE)
* RGZLIBR - Read DSPFD outfile of file members in library,
* and reorg them based the number of deleted records
* or a percentage of total records deleted to active.
* Richard Baird
FQAFDMBR IP E DISK
FRGZLIBPR O E PRINTER infds(PrtFeedBack)
* printer feedback (overflow)
DPrtFeedBack DS
D $CurrLine 367 368I 0
D $CurrPage 369 372I 0
* Variable to build command for QCMDEXC
D@Cmd S 275A
* Procedure interface for QCMDEXC
D qCmdExc PR EXTPGM('QCMDEXC')
D Cmd 275A OPTIONS(*VARSIZE) CONST
D CmdLen 15P 5 CONST
* input parameters
D@Lib S 10A
D@DRec S 9P 0
D@DPct S 3P 0
D@List S 1A
D$overflow S 2s 0 INZ(58)
C *Entry plist
C parm @Lib
C parm @DRec
C parm @DPct
C parm @List
* if physical file and *dta.
C if MBFTYP = 'P' and
C MBDTAT = 'D'
* calculate percentage of deleted records.
C select
C when MBNDTR > 0 and MBNRCD = 0
C eval $pct = 99
C when MBNDTR = 0 or MBNRCD = 0
C eval $pct = 0
C when ((MBNDTR / MBNRCD) * 100) > 999
C eval $pct = 999
C other
C eval $pct = ((MBNDTR / MBNRCD) * 100)
C endsl
* decide if file has reached threashold to reorganize.
C select
* file has no active records but has some deleted records.
C when MBNRCD = 0 and
C MBNDTR > 0
C exsr $RgzPfm
* file has more deleted records than threashold
C when @DRec > 0 and
C MBNDTR >= @DRec
C exsr $RgzPfm
* file has a percentage of deleted records greater than threashold
C when @DPct > 0 and
C MBNRCD > 0 and
C $pct >= @DPct
C exsr $RgzPfm
C when @List = 'Y'
C exsr $WrtNoReorg
C endsl
C end
*--------------------------------------------------------------------*
* $RgzPfm - reorganize physical file member.
*--------------------------------------------------------------------*
C $RgzPfm begsr
* attempt to allocate object
C eval @Cmd = 'ALCOBJ OBJ((' +
C %trim(MBLIB ) + '/' +
C %trim(MBFILE ) +
C ' *FILE *EXCL ' +
C %trim(MBNAME ) + ')) +
C WAIT(10)'
C callp(e) QCmdExc(@Cmd : %size(@Cmd))
* attempt failed. write error to report and skip file.
C if %error
C exsr $WrtError1
C else
* build command to reorganize member.
C eval @Cmd = 'RGZPFM FILE(' +
C %trim(MBLIB ) + '/' +
C %trim(MBFILE ) + ') MBR(' +
C %trim(MBNAME ) + ')'
* if file is keyed, reorg by primary key.
C if MBACCP = 'K'
C eval @Cmd = %trim(@Cmd) +
C ' KEYFILE(*FILE)'
C end
* execute reorg command
C callp(e) QCmdExc(@Cmd : %size(@Cmd))
* reorg unsuccessful or successful - write to report.
C if %error
C exsr $WrtError2
C else
C exsr $WrtSuccess
C end
* regardless of reorg success - de-allocate object.
C eval @Cmd = 'DLCOBJ OBJ((' +
C %trim(MBLIB ) + '/' +
C %trim(MBFILE ) +
C ' *FILE *EXCL ' +
C %trim(MBNAME ) + '))'
C callp(e) QCmdExc(@Cmd : %size(@Cmd))
C end
C endsr
*--------------------------------------------------------------------*
* $WrtError1 - allocate object failed.
*--------------------------------------------------------------------*
C $WrtError1 begsr
C eval $Msg = 'Could not allocate file. +
C File could be in use or +
C authority problem.'
C write DTLLIN
C exsr $ovrflw
C endsr
*--------------------------------------------------------------------*
* $WrtError2 - reorg of phys file member failed.
*--------------------------------------------------------------------*
C $WrtError2 begsr
C eval $Msg = 'Could not reorg file. +
C Possible authority problem.'
C write DTLLIN
C exsr $ovrflw
C endsr
*--------------------------------------------------------------------*
* $WrtSuccess - reorg of phys file member was successful.
*--------------------------------------------------------------------*
C $WrtSuccess begsr
C eval $Msg = 'File was reorganized +
C successfully.'
C write DTLLIN
C exsr $ovrflw
C endsr
*--------------------------------------------------------------------*
* $WrtNoReorg - if requested, list even lines that weren't selected.
*--------------------------------------------------------------------*
C $WrtNoReorg begsr
C eval $Msg = 'File reorg was not needed +
C for this file.'
C write DTLLIN
C exsr $ovrflw
C endsr
*--------------------------------------------------------------------*
* $ovrflw - check for printer overflow
*--------------------------------------------------------------------*
C $ovrflw begsr
C if $CurrLine > $overflow
C write PAGHDG
C end
C endsr
*--------------------------------------------------------------------*
* *inzsr - runs once at very beginning of program
*--------------------------------------------------------------------*
C *inzsr begsr
C eval $lib = @lib
C eval $DRec = @DRec
C eval $DPct = @DPct
C write PAGHDG
C endsr
--------End of source member----------
source file(member): QCLSRC(RGZLIBCL) SRCTYPE(CLP)
PGM PARM(&LIB &DREC &DPCT &LIST)
DCL VAR(&LIB ) TYPE(*CHAR) LEN(10)
DCL VAR(&DREC ) TYPE(*DEC) LEN(9 0)
DCL VAR(&DPCT ) TYPE(*DEC) LEN(3 0)
DCL VAR(&LIST ) TYPE(*CHAR) LEN(1)
CHKOBJ OBJ(&LIB) OBJTYPE(*LIB)
MONMSG MSGID(CPF0000) EXEC(DO)
SNDPGMMSG MSG('Library does not exist. Command +
Cancelled')
GOTO CMDLBL(EXIT)
ENDDO
DSPFD FILE(&LIB/*ALL) TYPE(*MBR) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/QAFDMBR)
OVRDBF FILE(QAFDMBR) TOFILE(QTEMP/QAFDMBR)
CALL PGM(RGZLIBR) PARM(&LIB &DREC &DPCT &LIST)
DLTOVR FILE(QAFDMBR)
DLTF FILE(QTEMP/QAFDMBR)
EXIT: ENDPGM
--------End of source member----------
source file(member): QCMDSRC(RGZLIB) SRCTYPE(CMD)
CMD PROMPT('Reorg Files in Library')
PARM KWD(LIBR) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('Library Name:')
PARM KWD(DELREC) TYPE(*DEC) LEN(9 0) +
PROMPT('Deleted Records threshold')
PARM KWD(DELPCT) TYPE(*DEC) LEN(3 0) +
PROMPT('Deleted Pct threshold')
PARM KWD(LIST) TYPE(*CHAR) LEN(1) DFT(N) +
PROMPT('List files reorged? Y/N')
--------End of source member----------
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.
