2003-06-11 如何於程式執行時知道 Savf File 的內容(API QSRLSAVF) ?
有時候系統管理員需要控管哪些程式，檔案或程式原始檔成員可以 Restore 到系統中，
所以需要作確認，系統中提供 DSPSAVF 指令可以顯示 SAVF 內容，但無法於程式中直接
檢核，所以我利用 API QSRLSAVF 來達成這個目的，此範例僅顯示 SAVF 內容，並未提
供自動 Restore 物件功能，若有需要你可以於程式中自行建立 RSTOBJ 指令字串於程式
中，並加入所選取的物件字串，再執行整個 RSTOBJ 指令即可。
File : QDDSSRC
Member: RSTOBJD
Type : DSPF
Usage : CRTDSPF RSTOBJD
*===============================================================
*
* To compile:
*
* CRTDSPF FILE(XXX/RSTOBJD) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CA03
A CA12
A*
A R SFL1 SFL
A*
A SELECT 1 B 6 2
A OBJNAM 10 O 6 4
A OBJTYP 10 O 6 15
A OBJATR 10 O 6 26
A MBRNAM 10 O 6 37
A*
A*
A R SF1CTL SFLCTL(SFL1)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A SFLCSRRRN(&CSRRRN1)
A RRN1 4S 0H SFLRCDNBR
A CSRRRN1 5S 0H
A 1 2'RSTOBJR '
A 1 28'DISPLAY SAVF FILE CONTENTS'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 29'API QSRLSAVF SAMPLE'
A COLOR(WHT)
A 2 71TIME
A 4 1'INPUT X TO SELECT'
A 3 2'LIBRARY SAVED:'
A SAVLIB 10 O 3 17
A 3 29'SAVE COMMAND:'
A SAVCMD 10 O 3 43
A 3 54'RELEASE:'
A SAVRLS 6 O 3 63
A 4 54'SAVED DATE:'
A SAVDAT 8 O 4 66
A 5 4'OBJECT'
A COLOR(WHT)
A 5 15'OBJ TYPE'
A COLOR(WHT)
A 5 26'OBJ ATTR'
A COLOR(WHT)
A 5 37'MEMBER'
A COLOR(WHT)
A*
A R SFL3 SFL
A OBJNAM 10 O 6 4
A OBJTYP 10 O 6 15
A MBRNAM 10 O 6 26
*
A R SF3CTL SFLCTL(SFL3)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN3 4S 0H
A 1 2'TFROBJR '
A 1 28'DISPLAY SAVF FILE CONTENTS'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 29'API QSRLSAVF SAMPLE'
A 2 71TIME
A 3 1'PRESS ENTER TO CONFIRM'
A 4 2'LIBRARY SAVED:'
A SAVLIB 10 O 4 17
A 4 29'SAVE COMMAND:'
A SAVCMD 10 O 4 43
A 5 4'OBJECT'
A COLOR(WHT)
A 5 15'OBJ TYPE'
A COLOR(WHT)
A 5 26'MEMBER'
A COLOR(WHT)
A R FKEY1
A*
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F12=Cancel'
A COLOR(BLU)
File : QDRPGLESRC
Member: RSTOBJR
Type : RPGLE
Usage : CRTBNDRPG RSTOBJR
*===============================================================
* To compile:
*
* CRTRPGPGM PGM(XXX/WRKSAVOBJR) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DftActGrp(*NO) ActGrp(*CALLER)
FRSTOBJD cf e workstn
F sfile(sfl1:rrn1)
F sfile(sfl3:rrn3)
F infds(info)
* Information data structure to hold attention indicator (AID) byte.
* AID byte contains a code identifying the function
* key used to return control to the program from the display file.
* For more information see the DATA MANAGEMENT GUIDE.
Dinfo ds
D cfkey 369 369
* Constants to compare to AID - F3, F12, F6, and ENTER keys.
* Other values documented in DATA MANAGEMENT GUIDE.
Dexit C const(X'33')
Dcancel C const(X'3C')
Dadd C const(X'36')
Denter C const(X'F1')
D savrrn S 5S 0
D confirm S 1
D GENDS DS
D OFFLST 125 128B 0
D NUMLST 133 136B 0
D SIZENT 137 140B 0
D LIBINF DS 72
D SAVLIB 1 10
D SAVCMD 11 20
D SAVCM6 11 16
* The time at which the objects were saved in system time-stamp format
D SAVDAT 21 28
D SAVRLS 55 60
D OBJINF DS 204
D OBJNAM 1 10
D OBJTYP 21 30
D OBJATR 31 40
D OBJTXT 155 194
D MBRINF DS 40
D FILNAM 1 10
D FILLIB 11 20
D MBRNAM 21 30
D DS INZ
D USRSPC 1 20 INZ('DSPSAVF QTEMP ')
D STRPOS 41 44B 0
D STRLEN 45 48B 0
D LENSPC 49 52B 0
D STKCNT 53 56B 0
D APPSCP 57 60B 0
D EXTPRM 61 64B 0
D ERRCOD 65 68B 0
D FKEY 69 72B 0
D VARLEN 73 76B 0
* Parameters for Create User Space used
D ExtendAttr S 10 INZ('USRSPC ')
D InitialSiz S 10I 0 INZ(1024)
D InitialVal S 1 INZ(X'00')
D PublicAut S 10 INZ('*ALL ')
D ReplaceSpc S 10 INZ('*YES ')
D TextDescrp S 50 INZ('User space for SAVF ListAPI')
*
D DTS s 16a
D LongJul s 17a
D YYMD s 17a
**-- Convert date & time: -------------------------------------------
D CvtDtf Pr ExtPgm( 'QWCCVTDT' )
D CdInpFmt 10a Const
D CdInpVar 17a Const Options( *VarSize )
D CdOutFmt 10a Const Options( *VarSize )
D CdOutVar 17a Options( *VarSize )
D CdError 32767a Options( *VarSize )
**
**********************************************************************************************
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 10I 0 INZ( %Size( Error_Code ))
D BytesAvail 10I 0 INZ(0)
D Except_ID 7
D Reserved 1
D Exception 256
*===============================================================
C *ENTRY PLIST
C PARM SAVF 20
C PARM OBJFLT 10
C PARM TYPFLT 10
*
* Create User Space
C EXSR CRTUSRSPC
*
* Load user space with library level information
C MOVEL 'SAVF0100' FMTNAM 8
C EXSR LODSPC
*
* Get library level information from user space
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM LIBINF
*
* Perform error checking selection
C SELECT
*
* If no data issue message
C SAVLIB WHENEQ *BLANKS
C MOVEL '*EMPTY' ERRDTA 10
*
* If unsupported save command issue message
C SAVCM6 WHENNE 'SAVLIB'
C SAVCM6 ANDNE 'SAVOBJ'
C SAVCM6 ANDNE 'SAVCHG'
C MOVEL SAVCMD ERRDTA
*
* Otherwise process data
C OTHER
* Convert Save Date & time to *MDY format
C CallP CvtDtf( '*DTS'
C : SAVDAT
C : '*MDY'
C : DTS
C : Error_Code
C )
C EVAL SAVDAT = %subst(DTS:2:6)
C EXSR PROCES
C ENDSL
*
C MOVE *ON *INLR
*===============================================================
C CRTUSRSPC BEGSR
* Create a user space to hold savf list entries
C CALL 'QUSCRTUS'
C PARM USRSPC
C PARM ExtendAttr
C PARM InitialSiz
C PARM InitialVal
C PARM PublicAut
C PARM TextDescrp
C PARM ReplaceSpc
C PARM Error_Code
C ENDSR
*===============================================================
C LODSPC BEGSR
*
* Call the list save file API
C CALL 'QSRLSAVF'
C PARM USRSPC
C PARM FMTNAM
C PARM SAVF
C PARM OBJFLT
C PARM TYPFLT
C PARM *BLANKS CNTHND 36
C PARM 0 ERRCOD
*
* Retrieve the generic header
C Z-ADD 1 STRPOS
C Z-ADD 140 STRLEN
*
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM GENDS
*
* Calculate starting position and length
C OFFLST ADD 1 STRPOS
C Z-ADD SIZENT STRLEN
*
C ENDSR
*===============================================================
C PROCES BEGSR
*
* Load user space with object level information
C MOVEL 'SAVF0200' FMTNAM
C EXSR LODSPC
*
C ExSr clrsfl
* Get object level information from user space
C DO NUMLST
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM OBJINF
*
* Exclude library objects from list
C OBJTYP IFNE '*LIB'
C move ' ' select
C MOVE *Blanks MBRNAM
*
* Add a OBJINF list entry to the screen
C Eval rrn1 = rrn1 + 1
C Write sfl1
C ENDIF
*
* Calculate position of next entry
C ADD SIZENT STRPOS
C ENDDO
* Load user space with member level information
C MOVEL 'SAVF0300' FMTNAM
C EXSR LODSPC
*
* Get object level information from user space
C DO NUMLST
C CALL 'QUSRTVUS'
C PARM USRSPC
C PARM STRPOS
C PARM STRLEN
C PARM MBRINF
*
C move ' ' select
C MOVEL FILNAM OBJNAM
C MOVE *Blanks OBJTYP
*
* Add a list entry to the screen
C Eval rrn1 = rrn1 + 1
C Write sfl1
C* ENDIF
*
* Calculate position of next entry
C ADD SIZENT STRPOS
C ENDDO
*
* Display Screen
C Eval savrrn = rrn1
C Eval rrn1 = 1
*
C Eval *In90 = *on
C If rrn1 = 0
C Eval *in32 = *on
C EndIf
* Simply redisplay subfile until user hits Exit or Cancel
C DoU (cfkey = exit) or (cfkey = cancel)
C Write fkey1
C ExFmt sf1ctl
C Exsr procesSlt
C If confirm = '1'
C leave
C EndIf
C EndDo
C
C ENDSR
*===============================================================
C procesSlt BEGSR
*
* clear sfl3
C Eval *in31 = *on
C Eval rrn3 = 0
c Write sf3ctl
C Eval *in31 = *off
*
C z-add 1 idx 5 0
C Eval confirm = '0'
C DoW idx <= savrrn
C idx Chain sfl1
C If select = 'X'
C Z-add idx strrrn 4 0
C Eval rrn3 = rrn3 + 1
C Write sfl3
C Eval select = ' '
C update sfl1
C EndIf
C Eval idx = idx + 1
C EndDo
C
C If rrn3 > 0
C z-add rrn3 savrrn3 4 0
C Write fkey1
C ExFmt sf3ctl
C If (cfkey <> exit) and (cfkey <> cancel)
C Eval confirm = '1'
C Eval idx = 1
C DoW idx <= savrrn3
C idx Chain sfl3
* write your process select obj or member step under here.
C Eval idx = idx + 1
C EndDo
C EndIf
C If cfkey = cancel
C Eval cfkey = ' '
C EndIf
C EndIf
C If strrrn > 0
C Z-add strrrn rrn1
C Else
C Z-add csrrrn1 rrn1
C EndIf
*
C ENDSR
*********************************************************************
C ClrSfl BegSr
* Clear the subfile by activating SFLCLR and writing the subfile control
* format. Reset the subfile relative record number.
C Eval *in31 = *on
C Eval rrn1 = 0
C Write sf1ctl
C Eval *in31 = *off
*
C EndSr
星期一, 11月 06, 2023
2003-06-11 如何於程式執行時知道 Savf File 的內容(API QSRLSAVF) ?
2003-06-10 如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
有時候由於檔案或原始檔某些成員需要傳至另一個 AS/400(iSeries) 系統，
所以需要使用 SAVOBJ 的方式儲存，但是又須麻煩的一個一個輸入指定物件或原
始檔成員，所以我寫一個程式針對同一個 Library 中的物件或原始檔中
成員讓使用者選取，並將所選儲存至同一 Library SAVF 中，然後你可以
使用此 SAVF 利用 FTP 或 SNDNETF 或 SAVRSTOBJ 傳輸至另一系統中。
此程式中使用 Source-Library -> 欲儲存的 Library
Targrt-Library -> 欲 Restored 到目的地 Library，目前未使用，若需要將傳輸及自動 Restored 時，你可以利用此參數。
二個參數，並將選取的物件存至 Source-Library 中以同 Source-Library 為名的 SAVF。
File : QCLSRC
Member: TFROBJC
Type : CLP
Usage : CRTCLPGM TFROBJC
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CURRCD) TYPE(*DEC) LEN(10 0)
DCLF QAFDBASI
/* OUTPUT OBJ DESCRIPTION TO OUTFILE */
DSPOBJD OBJ(&SRCLIB/*ALL) OBJTYPE(*ALL) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPOBJ)
/* OUTPUT FILE DESCRIPTION TO OUTFILE */
DSPFD FILE(&SRCLIB/*ALL) TYPE(*BASATR) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD)
OVRDBF FILE(QAFDBASI) TOFILE(QTEMP/DSPFD)
DLTF DSPMBRLIST
MONMSG CPF0000
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&ATDTAT = 'S') +
DSPFD FILE(&ATLIB/&ATFILE) TYPE(*MBRLIST) +
OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPMBRLIST) OUTMBR(*FIRST *ADD)
GOTO NEXT
MBRLISTEND:
DLTF QTEMP/SAVMBRLIST
MONMSG CPF0000
/* CREATE TEMP FILE TO SAVE SAVED MEMBER NAME AND OBJ */
CRTDUPOBJ OBJ(QAFDMBRL) FROMLIB(*LIBL) OBJTYPE(*FILE) +
TOLIB(QTEMP) NEWOBJ(SAVMBRLIST)
ADDPFM FILE(QTEMP/SAVMBRLIST) MBR(SAVMBRLIST)
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
ENDPGM
File : QCLSRC
Member: TFROBJC1
Type : CLP
Usage : CRTCLPGM TFROBJC1
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CMDSTR) TYPE(*CHAR) LEN(3000) +
VALUE('SAVOBJ OBJ(')
DCL VAR(&MLFILES) TYPE(*CHAR) LEN(10) +
VALUE(' ')
DCL VAR(&SAVFILE) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJS) TYPE(*CHAR) LEN(7) +
VALUE('SAVOBJ ')
DCL VAR(&OBJS) TYPE(*CHAR) LEN(4) VALUE('OBJ(')
DCL VAR(&OBJSS) TYPE(*CHAR) LEN(150)
DCL VAR(&LIBS) TYPE(*CHAR) LEN(4) VALUE('LIB(')
DCL VAR(&DEVS) TYPE(*CHAR) LEN(11) +
VALUE('DEV(*SAVF) ')
DCL VAR(&OBJTYPS) TYPE(*CHAR) LEN(14) +
VALUE('OBJTYPE(*ALL) ')
DCL VAR(&SAVFS) TYPE(*CHAR) LEN(15) VALUE('SAVF(')
DCL VAR(&FILEMBRS) TYPE(*CHAR) LEN(15) +
VALUE('FILEMBR(')
DCL VAR(&LEFT) TYPE(*CHAR) LEN(1) VALUE('(')
DCL VAR(&RIGHT) TYPE(*CHAR) LEN(2) VALUE(') ')
DCL VAR(&SLASH) TYPE(*CHAR) LEN(1) VALUE('/')
DCL VAR(&MBRS) TYPE(*CHAR) LEN(300)
DCL VAR(&WITHMBRS) TYPE(*CHAR) LEN(1)
DCLF QAFDMBRL
CHGVAR &SAVFILE &SRCLIB
DLTF &SRCLIB/&SAVFILE
MONMSG CPF0000
CRTSAVF FILE(&SRCLIB/&SAVFILE)
OVRDBF FILE(QAFDMBRL) TOFILE(QTEMP/SAVMBRLIST)
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&MLFILES *NE &MLFILE) DO
/* SAVOBJ +
OBJ(FILE) LIB(SRCLIB) DEV(*SAVF) +
OBJTYPE(*FILE) SAVF(SRCLIB/SAVF) +
FILEMBR((FILE1 (MBR1 MBR2)) (FILE2 (MBR1 +
MBR2))) */
IF (&MLFILES *NE ' ' *AND +
&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT)
ENDDO
CHGVAR &MLFILES &MLFILE
CHGVAR &OBJSS (&OBJSS *BCAT &MLFILE)
IF (&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *BCAT &LEFT *CAT &MLFILE *BCAT &LEFT)
CHGVAR &WITHMBRS '1'
ENDDO
ENDDO
IF (&MLNAME *NE ' ') +
CHGVAR &MBRS +
(&MBRS *BCAT &MLNAME)
GOTO NEXT
MBRLISTEND:
DLTOVR FILE(*ALL)
CHGVAR &CMDSTR +
(&SAVOBJS *CAT +
&OBJS *TCAT &OBJSS *TCAT &RIGHT *CAT +
&LIBS *TCAT &MLLIB *TCAT &RIGHT *CAT +
&DEVS *CAT +
&OBJTYPS *CAT +
&SAVFS *TCAT &SRCLIB *TCAT &SLASH *CAT +
&SAVFILE *TCAT &RIGHT)
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT *TCAT &RIGHT)
IF (&WITHMBRS = '1') DO
CHGVAR &CMDSTR +
(&CMDSTR *BCAT &FILEMBRS *CAT &MBRS)
ENDDO
CALL QCMDEXC (&CMDSTR 3000)
SNDPGMMSG MSG('SAVF' *BCAT &SAVFILE *BCAT 'created in' +
*BCAT &SRCLIB *TCAT '.') TOPGMQ(*PRV +
(TFROBJC))
ENDPGM
File : QDDSSRC
Member: TFROBJD
Type : DSPF
Usage : CRTDSPF TFROBJD
*===============================================================
*
* To compile:
*
* CRTDSPF FILE(XXX/TFROBJD) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CA03
A CA12
A*
A R SFL1 SFL
A*
A SELECT 1 B 6 2
A MLFILE 10 O 6 4
A MLNAME 10 O 6 15
A MLCDAT 6 O 6 26
A MLCHGD 6 O 6 33
A ODOBNM 10 O 6 40
A ODOBTP 8 O 6 51
A ODOBOW 10 O 6 60
A ODLDAT 6 O 6 71
A ODCDAT 6 H
A*
A*
A R SF1CTL SFLCTL(SFL1)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A SFLCSRRRN(&CSRRRN1)
A RRN1 4S 0H SFLRCDNBR
A CSRRRN1 5S 0H
A 1 2'TFROBJR '
A 1 28'Your Company name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 29'Select Object or SRC Member to save'
A COLOR(WHT)
A 2 71TIME
A 3 1'X'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'FILE'
A COLOR(WHT)
A 5 15'MEMBER'
A COLOR(WHT)
A 4 26'CRT'
A COLOR(WHT)
A 5 26'DATE'
A COLOR(WHT)
A 3 33'LAST'
A COLOR(WHT)
A 4 33'CHANGE'
A COLOR(WHT)
A 5 33'DATE'
A COLOR(WHT)
A 5 40'OBJECT'
A COLOR(WHT)
A 5 51'TYPE'
A COLOR(WHT)
A 5 60'OWNER'
A COLOR(WHT)
A 3 71'LAST'
A COLOR(WHT)
A 4 71'CHANGED'
A COLOR(WHT)
A 5 71'DATE'
A COLOR(WHT)
A*
A R SFL2 SFL
A*
A SELECT 1 B 6 2
A ODLBNM 10 O 6 4
A ODOBNM 10 O 6 15
A ODOBTP 8 O 6 26
A ODOBAT 10 O 6 37
A ODCDAT 6 O 6 48
A ODLDAT 6 O 6 55
A ODOBOW 10 O 6 62
A R SF2CTL SFLCTL(SFL2)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN2 4S 0H
A 1 2'TFROBJR '
A 1 28'Your Company name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34''
A COLOR(WHT)
A 2 71TIME
A 3 1'X'
A 5 4'LIBRARY'
A COLOR(WHT)
A 5 15'OBJECT '
A COLOR(WHT)
A 5 26'OBJTYPE'
A COLOR(WHT)
A 5 37'ATTR'
A COLOR(WHT)
A 4 48'CRT'
A COLOR(WHT)
A 5 48'DATE'
A COLOR(WHT)
A 4 48'CHG'
A COLOR(WHT)
A 5 55'DATE'
A COLOR(WHT)
A 5 62'OWNER'
A COLOR(WHT)
A R SFL3 SFL
A SAVOBJ 10 O 6 4
A SAVMBR 10 O 6 15
A MLCDAT 6 O 6 27
A MLCHGD 6 O 6 34
A ODOBOW 10 O 6 41
*
A R SF3CTL SFLCTL(SFL3)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN3 4S 0H
A 1 2'TFROBJR '
A 1 28'Your Company Name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34'Confirm Selection'
A 2 71TIME
A 3 1'Please press Enter to confirm'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'OBJECT MEMBER'
A COLOR(WHT)
A 4 27'CRT'
A COLOR(WHT)
A 5 27'DATE'
A COLOR(WHT)
A 3 34'LAST'
A COLOR(WHT)
A 4 34'CHG'
A COLOR(WHT)
A 5 34'DATE'
A COLOR(WHT)
A 5 41'OWNER'
A COLOR(WHT)
A R FKEY1
A*
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F12=Cancel'
A COLOR(BLU)
File : QRPGLESRC
Member: TFROBJR
Type : RPGLE
Usage : CRTBNDRPG TFROBJR
*===============================================================
*
* To compile:
*
* CRTBNDRPG PGM(XXX/TFROBJR) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DftActGrp(*NO) ActGrp(*CALLER)
FTFROBJD cf e workstn
F sfile(sfl1:rrn1)
F sfile(sfl2:rrn2)
F sfile(sfl3:rrn3)
F infds(info)
FDSPOBJ if e disk
FDSPMBRLISTif e disk
FSAVMBRLISTO e disk rename(QWHFDML : SAVMBRR)
* Information data structure to hold attention indicator (AID) byte.
* AID byte contains a code identifying the function
* key used to return control to the program from the display file.
* For more information see the DATA MANAGEMENT GUIDE.
Dinfo ds
D cfkey 369 369
* Constants to compare to AID - F3, F12, F6, and ENTER keys.
* Other values documented in DATA MANAGEMENT GUIDE.
Dexit C const(X'33')
Dcancel C const(X'3C')
Dadd C const(X'36')
Denter C const(X'F1')
* Input parameter: Source Type or not
D savrrn S 5S 0
D confirm S 1
* Clear the subfile, then call the recursive NextLevel procedure
C ExSr clrsfl
C Exsr loadsfl
C Eval *In90 = *on
C If rrn1 = 0
C Eval *in32 = *on
C EndIf
C* Eval csrrrn1 = 1
* Simply redisplay subfile until user hits Exit or Cancel
C DoU (cfkey = exit) or (cfkey = cancel)
C Write fkey1
C ExFmt sf1ctl
C Exsr prcsfl
C If confirm = '1'
C leave
C EndIf
C EndDo
* Close files and terminate.
C Eval *inlr = *on
*********************************************************************
C ClrSfl BegSr
* Clear the subfile by activating SFLCLR and writing the subfile control
* format. Reset the subfile relative record number.
C Eval *in31 = *on
C Eval rrn1 = 0
C Write sf1ctl
C Eval *in31 = *off
*
C EndSr
*********************************************************************
C Loadsfl Begsr
* Loop until EOF is encountered.
* read DSPMBRLIST
C Read DSPMBRLIST
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPMBRLIST
C EndDo
C Eval SAVLIB = MLLIB
* read DSPOBJ
C Reset SFL1
C Read DSPOBJ
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPOBJ
C EndDo
C Eval savrrn = rrn1
C Eval rrn1 = 1
C EndSr
*********************************************************************
C PrcSfl Begsr
* clear sfl3
C Eval *in31 = *on
C Eval rrn3 = 0
c Write sf3ctl
C Eval *in31 = *off
C z-add 1 idx 5 0
C Eval confirm = '0'
C DoW idx < savrrn
C idx Chain sfl1
C If select = 'X'
C If MLFILE <> *blanks
C Eval SavLIB = SAVLIB
C Eval SavOBJ = MLFILE
C Eval SavMBR = MLNAME
C Else
C Eval SavLIB = SAVLIB
C Eval SavOBJ = ODOBNM
C Eval SavMBR = *BLANKS
C Eval MLCDAT = ODCDAT
C Eval MLCHGD = ODLDAT
C EndIf
C Z-add idx strrrn 4 0
C Eval rrn3 = rrn3 + 1
C Write sfl3
C Eval select = ' '
C update sfl1
C EndIf
C Eval idx = idx + 1
C EndDo
C
C If rrn3 > 0
C z-add rrn3 savrrn3 4 0
C Write fkey1
C ExFmt sf3ctl
C If (cfkey <> exit) and (cfkey <> cancel)
C Eval confirm = '1'
C Eval idx = 1
C Reset SAVMBRR
C DoW idx <= savrrn3
C idx Chain sfl3
C Eval MLLIB = SAVLIB
C Eval MLFILE= SAVOBJ
C EVAL MLNAME= SAVMBR
C EVAL MLSEU2= ODOBOW
C Write SAVMBRR
C Eval idx = idx + 1
C EndDo
C EndIf
C EndIf
C If strrrn > 0
C Z-add strrrn rrn1
C Else
C Z-add csrrrn1 rrn1
C EndIf
C EndSr
由於此程式利用 QTEMP 暫存檔處理，所以安裝程序須照下列方式，否則無法編譯完成：
1. 將 TFROBJC 程式後段修改如下：
/* SELECT OBJECT TO SAVED */
/* CALL TFROBJR */
/* CONSTRUCT SAVRST COMMAND */
/* RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD) */
/* IF (&CURRCD > 0) + */
/* CALL TFROBJC1 (&SRCLIB &TOLIB) */
儲存，執行編譯 CRTCLPGM TFROBJC完成後，
執行 CALL TFROBJC ('QGPL' 'QGPL' '*ALL')產生暫存檔 QTEMP/SAVMBRLIST 供 TFROBJR 使用。
2. CRTDSPF TFROBJD
3. CRTBNDRPG TFROBJR
4. CRTCLPGM TFROBJC1
5. 回復 TFROBJC 後段為：
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
儲存，執行編譯 CRTCLPGM TFROBJC 完成安裝。
執行程式語法：
CALL TFROBJC ('source-library' 'target-library')
訂閱：
文章 (Atom)