- SMTP Configuration Checklist
- Configuration of the IBM i SMTP Client to Relay Email to Office365 and Gmail
- How To Migrate SMTP on IBM i from *SDD to *SMTP/*SMTPMSF
- Configuring TLS Between IBM i and Remote Mail Router WITHOUT Authentication
- How To Configure the SMTP Client To Use SMTP Authentication with a SMTP Relay
星期一, 10月 21, 2024
IBM i SMTP
星期五, 12月 22, 2023
2023-12-22 Get top cpu usage percentage job (TOPCPUPCT)
2023-12-22 Get top cpu usage percentage job (TOPCPUPCT)
File : QRPGLESRC
Member: TOPCPUPCT
Type : RPGLE
**
** Program . . : TopCpuPct
** Description : Finds CPU Top and notifies caller
** Author . . : Vengoal Chang
** Published . : AS400 ePaper
** Date . . . : November 21, 2023
**
**
** Program summary
** ---------------
**
** Work management APIs:
** QGYOLJOB Open list of jobs Lists jobs on the system based on
** the specified selection criteria.
**
** Optionally a sort order for the
** returned jobs can be specified -
** in this case the processor unit
** time percentage in descending
** order - listing the jobs having
** the highest CPU usage first.
**
** The CPU processor time is measured
** for an interval of 10 seconds in
** this example.
**
** The QGYOLJOB API is found in the
** QGY library as are all other open
** list APIs.
**
** QWVRCSTK Retrieve Call Stack Lists the program call stack for
** the specified job or thread.
** The current invocation level is
** returned first.
**
** Message handling API:
** QMHSNDM Send message Sends a message to the specified
** non-program message queue - here
** an informational message is sent
** to the current user running this
** program.
**
** Open list APIs:
** QGYGTLE Get list entries To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** QGYCLST Close list This API closes the previously
** opened list identified by the
** request handle parameter.
** Storage allocated is freed.
**
** MI builtins:
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** Unix Type - Signal APIs:
** Sleep Suspends program processing for
** the specified number of seconds.
**
**
** Sequence of events:
** 1. The act jobs processor time limit percentage is retrieved
**
** 2. The list jobs API input parameters are initialized
**
** 3. The open list of jobs API is called to reset the job
** statistics.
**
** 4. Program is suspended for some seconds
**
** 5. The open list of jobs API is called to list the interactive
** jobs on the system returning the most CPU intensive jobs
** for the elapsed period first.
**
** 6. For each top cpu percent job a message is sent to the
** message queue.
**
** 7. The job list resources are cleaned up.
**
** 8. The program will loop 1 to 7, until manual job.
**
** Programmer's notes:
**
** As mentioned above library QGY must be in the job library list
** to succesfully run this program.
**
** To retrieve another job's call stack *JOBCTL special authority is
** required.
**
**
** Compile options:
**
** CrtRpgMod Module( TOPCPUPCT ) DbgView( *LIST )
**
** CrtPgm Pgm( TOPCPUPCT )
** Module( TOPCPUPCT )
**
** Usage sample:
** Get top first CPU% job per 60 secs with following:
** SBMJOB
** CMD(TOPCPUPCT TOPCOUNT(001) INTERVAL(00060)
** TOMSGQ(*SYSOPR))
** Job(TOPPCTPCT)
**
** Get top 5 CPU% job per 60 secs with following:
** SBMJOB
** CMD(TOPCPUPCT TOPCOUNT(005) INTERVAL(00060)
** TOMSGQ(*SYSOPR))
** Job(TOPPCTPCT)
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) DecEdit( *JobRun ) BndDir( 'QC2LE' )
H DftActGrp(*NO)
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsSts 5a Overlay( PgmSts: 11 )
D PsCurJob 10a Overlay( PgmSts: 244 )
D PsUsrPrf 10a Overlay( PgmSts: 254 )
D PsJobNbr 6a Overlay( PgmSts: 264 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
**-- API parameters: ---------------------------------------------------**
D JlRtnRcdNbr s 10i 0 Inz( 1 )
D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld ))
D JlKeyFld s 10i 0 Dim( 3 )
**-- Job information:
D JlJobInf Ds 512
D JbJobId 26a
D JbJobUsd 10a Overlay( JbJobId: 1 )
D JbUsrUsd 10a Overlay( JbJobId: *Next )
D JbNbrUsd 6a Overlay( JbJobId: *Next )
D JbActSts 4a
D JbJobTyp 1a
D JbJobSubTyp 1a
D JbDtaLen 10i 0
D 4a
D JbDta 256a
**-- Key information:
D JlKeyInf Ds
D KiFldNbrRtn 10i 0
D KiKeyInf 20a Dim( %Elem( JlKeyFld ))
D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 )
D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 )
D KiDtaTyp 1a Overlay( KiKeyInf : 9 )
D 3a Overlay( KiKeyInf : 10 )
D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 )
D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 )
**-- Sort information:
D JlSrtInf Ds
D SiNbrKeys 10i 0 Inz( 1 )
D SiSrtInf 12a Dim( 10 )
D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 )
D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 )
D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 )
D SiSrtOrd 1a Overlay( SiSrtInf : 11 )
D SiRsv 1a Overlay( SiSrtInf : 12 )
**-- List information:
D JlLstInf Ds
D LiRcdNbrTot 10i 0
D LiRcdNbrRtn 10i 0
D LiHandle 4a
D LiRcdLen 10i 0
D LiInfSts 1a
D LiDts 13a
D LiLstSts 1a
D 1a
D LiInfLen 10i 0
D LiRcd1 10i 0
D 40a
**-- Selection information:
D JlSltInf Ds
D SiJobNam 10a Inz( '*ALL' )
D SiUsrNam 10a Inz( '*ALL' )
D SiJobNbr 6a Inz( '*ALL' )
D SiJobTyp 1a Inz( '*' )
D 1a
D SiOfsPriSts 10i 0 Inz( 60 )
D SiNbrPriSts 10i 0 Inz( 0 )
D SiOfsActSts 10i 0 Inz( 70 )
D SiNbrActSts 10i 0 Inz( 0 )
D SiOfsJbqSts 10i 0 Inz( 78 )
D SiNbrJbqSts 10i 0 Inz( 0 )
D SiOfsJbqNam 10i 0 Inz( 88 )
D SiNbrJbqNam 10i 0 Inz( 0 )
**
D SiPriSts 10a Dim( 1 )
D SiActSts 4a Dim( 2 )
D SiJbqSts 10a Dim( 1 )
D SiJbqNam 20a Dim( 1 )
**-- Job information key fields:
D JbKeyDta Ds
D JbPrcUniTim 20u 0
D JbPrcUniPct 9b 1
D JbPrcUniTimE 20u 0
**-- General return data:
D JlGenDta Ds
D GdBytRtn 10i 0
D GdBytAvl 10i 0
D GdElpTim 20u 0
D 16a
**-- MatRmd parameters: ------------------------------------------------**
D MatRscMgDt Ds
D RdBytPrv 10i 0 Inz( %Size( MatRscMgDt ))
D RdBytAvl 10i 0
D RdTimDay 8a
D RdData
D RdPrcTimIpl 20u 0 Overlay( RdData: 1 )
D RdPrcTimScWl 20u 0 Overlay( RdData: *Next )
D RdPrcTimDb 20u 0 Overlay( RdData: *Next )
D RdPrcTimDbTh 5u 0 Overlay( RdData: *Next )
D RdPrcTimDbLm 5u 0 Overlay( RdData: *Next )
D RdRsv1 10u 0 Inz( x'00' )
D Overlay( RdData: *Next )
D RdPrcTimInt 20u 0 Overlay( RdData: *Next )
D RdPrcTimIntT 4b 1 Overlay( RdData: *Next )
D RdPrcTimIntL 4b 1 Overlay( RdData: *Next )
D RdRsv2 10u 0 Inz( x'00' )
D Overlay( RdData: *Next )
**
D MatCtlDta Ds
D CdSltOpt 1a Inz( x'01' )
D CdRsv 7a Inz( *Allx'00' )
**-- Global variables: -------------------------------------------------**
D Ix s 5i 0
D Count s 5i 0
D Interval s 10u 0
D TopCount s 3S 0
D PgmNam s 10a
D MsgDta s 256a Varying
D MsgKey s 4a
D SysTime s z inz(*sys)
**-- API constants: ----------------------------------------------------**
D JOB_RESET_STAT c '1'
D JOB_KEEP_STAT c '0'
**-- Open list of jobs: ------------------------------------------------**
D LstJobs Pr ExtPgm( 'QGYOLJOB' )
D LjRcvVar 65535a Options( *VarSize )
D LjRcvVarLen 10i 0 Const
D LjFmtNam 8a Const
D LjRcvVarDfn 65535a Options( *VarSize )
D LjRcvDfnLen 10i 0 Const
D LjLstInf 80a
D LjNbrRcdRtn 10i 0 Const
D LjSrtInf 1024a Const Options( *VarSize )
D LjJobSltInf 1024a Const Options( *VarSize )
D LjJobSltLen 10i 0 Const
D LjNbrFldRtn 10i 0 Const
D LjKeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D LjError 1024a Options( *VarSize )
**
D LjJobSltFmt 8a Const Options( *NoPass )
**
D LjResStc 1a Const Options( *NoPass )
D LjGenRtnDta 32a Options( *NoPass: *VarSize )
D LjGenRtnDtaLn 10i 0 Const Options( *NoPass )
**-- Get list entry: ---------------------------------------------------**
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list: -------------------------------------------------------**
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Send message: -----------------------------------------------------**
D SndMsg Pr ExtPgm( 'QMHSNDM' )
D SmMsgId 7a Const
D SmMsgFq 20a Const
D SmMsgDta 512a Const Options( *VarSize )
D SmMsgDtaLen 10i 0 Const
D SmMsgTyp 10a Const
D SmMsgQq 1000a Const Options( *VarSize )
D SmMsgQnbr 10i 0 Const
D SmMsgQrpy 20a Const
D SmMsgKey 4a
D SmError 10i 0 Const
**
D SmCcsId 10i 0 Const Options( *NoPass )
**-- Copy memory: ------------------------------------------------------**
D memcpy Pr * ExtProc( '_MEMMOVE' )
D outmem * Value
D inpmem * Value
D memsiz 10u 0 Value
**-- Delay job: --------------------------------------------------------**
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Get top stack entry: ----------------------------------------------**
D GetTopStkE Pr 20a
D GtJobId 26a Const
**-- Materialize resource management data: -----------------------------**
D MatRmd Pr ExtProc( '_MATRMD' )
D Rcv Like( MatRscMgDt )
D Ctl Like( MatCtlDta )
**
**-- Mainline: ---------------------------------------------------------**
**
C *Entry Plist
C Parm TopCount_p 3
C Parm Interval_p 5
C Parm ToMsgQ 10
**
C Eval TopCount = %Int(TopCount_p)
C Eval Interval = %Int(Interval_p)
C Select
C When ToMsgQ = '*SYSOPR'
C Eval ToMsgQ = 'QSYSOPR'
C When ToMsgQ = '*CURUSR'
C Eval ToMsgQ = PsCurUsr
C EndSl
**
**-- Job information return fields:
C Eval JlKeyFld(1) = 312
C Eval JlKeyFld(2) = 314
C Eval JlKeyFld(3) = 315
**
**-- Sort field specification:
C Eval SiNbrKeys = 1
C Eval SiKeyFldOfs(1) = 49
C Eval SiKeyFldLen(1) = 4
C Eval SiKeyFldTyp(1) = 0
C Eval SiSrtOrd(1) = '2'
C Eval SiRsv(1) = x'00'
**
**-- Initialize job CPU measurement:
**-- NOTE: Statistics only reset if return records are requested
**
C DoW 1 = 1
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_RESET_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
**-- Wait 10 seconds:
C CallP sleep( Interval )
**
**-- Retrieve job list:
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_KEEP_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C If AeBytAvl = *Zero
**
C Eval Count = 0
C DoW LiLstSts <> '2' Or
C LiRcdNbrTot > JlRtnRcdNbr
**
C ExSr GetCpuDta
C ExSr ChkCpuPct
**
C* ExSr SndCmpMsg
**
C If Count >= TopCount
C Leave
C EndIf
**
C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1
**
C CallP GetLstEnt( JlJobInf
C : %Size( JlJobInf )
C : LiHandle
C : JlLstInf
C : 1
C : JlRtnRcdNbr
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Leave
C EndIf
**
C EndDo
**
C CallP CloseLst( LiHandle
C : ApiError
C )
**
C EndIf
**
C EndDo
**
C Eval *InLr = *On
**
C Return
**
**-- Get CPU data: -----------------------------------------------------**
C GetCpuDta BegSr
**
C Clear JbKeyDta
**
C For Ix = 1 To KiFldNbrRtn
**
C Select
C When KiKeyFld(Ix) = 312
C CallP memcpy( %Addr( JbPrcUniTim )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 314
C CallP memcpy( %Addr( JbPrcUniPct )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 315
C CallP memcpy( %Addr( JbPrcUniTimE )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
C EndSl
C EndFor
**
C EndSr
**-- Check CPU percent: ------------------------------------------------**
C ChkCpuPct BegSr
**
C Eval Count = Count + 1
C Eval PgmNam = GetTopStkE( JbJobId )
**
C Eval SysTime = %Timestamp()
C Eval MsgDta =
C '{ "CPUPCTMSG": { ' +
C '"QDATETIME" : "' +
C %Char(%Timestamp():*ISO) + '", ' +
C '"JobNam" : "' +
C %Trim(JbJobUsd) + '", ' +
C '"JobUsr" : "' +
C %Trim(JbUsrUsd) + '", ' +
C '"JobNbr" : "' +
C %Trim(JbNbrUsd) + '", ' +
C '"CpuPct" : "' +
C %Char( JbPrcUniPct ) + '", ' +
C '"PgmNam" : "' +
C %Trim( PgmNam ) + '" ' +
C '} }'
**
C CallP(e) SndMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*INFO'
C : ToMsgQ + '*LIBL'
C : 1
C : *Blanks
C : MsgKey
C : 0
C )
**
C EndSr
**-- Get top stack entry: ----------------------------------------------**
P GetTopStkE B Export
D Pi 20a
D GtJobId 26a Const
**-- API parameters:
D CsRcvVar Ds
D CsBytRtn 10i 0
D CsBytAvl 10i 0
D CsNbrStkE 10i 0
D CsOfsStkE 10i 0
D CsNbrEntRtn 10i 0
D CsThrId 8a
D CsInfSts 1a
D CsCalStk 32767a
**
D CsCalStkE Ds Based( pCalStkE )
D CsStkEntLen 10i 0
D CsOfsStmIds 10i 0
D CsNbrStmIds 10i 0
D CsOfsPrcNam 10i 0
D CsLenPrcNam 10i 0
D CsRqsLvl 10i 0
D CsPgmNam 10a
D CsPgmLib 10a
D CsMiInst 10i 0
D CsModNam 10a
D CsModLib 10a
D CsCtlBdy 1a
D CsRsv 3a
D CsActGrpNbr 10u 0
D CsActGrpNam 10a
D CsAddInf 4096a
**
D CsStmIds 10a Dim( 16 )
D CsPrcNam 512a
**
D CsJobId Ds
D JiJobId 26a
D JiJobNam 10a Overlay( JiJobId: 1 )
D JiUsrNam 10a Overlay( JiJobId: *Next )
D JiJobNbr 6a Overlay( JiJobId: *Next )
D JiIntId 16a
D JiRsv 2a Inz( *Allx'00' )
D JiThrInd 10i 0 Inz( 2 )
D JiThrId 8a Inz( *Allx'00' )
**-- Retrieve call stack:
D RtvCalStk Pr ExtPgm( 'QWVRCSTK' )
D RcRcvVar 32767a
D RcRcvVarLen 10i 0 Const
D RcRcvInfFmt 8a Const
D RcJobId 56a Const
D RcJobIdFmt 8a Const
D RcError 32767a Options( *VarSize )
**
D EntNbr s 5u 0
**-- Get stack entries: ------------------------------------------------**
**
C Eval JiJobId = GtJobId
**
C CallP RtvCalStk( CsRcvVar
C : %Size( CsRcvVar )
C : 'CSTK0100'
C : CsJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Eval pCalStkE = %Addr( CsRcvVar ) + CsOfsStkE
**
C For EntNbr = 1 to CsNbrEntRtn
**
C If EntNbr = 1
**
C Eval CsStmIds = *Blanks
C Eval CsPrcNam = *Blanks
**
C If CsOfsStmIds > *Zero
C CallP MemCpy( %Addr( CsStmIds )
C : %Addr( CsCalStkE ) +
C CsOfsStmIds
C : CsNbrStmIds * %Size( CsStmIds )
C )
C EndIf
**
C If CsOfsPrcNam > *Zero
C CallP MemCpy( %Addr( CsPrcNam )
C : %Addr( CsCalStkE ) +
C CsOfsPrcNam
C : CsLenPrcNam
C )
C EndIf
**
C Leave
C EndIf
**
C If EntNbr < CsNbrEntRtn
C Eval pCalStkE = PCalStkE + CsStkEntLen
C EndIf
C EndFor
**
C Return CsPgmNam + CsPgmLib
**
C Else
C Return *Blanks
C EndIf
**
P GetTopStkE E
File : QCMDSRC
Member: TOPCPUPCT
Type : CMD
/* =============================================================== */
/* = Command....... TopCpuPct = */
/* = CPP........... TopCpuPct RPGLE = */
/* = Description... Send WRKACTJOB CPUPCT top to user = */
/* = = */
/* = = */
/* = CrtCmd Cmd( TopCpuPct ) = */
/* = Pgm( TopCpuPct ) = */
/* = SrcFile( YourSourceFile ) = */
/* =============================================================== */
/* = Date : 2023/11/21 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
CMD PROMPT('Top Cpu Percent Job')
PARM KWD(TOPCOUNT) TYPE(*CHAR) LEN(3) +
RANGE('001' '999') +
FULL(*YES) +
PROMPT('TOP CPU JOB COUNT')
PARM KWD(INTERVAL) TYPE(*CHAR) LEN(5) +
RANGE('00001' '99999') +
FULL(*YES) +
PROMPT('Interval second')
PARM KWD(TOMSGQ) TYPE(*CHAR) LEN(10) +
DFT(*SYSOPR) +
SPCVAL((*SYSOPR) (*CURUSR)) +
PROMPT('Message To MsgQ')
Program to capture CPU usage over time (with SQL)
星期一, 11月 06, 2023
2003-06-11 如何於程式執行時知道 Savf File 的內容(API QSRLSAVF) ?
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
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')
2003-04-28 如何快速得知 IFS 目錄下的檔案大小？
如何快速得知 IFS 目錄下的檔案大小？
IBM 提供 V5R1 PTF SI05156 (superseded by SI05856) 及 V5R2 PTF SI05155
可以執行程式指定目錄及可以快速得知該目錄下檔案大小。
For the full report:
call qsrsrv parm("METRICS" '/')
To omit QNTC, QNETWARE, QLANSRV use the following.
call qsrsrv parm("METRICS" '/' "EPFS")
Or for a specific directory.
call qsrsrv parm("METRICS" '/mydir/mysubdir')
2003-01-06 報表安全系列五：如何限制指令 CHGSPLFA 的使用, 防止使用者更改其他人報表的屬性?
報表安全系列五：如何限制指令 CHGSPLFA 的使用, 防止使用者更改其他人報表的屬性?
有鑑於 報表的安全性管理，iSeries(AS/400) 作業系統並未提供完善的保護，我將建議使用 VCP 命令
語法檢核程式來做安全空管，
報表安全系列一 ：如何限制指令 WRKSPLF 的使用, 防止使用者察看全系統的報表 ?
報表安全系列二 ：如何限制指令 DSPSPLF 的使用, 防止使用者於 WRKSPLF 畫面中瀏覽全系統的報表 ?
報表安全系列三 ：如何限制指令 DLTSPLF 的使用, 防止使用者刪除其他人的報表 ?
報表安全系列四 ：如何限制指令 CPYSPLF 的使用, 防止使用者複製其他人的報表 ?
報表安全系列五 ：如何限制指令 CHGSPLFA 的使用, 防止使用者更改其他人報表的屬性?
有 *SPLCTL 權限的人可以更改系統上任何報表的屬性，如印表機，Outq 輸出佇列..等屬性，
要如何防止非授權使用者更改機密敏感的報表資料屬性，為了要防止這種情形發生，只能從命
令檢核程式著手，此範例與其他相關報表命令
（WRKSPLF, DSPSPLF, DLTSPLF, CPYSPLF）的檢核程式一樣，限制除了 QSECOFR, QSYSOPR
之外，使用者僅能刪除自己的報表，同樣也分 OS V5R1(含)以前及OS V5R2(含)以後的版本。
CHGSPLFAVC 命令語法檢核程式 for V5R1
File : QCLSRC
Member: CHGSPLFAVC
Type : CLP
OS version: V5R1 以前
Usage : CRTCLPGM mylib/CHGSPLFAVC
CHGCMD CMD(CHGSPLFA) VLDCKR(mylib/CHGSPLFAVC)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(CHGSPLFA) VLDCKR(*NONE)
/* Program : CHGSPLFVAVC */
/* System : iSeries 400 */
/* */
/* Validity Checking program for command CHGSPLFA */
/* */
/* Example : protecting an OUTQ from a USER */
/* */
/* CHGCMD CMD(CHGSPLFA) VLDCKR(MYLIB/CHGSPLFVAL) */
/* To reset (in case you made errors) : */
/* CHGCMD CMD(CHGSPLFA) VLDCKR(*NONE) */
CHGSPLFVAL: PGM PARM(&P1 &P2 &P3 &P4 &P5 &P6 &P7 &P8 &P9 +
&P10 &P11 &P12 &P13 &P14 &P15 &P16 &P17 +
&P18 &P19 &P20 &P21 &P22 &P23 &P24 &P25 +
&P26 &P27 &P28 &P29 &P30 &P31 &P32 &P33 +
&P34 &P35 &P36 &P37 &P38 &P39)
DCL VAR(&P1) TYPE(*CHAR) LEN(1)
DCL VAR(&P2) TYPE(*CHAR) LEN(10) /* FILE */
DCL VAR(&P3) TYPE(*CHAR) LEN(26) /* JOB */
DCL VAR(&P4) TYPE(*CHAR) LEN(1)
DCL VAR(&P5) TYPE(*CHAR) LEN(44) /* SELECT */
DCL VAR(&P6) TYPE(*CHAR) LEN(10) /* PRINTER */
DCL VAR(&P7) TYPE(*CHAR) LEN(1)
DCL VAR(&P8) TYPE(*CHAR) LEN(20) /* OUTQ */
DCL VAR(&P9) TYPE(*CHAR) LEN(10) /* OUTQ LIB */
DCL VAR(&P10) TYPE(*CHAR) LEN(1)
DCL VAR(&P11) TYPE(*CHAR) LEN(1)
DCL VAR(&P12) TYPE(*CHAR) LEN(1)
DCL VAR(&P13) TYPE(*CHAR) LEN(1)
DCL VAR(&P14) TYPE(*CHAR) LEN(1)
DCL VAR(&P15) TYPE(*CHAR) LEN(1)
DCL VAR(&P16) TYPE(*CHAR) LEN(1)
DCL VAR(&P17) TYPE(*CHAR) LEN(1)
DCL VAR(&P18) TYPE(*CHAR) LEN(1)
DCL VAR(&P19) TYPE(*CHAR) LEN(1)
DCL VAR(&P20) TYPE(*CHAR) LEN(1)
DCL VAR(&P21) TYPE(*CHAR) LEN(1)
DCL VAR(&P22) TYPE(*CHAR) LEN(1)
DCL VAR(&P23) TYPE(*CHAR) LEN(1)
DCL VAR(&P24) TYPE(*CHAR) LEN(1)
DCL VAR(&P25) TYPE(*CHAR) LEN(1)
DCL VAR(&P26) TYPE(*CHAR) LEN(1)
DCL VAR(&P27) TYPE(*CHAR) LEN(1)
DCL VAR(&P28) TYPE(*CHAR) LEN(1)
DCL VAR(&P29) TYPE(*CHAR) LEN(1)
DCL VAR(&P30) TYPE(*CHAR) LEN(1)
DCL VAR(&P31) TYPE(*CHAR) LEN(1)
DCL VAR(&P32) TYPE(*CHAR) LEN(1)
DCL VAR(&P33) TYPE(*CHAR) LEN(1)
DCL VAR(&P34) TYPE(*CHAR) LEN(1)
DCL VAR(&P35) TYPE(*CHAR) LEN(1)
DCL VAR(&P36) TYPE(*CHAR) LEN(1)
DCL VAR(&P37) TYPE(*CHAR) LEN(1)
DCL VAR(&P38) TYPE(*CHAR) LEN(1)
DCL VAR(&P39) TYPE(*CHAR) LEN(1)
DCL VAR(&OUTQ) TYPE(*CHAR) LEN(10)
DCL VAR(&SPLUSR) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
RTVJOBA JOB(&JOBNAME) USER(&USER) NBR(&JOBNBR)
CHGVAR &OUTQ %SST(&P8 1 10)
IF (%SST(&P3 1 1) *EQ '*') DO
CHGVAR &SPLUSR &USER
CHGVAR %SST(&P3 1 10) &JOBNAME
CHGVAR %SST(&P3 11 10) &USER
CHGVAR %SST(&P3 21 6) &JOBNBR
ENDDO
ELSE +
CHGVAR &SPLUSR %SST(&P3 11 10)
/* Check here your criteria. */
/* (f.e. Userprofile ... */
/* If a user is authorized based on your criteria, then */
/* RETURN. */
/* If he is not authorized then goto NOT_OK. */
/* In that case an escape message is send. */
/* USER QSECOFR, QSYSOPR UNLIMIT ACCESS SPOOLED FILE */
IF ((&USER *EQ 'QSECOFR') *OR +
(&USER *EQ 'QSYSOPR')) +
THEN(GOTO OK)
/* LIMIT ONLY SPOOLED CREATION USER CAN BROWSE OWN'S SPOOLED FILE */
IF COND(&USER *NE &SPLUSR) +
THEN(GOTO NOT_OK)
/* LIMIT OUTQ FOR SPECIFIED USER */
IF COND(&USER *EQ 'JOE' *AND &P8 *EQ 'MYOUTQ') +
THEN(GOTO NOT_OK)
OK:
RETURN
NOT_OK: SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) +
MSGDTA('0000' *CAT 'You are not +
authorized to output queue MYOUTQ') +
MSGTYPE(*DIAG)
SNDPGMMSG MSGID( CPF0002 ) +
MSGF( QSYS/QCPFMSG ) +
MSGTYPE( *ESCAPE )
END: ENDPGM
CPYSPLF 命令語法檢核程式 for V5R2
因為 CHGSPLFA 命令於 OS V5R2 中的參數個數增加至 42 個，而 CLP 的 PARM 參數僅能
接收 40 個參數，所以我改用 RPGLE 來撰寫命令語法檢核程式。
File : QRPGLESRC
Member: CHGSPLFAVR
Type : RPGLE
OS version: V5R2 以後
Usage : CRTBNDRPG mylib/CHGSPLFAVR
CHGCMD CMD(CHGSPLFA) VLDCKR(mylib/CHGSPLFAVR)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(CHGSPLFA) VLDCKR(*NONE)
****************************************************************************************
* CHGSPLFA VCP for iSeries V5R2
*
/* * Validity Checking program for command CHGSPLFA
/*
/* * Example : protecting an SPOOL From a USER
/* *
/* * CHGCMD CMD(CHGSPLFA) VLDCKR(MYLIB/CHGSPLFAVR)
/* * To reset (in case you made errors) :
/* * CHGCMD CMD(CHGSPLFA) VLDCKR(*NONE)
****************************************************************************************
****************************************************************************************
* D E F I N I T I O N S P E C I F I C A T I O N *
****************************************************************
*
* Program Status Data Structure
*
D PGMDS SDS
D Pgmq## *PROC
D ErrorSts *STATUS
D PrvStatus 16 20S 0
D SrcLinNum 21 28
D Routine *ROUTINE
D NumParms *PARMS
D ExcpType 40 42
D ExcpNum 43 46
*
D PgmLib 81 90
D ExcpData 91 170
D ExcpId 171 174
D LastFile 201 208
D FileErr 209 243
D JobName 244 253
D User 254 263
D JobNumA 264 269
D JobNum 264 269S 0
D JobDate 270 275S 0
D RunDate 276 281S 0
D RunTime 282 287S 0
D PgmCrtDt 288 293
D PgmCrtTm 294 299
D CmplrLvl 300 303
D SrcFile 304 313
D SrcLib 314 323
D SrcMbr 324 333
D ProcPgm 334 343
D ProcMod 344 353
D cmd_str S 1024 INZ
D cmd_len S 15P 5 INZ(1024)
D msg_str S 256
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7a error msgid
D vresvd 1a reserved
D vrpldta 50a replacement data
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGES
D 7 const ID
D 20 const FILE
D 73 const TEXT
D 10i 0 const LENGTH
D 10 const TYPE
D 10 const QUEUE
D 10i 0 const STACK ENTRY
D 4 const KEY
Db like(vApiErrDS)
* QCMDEXC - Prototyped Call
D qcmdexc PR EXTPGM('QCMDEXC')
D cmd_str 1024 OPTIONS(*VARSIZE) CONST
D cmd_len 15P 5 CONST
C *entry Plist
C Parm P1 1
C Parm P2 10 File
C Parm P3 26 Job
C Parm P4 4 Splnbr
C Parm P5 8 Sysname
C Parm P6 6
C Parm P7 44
C Parm P8 10 Device
C Parm P9 1
C Parm P10 20
C Parm P11 1
C Parm P12 1
C Parm P13 1
C Parm P14 1
C Parm P15 1
C Parm P16 1
C Parm P17 1 Outq
C Parm P18 1
C Parm P19 1
C Parm P21 1
C Parm P22 1
C Parm P23 1
C Parm P24 1
C Parm P25 1
C Parm P26 1
C Parm P27 1
C Parm P28 1
C Parm P29 1
C Parm P30 1
C Parm P31 1
C Parm P32 1
C Parm P33 1
C Parm P34 1
C Parm P35 1
C Parm P36 1
C Parm P37 1
C Parm P38 1
C Parm P39 1
C Parm P40 1
C Parm P41 1
C Parm P42 1
C
C If %Subst(P3:1:1) = '*'
C Eval %Subst(P3: 1:10)= JobName
C Eval %Subst(P3:11:10)= User
C Eval %Subst(P3:21: 6)= JobNumA
C EndIf
* Exclude highest authority user
C If User <> 'QSECOFR' and
C User <> 'QSYSOPR'
* Limit user can chgsplfa on their own spooled
C If %Subst(P3:11:10)<> User
C Eval msg_str =
C '0000 You are not authorized to ' +
C 'spooled file ' + P2
* Send diag message
C callp QMHSNDPM(
C 'CPD0006':'QCPFMSG *LIBL ':
C msg_str:
C 256:'*DIAG ':'*CTLBDY ': 1:' ':
C vApiErrDS)
C
* Send Excape message
C callp QMHSNDPM(
C 'CPF0002':'QCPFMSG *LIBL ':
C ' ' :
C 0 :'*ESCAPE':'*CTLBDY ': 1:' ':
C vApiErrDS)
C EndIf
C EndIf
C
C Eval *InLr = *On
2003-01-05 報表安全系列四：如何限制指令 CPYSPLF 的使用, 防止使用者複製其他人的報表 ?
如何限制指令 CPYSPLF 的使用, 防止使用者複製其他人的報表 ?
有鑑於 報表的安全性管理，iSeries(AS/400) 作業系統並未提供完善的保護，我將建議使用 VCP 命令
語法檢核程式來做安全空管，
報表安全系列一 ：如何限制指令 WRKSPLF 的使用, 防止使用者察看全系統的報表 ?
報表安全系列二 ：如何限制指令 DSPSPLF 的使用, 防止使用者於 WRKSPLF 畫面中瀏覽全系統的報表 ?
報表安全系列三 ：如何限制指令 DLTSPLF 的使用, 防止使用者刪除其他人的報表 ?
報表安全系列四 ：如何限制指令 CPYSPLF 的使用, 防止使用者複製其他人的報表 ?
有 *SPLCTL 權限的人可以複製系統上任何報表，要如何防止非授權使用者複製機密敏感
的報表資料，為了要防止這種情形發生，只能從命令檢核程式著手，此範例與其他相關報
表命令（WRKSPLF, DSPSPLF, DLTSPLF）的檢核程式一樣，限制除了 QSECOFR, QSYSOPR 之外，
使用者僅能刪除自己的報表，同樣也分 OS V5R1(含)以前及OS V5R2(含)以後的版本。
CPYSPLF 命令語法檢核程式 for V5R1
File : QCLSRC
Member: CPYSPLFVC
Type : CLP
OS version: V5R1 以前
Usage : CRTCLPGM mylib/CPYSPLFVC
CHGCMD CMD(CPYSPLF) VLDCKR(mylib/CPYSPLFVC)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(DSPSPLF) VLDCKR(*NONE)
/* Program : CPYSPLFVC */
/* System : iSeries 400 FOR V5R1 */
/* */
/* Validity Checking program for command CPYSPLF */
/* */
/* Example : protecting an SPOOL From a USER */
/* */
/* CHGCMD CMD(CPYSPLF) VLDCKR(MYLIB/CPYSPLFVC) */
/* To reset (in case you made errors) : */
/* CHGCMD CMD(CPYSPLF) VLDCKR(*NONE) */
DSPSPLFVC: PGM PARM(&P1 &P2 &P3 &P4 &P5 +
&P6 &P7 &P8 &P9 &P10)
DCL VAR(&P1) TYPE(*CHAR) LEN(10) /* FILE */
DCL VAR(&P2) TYPE(*CHAR) LEN(20) /* TOFILE */
DCL VAR(&P3) TYPE(*CHAR) LEN(26) /* JOB */
DCL VAR(&P4) TYPE(*CHAR) LEN(4) /* SPLNBR */
DCL VAR(&P5) TYPE(*CHAR) LEN(10) /* MEMBER */
DCL VAR(&P6) TYPE(*CHAR) LEN(1) /* MBR OPTION */
DCL VAR(&P7) TYPE(*CHAR) LEN(1) /* CTLCHAR */
DCL VAR(&P8) TYPE(*CHAR) LEN(1)
DCL VAR(&P9) TYPE(*CHAR) LEN(1)
DCL VAR(&P10) TYPE(*CHAR) LEN(1)
DCL VAR(&SPLUSR) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
RTVJOBA JOB(&JOBNAME) USER(&USER) NBR(&JOBNBR)
IF (%SST(&P3 1 1) *EQ '*') DO
CHGVAR &SPLUSR &USER
CHGVAR %SST(&P3 1 10) &JOBNAME
CHGVAR %SST(&P3 11 10) &USER
CHGVAR %SST(&P3 21 6) &JOBNBR
ENDDO
ELSE +
CHGVAR &SPLUSR %SST(&P3 11 10)
/* QSECOFR, QSYSOPR CAN BROWSE ALL SPOOLED FILE */
IF COND((&USER *EQ 'QSECOFR') *OR +
(&USER *EQ 'QSYSOPR')) +
THEN(GOTO CMDLBL(OK))
/* LIMIT ONLY SPOOLED CREATION USER CAN BROWSE OWN'S SPOOLED FILE */
IF COND(&USER *NE &SPLUSR) +
THEN(GOTO NOT_OK)
OK:
RETURN
NOT_OK: SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000' +
*CAT 'You are not authorized to spooled +
file' *BCAT &P1) MSGTYPE(*DIAG)
SNDPGMMSG MSGID( CPF0002 ) +
MSGF( QSYS/QCPFMSG ) +
MSGTYPE( *ESCAPE )
ENDPGM
CPYSPLF 命令語法檢核程式 for V5R2
File : QCLSRC
Member: CPYSPLFVC
Type : CLP
OS version: V5R2 以後
Usage : CRTCLPGM mylib/CPYSPLFVC
CHGCMD CMD(CPYSPLF) VLDCKR(mylib/CPYSPLFVC)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(DSPSPLF) VLDCKR(*NONE)
/* Program : CPYSPLFVC */
/* System : iSeries 400 FOR V5R2 */
/* */
/* Validity Checking program for command CPYSPLF */
/* */
/* Example : protecting an SPOOL From a USER */
/* */
/* CHGCMD CMD(CPYSPLF) VLDCKR(MYLIB/CPYSPLFVC) */
/* To reset (in case you made errors) : */
/* CHGCMD CMD(CPYSPLF) VLDCKR(*NONE) */
DSPSPLFVC: PGM PARM(&P1 &P2 &P3 &P4 &P5 &P6 +
&P7 &P8 &P9 &P10 &P11 &P12)
DCL VAR(&P1) TYPE(*CHAR) LEN(10) /* FILE */
DCL VAR(&P2) TYPE(*CHAR) LEN(20) /* TOFILE */
DCL VAR(&P3) TYPE(*CHAR) LEN(26) /* JOB */
DCL VAR(&P4) TYPE(*CHAR) LEN(4) /* SPLNBR */
DCL VAR(&P5) TYPE(*CHAR) LEN(8) /* SYSNAME*/
DCL VAR(&P6) TYPE(*CHAR) LEN(6) /* CRTDATE */
DCL VAR(&P7) TYPE(*CHAR) LEN(10) /* MEMBER */
DCL VAR(&P8) TYPE(*CHAR) LEN(1) /* MBR OPTION */
DCL VAR(&P9) TYPE(*CHAR) LEN(1) /* CTLCHAR */
DCL VAR(&P10) TYPE(*CHAR) LEN(1)
DCL VAR(&P11) TYPE(*CHAR) LEN(1)
DCL VAR(&P12) TYPE(*CHAR) LEN(1)
DCL VAR(&SPLUSR) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
RTVJOBA JOB(&JOBNAME) USER(&USER) NBR(&JOBNBR)
IF (%SST(&P3 1 1) *EQ '*') DO
CHGVAR &SPLUSR &USER
CHGVAR %SST(&P3 1 10) &JOBNAME
CHGVAR %SST(&P3 11 10) &USER
CHGVAR %SST(&P3 21 6) &JOBNBR
ENDDO
ELSE +
CHGVAR &SPLUSR %SST(&P3 11 10)
/* QSECOFR, QSYSOPR CAN BROWSE ALL SPOOLED FILE */
IF COND((&USER *EQ 'QSECOFR') *OR +
(&USER *EQ 'QSYSOPR')) +
THEN(GOTO CMDLBL(OK))
/* LIMIT ONLY SPOOLED CREATION USER CAN BROWSE OWN'S SPOOLED FILE */
IF COND(&USER *NE &SPLUSR) +
THEN(GOTO NOT_OK)
OK:
RETURN
NOT_OK: SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000' +
*CAT 'You are not authorized to spooled +
file' *BCAT &P1) MSGTYPE(*DIAG)
SNDPGMMSG MSGID( CPF0002 ) +
MSGF( QSYS/QCPFMSG ) +
MSGTYPE( *ESCAPE )
ENDPGM
2003-01-04 報表安全列三：如何限制指令 DLTSPLF 的使用, 防止使用者刪除其他人的報表 ?
報表安全列三：如何限制指令 DLTSPLF 的使用, 防止使用者刪除其他人的報表 ?
有鑑於 報表的安全性管理，iSeries(AS/400) 作業系統並未提供完善的保護，我將建議使用 VCP 命令語
法檢核程式來做安全空管，
報表安全系列一 ：如何限制指令 WRKSPLF 的使用, 防止使用者察看全系統的報表 ?
報表安全系列二 ：如何限制指令 DSPSPLF 的使用, 防止使用者於 WRKSPLF 畫面中瀏覽全系統的報表 ?
報表安全系列三 ：如何限制指令 DLTSPLF 的使用, 防止使用者刪除其他人的報表 ?
你是否常會遇到使用者反應他的報表不見了，有可能被其他有 *SPLCTL 權限的人刪除，
為了要防止這種情形發生，只能從命令檢核程式著手，此範例與其他相關報表命令
（WRKSPLF, DSPSPLF）的檢核程式一樣，限制除了 QSECOFR, QSYSOPR 之外，使
用者僅能刪除自己的報表，同樣也分 OS V5R1(含)以前及OS V5R2(含)以後的版本。
DLTSPLF 命令語法檢核程式 for V5R1
File : QCLSRC
Member: DLTSPLFVC
Type : CLP
OS version: V5R1 以前
Usage : CRTCLPGM mylib/DLTSPLFVC
CHGCMD CMD(DLTSPLF) VLDCKR(mylib/DLTSPLFVC)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(DSPSPLF) VLDCKR(*NONE)
/* Program : DLTSPLFVC */
/* System : iSeries 400 FOR V5R1 */
/* */
/* Validity Checking program for command DLTSPLF */
/* */
/* Example : protecting an SPOOL From a USER */
/* */
/* CHGCMD CMD(DLTSPLF) VLDCKR(MYLIB/DLTSPLFVC) */
/* To reset (in case you made errors) : */
/* CHGCMD CMD(DLTSPLF) VLDCKR(*NONE) */
DSPSPLFVC: PGM PARM(&P1 &P2 &P3 &P4 &P5)
DCL VAR(&P1) TYPE(*CHAR) LEN(10) /* FUNC */
DCL VAR(&P2) TYPE(*CHAR) LEN(10) /* FILE */
DCL VAR(&P3) TYPE(*CHAR) LEN(26) /* JOB */
DCL VAR(&P4) TYPE(*CHAR) LEN(4) /* SPLNBR */
DCL VAR(&P5) TYPE(*CHAR) LEN(40) /* SELECT */
DCL VAR(&SPLUSR) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
RTVJOBA JOB(&JOBNAME) USER(&USER) NBR(&JOBNBR)
IF (%SST(&P3 1 1) *EQ '*') DO
CHGVAR &SPLUSR &USER
CHGVAR %SST(&P3 1 10) &JOBNAME
CHGVAR %SST(&P3 11 10) &USER
CHGVAR %SST(&P3 21 6) &JOBNBR
ENDDO
ELSE +
CHGVAR &SPLUSR %SST(&P3 11 10)
/* USER QSECOFR, QSYSOPR UNLIMIT ACCESS SPOOLED FILE */
IF ((&USER *EQ 'QSECOFR') *OR +
(&USER *EQ 'QSYSOPR')) +
THEN(GOTO OK)
/* LIMIT ONLY SPOOLED CREATION USER CAN BROWSE OWN'S SPOOLED FILE */
IF COND(&USER *NE &SPLUSR) +
THEN(GOTO NOT_OK)
OK:
RETURN
NOT_OK: SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000' +
*CAT 'You are not authorized to spooled +
file' *BCAT &P2) MSGTYPE(*DIAG)
SNDPGMMSG MSGID( CPF0002 ) +
MSGF( QSYS/QCPFMSG ) +
MSGTYPE( *ESCAPE )
ENDPGM
DLTSPLF 命令語法檢核程式 for V5R2
File : QCLSRC
Member: DLTSPLFVC
Type : CLP
OS version: V5R2 以後
Usage : CRTCLPGM mylib/DLTSPLFVC
CHGCMD CMD(DLTSPLF) VLDCKR(mylib/DLTSPLFVC)
若執行有問題或不使用命令語法檢核程式時，執行
CHGCMD CMD(DSPSPLF) VLDCKR(*NONE)
/* Program : DLTSPLFVC */
/* System : iSeries 400 FOR V5R2 */
/* */
/* Validity Checking program for command DLTSPLF */
/* */
/* Example : protecting an SPOOL From a USER */
/* */
/* CHGCMD CMD(DLTSPLF) VLDCKR(MYLIB/DLTSPLFVC) */
/* To reset (in case you made errors) : */
/* CHGCMD CMD(DLTSPLF) VLDCKR(*NONE) */
DSPSPLFVC: PGM PARM(&P1 &P2 &P3 &P4 &P5 &P6 &P7)
DCL VAR(&P1) TYPE(*CHAR) LEN(1) /* FUNC */
DCL VAR(&P2) TYPE(*CHAR) LEN(10) /* FILE */
DCL VAR(&P3) TYPE(*CHAR) LEN(26) /* JOB */
DCL VAR(&P4) TYPE(*CHAR) LEN(4) /* SPLNBR */
DCL VAR(&P5) TYPE(*CHAR) LEN(8) /* SYSNAME */
DCL VAR(&P6) TYPE(*CHAR) LEN(6) /* CRTDATE */
DCL VAR(&P7) TYPE(*CHAR) LEN(40) /* SELECT */
DCL VAR(&SPLUSR) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
RTVJOBA JOB(&JOBNAME) USER(&USER) NBR(&JOBNBR)
IF (%SST(&P3 1 1) *EQ '*') DO
CHGVAR &SPLUSR &USER
CHGVAR %SST(&P3 1 10) &JOBNAME
CHGVAR %SST(&P3 11 10) &USER
CHGVAR %SST(&P3 21 6) &JOBNBR
ENDDO
ELSE +
CHGVAR &SPLUSR %SST(&P3 11 10)
/* USER QSECOFR, QSYSOPR UNLIMIT ACCESS SPOOLED FILE */
IF ((&USER *EQ 'QSECOFR') *OR +
(&USER *EQ 'QSYSOPR')) +
THEN(GOTO OK)
/* LIMIT ONLY SPOOLED CREATION USER CAN BROWSE OWN'S SPOOLED FILE */
IF COND(&USER *NE &SPLUSR) +
THEN(GOTO NOT_OK)
OK:
RETURN
NOT_OK: SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000' +
*CAT 'You are not authorized to spooled +
file' *BCAT &P2) MSGTYPE(*DIAG)
SNDPGMMSG MSGID( CPF0002 ) +
MSGF( QSYS/QCPFMSG ) +
MSGTYPE( *ESCAPE )
ENDPGM
訂閱：
文章 (Atom)