使用 API Open List of Objects (QGYOLOBJ) API 列出損壞的物件(object damaged) -- Command DSPOBJDMG
File : QRPGLESRC
Member: DSPOBJDMG
Type : RPGLE
Usage : CRTBNDRPG DSPOBJDMG
**
** Program . . : DSPOBJDMGR
** Description : Display Object Damage - CPP
** Author . . : Vengoal Chang
** Published . : AS400ePaper
** Date . . . : January 25, 2013
**
**
** Program summary
** ---------------
**
** Work management APIs:
** QGYOLOBJ Open List of Objects List of object names based on the
** specified selection criteria.
**
** Optionally a sort order for the
** returned objects can be specified.
**
** The QGYOLOBJ API is found in the
** QGY library as are all other open
** list APIs. From V5R3 open list
** APIs are part of QSYS.
**
** To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** 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.
**
** 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.
**
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** an external message queue.
**
** Both messages defined in a message
** file and immediate messages can be
** used. For specific message types
** only one or the other is allowed.
**
** Programmer's note:
** As mentioned above library QGY must be in the job library list
** to succesfully run this program if on release V5R2 or earlier.
**
**
** Compile options:
** CrtBndRpg Pgm( DSPOBJDMG )
** DbgView( *LIST )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) DftActGrp(*NO) Debug
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 128a
**-- Global constants:
D OFS_MSGDTA c 16
D CHAR_NLS c 4
D SORT_ASC c '1'
**-- Global variables:
D ObjNam_q Ds
D ObjNam 10a
D ObjLib 10a
D MsgQ_q Ds
D MsgQNam 10a Inz('QSYSOPR')
D MsgQLib 10a Inz('*LIBL')
D TempStr S 512a
D DmgCnt S 10i 0
**-- List API parameters:
D LstApi Ds Qualified Inz
D RtnRcdNbr 10i 0 Inz( 0 )
D NbrKeyRtn 10i 0 Inz( 1 )
D KeyFld 10i 0 Dim( 1 )
**-- Object information:
D ObjInf Ds 4096 Qualified
D ObjNam_q 20a
D ObjNam 10a Overlay( ObjNam_q: 1 )
D ObjLib 10a Overlay( ObjNam_q: *Next )
D ObjTyp 10a
D InfSts 1a
D 1a
D FldNbrRtn 10i 0
D Data Like( KeyInf )
**-- Key information:
D KeyInf Ds Qualified Based( pKeyInf )
D FldInfLen 10i 0
D KeyFld 10i 0
D DtaTyp 1a
D 3a
D DtaLen 10i 0
D Data 256a
D Key0200 Ds Qualified
D InfSts 1a
D ExdObjAtr 10a
D TxtDesc 50a
D UsrDfnAtr 10a
D OrdInLibl 10i 0
D Resvd 5a
**-- Authority control:
D AutCtl Ds Qualified
D AutFmtLen 10i 0 Inz( %Size( AutCtl ))
D CalLvl 10i 0 Inz( 0 )
D DplObjAut 10i 0 Inz( 0 )
D NbrObjAut 10i 0 Inz( 0 )
D DplLibAut 10i 0 Inz( 0 )
D NbrLibAut 10i 0 Inz( 0 )
D 10i 0 Inz( 0 )
D ObjAut 10a Dim( 10 )
D LibAut 10a Dim( 10 )
**-- Selection control:
**-- Select all damaged objects
D SltCtl Ds
D SltFmtLen 10i 0 Inz( %Size( SltCtl ))
D SltOmt 10i 0 Inz( 0 )
D DplSts 10i 0 Inz( 20 )
D NbrSts 10i 0 Inz( 2 )
D 10i 0 Inz( 0 )
D Status 2a Inz( 'DP' )
**-- Sort information:
D SrtInf Ds Qualified
D NbrKeys 10i 0 Inz( 4 )
D SrtStr 12a Dim( 4 )
D KeyFldOfs 10i 0 Overlay( SrtStr: 1 )
D KeyFldLen 10i 0 Overlay( SrtStr: 5 )
D KeyFldTyp 5i 0 Overlay( SrtStr: 9 )
D SrtOrd 1a Overlay( SrtStr: 11 )
D Rsv 1a Overlay( SrtStr: 12 )
**-- List information:
D LstInf Ds Qualified
D RcdNbrTot 10i 0
D RcdNbrRtn 10i 0
D Handle 4a
D RcdLen 10i 0
D InfSts 1a
D Dts 13a
D LstSts 1a
D 1a
D InfLen 10i 0
D Rcd1 10i 0
D 40a
**-- Open list of objects:
D LstObjs Pr ExtPgm( 'QGYOLOBJ' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D LstInf 80a
D NbrRcdRtn 10i 0 Const
D SrtInf 1024a Const Options( *VarSize )
D ObjNam_q 20a Const
D ObjTyp 10a Const
D AutCtl 1024a Const Options( *VarSize )
D SltCtl 1024a Const Options( *VarSize )
D NbrKeyRtn 10i 0 Const
D KeyFld 10i 0 Const Options( *VarSize ) Dim( 32 )
D Error 1024a Options( *VarSize )
**
D JobIdInf 256a Options( *NoPass: *VarSize )
D JobIdFmt 8a Const Options( *NoPass )
**
D AspCtl 256a Options( *NoPass: *VarSize )
**-- Get open list entry:
D GetOplEnt Pr ExtPgm( 'QGYGTLE' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D Handle 4a Const
D LstInf 80a
D NbrRcdRtn 10i 0 Const
D RtnRcdNbr 10i 0 Const
D Error 1024a Options( *VarSize )
**-- Close list:
D CloseLst Pr ExtPgm( 'QGYCLST' )
D Handle 4a Const
D Error 1024a Options( *VarSize )
**-- Send message:
D SndMsg Pr ExtPgm( 'QMHSNDM' )
D SmMsgId 7a Const
D SmMsgF_q 20a Const
D SmMsgDta 512a Const Options( *VarSize )
D SmMsgDtaLen 10i 0 Const
D SmMsgTyp 10a Const
D SmMsgQ_q 1000a Const Options( *VarSize )
D SmMsgQnbr 10i 0 Const
D SmMsgQrpy 20a Const
D SmMsgKey 4a
D SmError 512a Options( *VarSize )
D SmCcsId 10i 0 Const Options( *NoPass )
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D MsgId 7a Const
D MsgFq 20a Const
D MsgDta 128a Const
D MsgDtaLen 10i 0 Const
D MsgTyp 10a Const
D CalStkE 10a Const Options( *VarSize )
D CalStkCtr 10i 0 Const
D MsgKey 4a
D Error 32767a Options( *VarSize )
**-- Send text message:
D SndTxtMsg Pr 10i 0
D PxMsgTxt 512a Const Varying
D PxMsgQ_q 20a Const
**-- Send joblog message:
D SndLogMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
D DSPOBJDMG Pr
D PxObjNam_q LikeDs( ObjNam_q )
**
D DSPOBJDMG Pi
D PxObjNam_q LikeDs( ObjNam_q )
/Free
ExSr LodObjLst;
*InLr = *On;
Return;
BegSr LodObjLst;
ExSr InzApiPrm;
pKeyInf = %Addr(ObjInf.Data);
LstObjs( ObjInf
: %Size( ObjInf )
: LstInf
: -1
: SrtInf
: PxObjNam_q
: '*ALL'
: AutCtl
: SltCtl
: LstApi.NbrKeyRtn
: LstApi.KeyFld
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
If ERRC0100.BytAvl < OFS_MSGDTA;
ERRC0100.BytAvl = OFS_MSGDTA;
EndIf;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
);
EndIf;
If ERRC0100.BytAvl = *Zero And LstInf.RcdNbrRtn > *Zero;
DoW LstInf.RcdNbrTot > LstApi.RtnRcdNbr;
LstApi.RtnRcdNbr += 1;
GetOplEnt( ObjInf
: %Size( ObjInf )
: LstInf.Handle
: LstInf
: 1
: LstApi.RtnRcdNbr
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
If ERRC0100.BytAvl < OFS_MSGDTA;
ERRC0100.BytAvl = OFS_MSGDTA;
EndIf;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
);
Leave;
EndIf;
If (ObjInf.InfSts = 'D' or ObjInf.InfSts = 'P');
SndTxtMsg( '*** Object damaged: ' +
ObjInf.ObjLib + '/' + ObjInf.ObjNam
: MsgQ_q
);
dmgCnt += 1;
EndIf;
EndDo;
EndIf;
If (%SubSt(PxObjNam_q:1:4) = '*ALL');
SndTxtMsg( %char(dmgCnt) + ' damaged objects in library ' +
%trim(%SubSt(PxObjNam_q:11:10))
: MsgQ_q
);
Else;
SndTxtMsg( %char(dmgCnt) + ' damaged objects for object ' +
%trim(%SubSt(PxObjNam_q:11:10)) + '/' +
%trim(%SubSt(PxObjNam_q:1:10))
: MsgQ_q
);
EndIf;
CloseLst( LstInf.Handle: ERRC0100 );
EndSr;
BegSr InzApiPrm;
LstApi.KeyFld(1) = 0200;
SrtInf.NbrKeys = 2;
SrtInf.KeyFldOfs(1) = 1;
SrtInf.KeyFldLen(1) = %Size( ObjNam );
SrtInf.KeyFldTyp(1) = CHAR_NLS;
SrtInf.SrtOrd(1) = SORT_ASC;
SrtInf.Rsv(1) = x'00';
SrtInf.KeyFldOfs(2) = 11;
SrtInf.KeyFldLen(2) = %Size( ObjLib );
SrtInf.KeyFldTyp(2) = CHAR_NLS;
SrtInf.SrtOrd(2) = SORT_ASC;
SrtInf.Rsv(2) = x'00';
EndSr;
/End-Free
**-- Send escape message:
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: PxMsgF + '*LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Send text message: ------------------------------------------------**
P SndTxtMsg B
D Pi 10i 0
D PxMsgTxt 512a Const Varying
D PxMsgQ_q 20a Const
D MsgKey s 4a
/Free
SndMsg( 'CPF9898'
: 'QCPFMSG *LIBL '
: PxMsgTxt
: %Len( PxMsgTxt )
: '*INFO'
: PxMsgQ_q
: 1
: *Blanks
: MsgKey
: ERRC0100
);
SndLogMsg( PxMsgTxt );
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndTxtMsg E
**-- Send joblog message: ----------------------------------------------**
P SndLogMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9898'
: 'QCPFMSG *LIBL '
: PxMsgDta
: %Len( PxMsgDta )
: '*INFO'
: '*EXT'
: *Zero
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
**
P SndLogMsg E
File : QCMDSRC
Member: DSPOBJDMG
Type : CMD
Usage :
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( DSPOBJDMG ) */
/* Pgm( DSPOBJDMG ) */
/* SrcMbr( DSPOBJDMG ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Display Object Damage' )
Parm OBJ Q0001 +
Min( 1 ) +
Choice( *NONE ) +
Prompt( 'Object' )
Q0001: Qual *Generic 10 +
Min( 1 ) +
SpcVal(( *ALL )) +
Expr( *YES ) +
Qual *Name 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'Library' )
run the command DSPOBJDMG will send message to joblog and MSGQ QSYSOPR
DSPOBJDMG OBJ(QIWS/*ALL)
0 damaged objects in library QIWS.
DSPOBJDMG OBJ(QIWS/QCUST*)
0 damaged objects for object QIWS/QCUST*.
If QIWS library have 1 object damaged:
DSPOBJDMG OBJ(QIWS/*ALL) will get following message:
*** Object damaged: QIWS/xxxOBJNAM.
1 damaged objects in library QIWS.
星期四, 11月 09, 2023
2013-01-30 使用 API Open List of Objects (QGYOLOBJ) API 列出損壞的物件(object damaged) -- Command DSPOBJDMG
星期三, 11月 08, 2023
2011-12-22 使用 Delete Object (QLIDLTO) API 刪除物件(Command DLTOBJ)
使用 Delete Object (QLIDLTO) API 刪除物件(Command DLTOBJ)
從 V6R1 後系統提供新 API QLIDLTO 來刪除物件，其功能相當於其他指令 DLTxxxx 的刪除物件指令。
File : QCLSRC
Member: DLTOBJ
Type : CLP
Usage : CRTCLPGM yourlib/DLTOBJ
OS : V6R1
/* =============================================================== */
/* = Command DltObjC CPP = */
/* = DltObjC CLP = */
/* = Paramater notes: = */
/* = Object : Object and library names = */
/* = Type : Object type = */
/* = AspDev : Auxiliary storage pool (ASP) device = */
/* = RmvMsg : Remove message = */
/* = = */
/* = For V6R1 and later use = */
/* = = */
/* =============================================================== */
/* = Date : 2012/12/22 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
Pgm (&QualObj &Type &AspDev &RmvMsg)
Dcl &QualObj *char 20
Dcl &Type *char 10
Dcl &AspDev *char 10
Dcl &RmvMsg *char 1
Dcl &ApiErr *char 8 X'0000000000000000'
Dcl &MsgId *char 7
Dcl &MsgDta *char 256
Dcl &Msgf *char 10
Dcl &MsgfLib *char 10
Dcl &MsgTxt *char 256
MonMsg MsgId(CPF0000 MCH0000) exec(GoTo Error)
Call QLIDLTO ( &QualObj +
&Type +
&AspDev +
&RmvMsg +
&ApiErr +
)
Return
/* =============================================================== */
/* = Error routine = */
/* =============================================================== */
Error:
RcvMsg MsgType( *Excp ) +
MsgDta( &MsgDta ) +
MsgID( &MsgID ) +
MsgF( &MsgF ) +
MsgFLib( &MsgFLib )
MonMsg ( CPF0000 MCH0000 )
SndMsg:
SndPgmMsg MsgID( &MsgID ) +
MsgF( &MsgFLib/&MsgF ) +
MsgDta( &MsgDta ) +
MsgType( *Escape )
MonMsg ( CPF0000 MCH0000 )
/* =============================================================== */
/* = End of program = */
/* =============================================================== */
EndPgm
File : QCMDSRC
Member: DLTOBJ
Type : CMD
Usage : CRTCMD Cmd(yourlib/DLTOBJ) Pgm(DltObj)
OS : V6R1
/* =============================================================== */
/* = Command....... DltObj = */
/* = CPP........... DltObj CLP = */
/* = Description... Delete Object by = */
/* = simple object name, a generic object name, = */
/* = or *ALL = */
/* = = */
/* = CrtCmd Cmd( DltObj ) = */
/* = Pgm( DltObj ) = */
/* = SrcFile( YourSourceFile ) = */
/* =============================================================== */
/* = Date : 2012/12/22 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
CMD PROMPT('Delete Object')
PARM KWD(OBJ) TYPE(QUAL2) MIN(1) PROMPT('Object')
PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) MIN(1) +
SPCVAL( +
( *ALRTBL ) +
( *AUTL ) +
( *BNDDIR ) +
( *CFGL ) +
( *CHTFMT ) +
( *CLD ) +
( *CLS ) +
( *CMD ) +
( *CNNL ) +
( *COSD ) +
( *CRQD ) +
( *CSI ) +
( *CSPMAP ) +
( *CSPTBL ) +
( *CTLD ) +
( *DEVD ) +
( *DTAARA ) +
( *DTADCT ) +
( *DTAQ ) +
( *EDTD ) +
( *FCT ) +
( *FILE ) +
( *FNTTBL ) +
( *FNTRSC ) +
( *FORMDF ) +
( *FTR ) +
( *GSS ) +
( *IGCDCT ) +
( *IGCSRT ) +
( *IGCTBL ) +
( *IMGCLG ) +
( *IPXD ) +
( *JOBD ) +
( *JOBQ ) +
( *JRN ) +
( *JRNRCV ) +
( *LIB ) +
( *LIND ) +
( *LOCALE ) +
( *MEDDFN ) +
( *MENU ) +
( *MODD ) +
( *MODULE ) +
( *MSGF ) +
( *MSGQ ) +
( *MGTCOL ) +
( *NODL ) +
( *NODGRP ) +
( *NTBD ) +
( *NWID ) +
( *NWSCFG ) +
( *NWSD ) +
( *OUTQ ) +
( *OVL ) +
( *PAGDFN ) +
( *PAGSEG ) +
( *PDFMAP ) +
( *PDG ) +
( *PGM ) +
( *PNLGRP ) +
( *PSFCFG ) +
( *QMFORM ) +
( *QMQRY ) +
( *QRYDFN ) +
( *SBSD ) +
( *SCHIDX ) +
( *SQLPKG ) +
( *SQLUDT ) +
( *SQLXSR ) +
( *SRVPGM ) +
( *SVRSTG ) +
( *SSND ) +
( *TBL ) +
( *TIMZON ) +
( *USRIDX ) +
( *USRQ ) +
( *USRSPC ) +
( *VLDL ) +
( *WSCST )) +
PROMPT('Object type')
PARM KWD(ASPDEV) TYPE(*NAME) LEN(10) DFT(*) +
SPCVAL((* *N) (*SYSBAS *N) (*CURASPGRP +
*N) (*ALLAVL *N)) PROMPT('Auxiliary +
storage pool device')
PARM KWD(RMVMSG) TYPE(*CHAR) LEN(1) +
RSTD( *YES ) +
DFT( *NO ) +
SPCVAL(( *NO '0' ) +
( *YES '1' )) +
PROMPT('Remove message')
QUAL2: QUAL TYPE(*GENERIC) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL) +
(*CURLIB)) EXPR(*YES) PROMPT('Library')
詳細資訊參照：Delete Object (QLIDLTO) API
星期二, 11月 07, 2023
2006-01-01 如何快速更改整個 Library 的所有 Object 的擁有者?(Commad CHGLIBOWN)
如何快速更改整個 Library 的所有 Object 的擁有者?(Command CHGLIBOWN)
要更改 Object owner 可以使用 CHGOBJOWN 指令, 但此指令僅能針對一個 Object 有效,
若需要針對多個物件更改時,處理時較麻煩.可以使用 CHGOWN 指令較容易快速, 他可以接受
萬用字元"*".
File : QCLSRC
Member: CHGLIBOWNC
Type : CLP
Usage : CRTCLPGM CHGLIBOWNC
Pgm (&Library &Owner)
Dcl &Library *Char 10
Dcl &Owner *Char 10
Dcl &Objects *Char 255
ChgVar &Objects Value('/QSYS.LIB/' *CAT &Library *TCAT +
'.LIB/*.*')
ChgOwn Obj(&Objects) NewOwn(&Owner)
Return
EndPgm
File : QCMDSRC
Member: CHGLIBOWN
Type : CMD
Usage : CRTCMD CMD(CHGLIBOWN) PGM(CHGLIBOWNC)
CMD PROMPT('Change Library Ownership')
PARM KWD(LIB) TYPE(*CHAR) LEN(10) PROMPT('Library:')
PARM KWD(NEWOWN) TYPE(*CHAR) LEN(10) PROMPT('New +
Owner:')
2005-08-19 如何得知某一物件被某些 Job 鎖住?(API QWCLOBJL)
如何得知某一物件被某些 Job 鎖住?(API QWCLOBJL)
傳統上可以透過 WRKOBJLCK 指令查到, 但要於程式中直接取得相關資訊就不容易,
因為需要將 WRKOBJLCK OBJ(xxx/xxx) OBJTYPE(XXX) OUTPUT(*PRINT) 輸出至報表,
再將報表複製至 PF 中,再由程式讀取內容解析相關資訊, 過於麻煩.
我們可以利用系統 API QWCLOBJL 直接取得是哪一作業鎖住物件,並做相對應的動作,
如傳送訊息給鎖住物件的作業, 要該作業退出系統,甚至直接 ENDJOB 終止該作業.
此範例僅發送訊息給該作業的使用者.
File : QCLSRC
Member: CHKOBJLCKC
Type : CLP
Usage : CRTCLPGM CHKOBJLCKC
CALL CHKOBJLCKC ('object-name' 'object-library' 'object-type' 'member-name')
只有針對 PF 的 member 時,才需要指定 membername, 其他物件只要給空白即可.
PGM PARM(&OBJ &LIB &OBJTYPE &MBRNAME)
DCL VAR(&OBJ) TYPE(*CHAR) LEN(10)
DCL VAR(&LIB) TYPE(*CHAR) LEN(10)
DCL VAR(&OBJTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&MBRNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&USRSPC) TYPE(*CHAR) LEN(20)
DCL VAR(&EXTATR) TYPE(*CHAR) LEN(10)
DCL VAR(&INITSIZE) TYPE(*CHAR) LEN(4)
DCL VAR(&INITVALUE) TYPE(*CHAR) LEN(1)
DCL VAR(&PUBAUTH) TYPE(*CHAR) LEN(10)
DCL VAR(&TEXT) TYPE(*CHAR) LEN(50)
DCL VAR(&ERRCODE) TYPE(*CHAR) LEN(8)
DCL VAR(&QUALOBJ) TYPE(*CHAR) LEN(20)
DCL VAR(&POS) TYPE(*CHAR) LEN(4)
DCL VAR(&LEN) TYPE(*CHAR) LEN(4)
DCL VAR(&TEMP) TYPE(*CHAR) LEN(4)
DCL VAR(&OFFSET) TYPE(*DEC) LEN(10 0)
DCL VAR(&ENTCOUNT) TYPE(*DEC) LEN(10 0)
DCL VAR(&ENTSIZE) TYPE(*DEC) LEN(10 0)
DCL VAR(&ENTRY) TYPE(*CHAR) LEN(64)
DCL VAR(&JOB) TYPE(*CHAR) LEN(10)
DCL VAR(&USER) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
DCL VAR(&LOCKSTATE) TYPE(*CHAR) LEN(10)
DCL VAR(&LOCKSTATUS) TYPE(*DEC) LEN(10 0)
DCL VAR(&LOCKTYPE) TYPE(*DEC) LEN(10 0)
DCL VAR(&MBRNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&SHARE) TYPE(*CHAR) LEN(1)
DCL VAR(&SCOPE) TYPE(*CHAR) LEN(1)
DCL VAR(&THREAD) TYPE(*CHAR) LEN(8)
/********************************************************** +
* CREATE A USER SPACE TO STORE THE LIST OF JOBS THAT ARE +
* LOCKING AN OBJECT. +
************************************************************/
CHGVAR VAR(%BIN(&INITSIZE)) VALUE(65536)
CHGVAR VAR(&INITVALUE) VALUE(X'00')
CHGVAR VAR(&USRSPC) VALUE('OBJLOCKS QTEMP')
CHGVAR VAR(&EXTATR) VALUE('MYPGM')
CHGVAR VAR(&PUBAUTH) VALUE('*EXCLUDE')
CHGVAR VAR(&TEXT) VALUE('USER SPACE TO CONTAIN OUTPUT +
FROM QWCLOBJL API')
CHGVAR VAR(%BIN(&ERRCODE 1 4)) VALUE(0)
CALL PGM(QUSCRTUS) PARM(&USRSPC +
&EXTATR +
&INITSIZE +
&INITVALUE +
&PUBAUTH +
&TEXT +
'*YES' +
&ERRCODE )
/********************************************************** +
* TELL THE QWCLOBJL API TO PUT A LIST OF LOCKS FOR THE +
* GIVEN OBJECTS INTO THE USER SPACE +
************************************************************/
CHGVAR VAR(&QUALOBJ) VALUE(&OBJ *CAT &LIB)
CHGVAR VAR(%BIN(&ERRCODE 1 4)) VALUE(0)
CALL PGM(QWCLOBJL) PARM(&USRSPC +
'OBJL0100' +
&QUALOBJ +
&OBJTYPE +
&MBRNAME +
&ERRCODE )
/********************************************************** +
* RETRIEVE INFORMATION ABOUT WHERE THE LIST ENTRIES ARE +
* LOCATED IN THE USER SPACE +
* +
* POSITION 125-128 = OFFSET TO THE LIST DATA +
* 133-136 = NUMBER OF ENTRIES IN LIST +
* 137-140 = SIZE OF EACH LIST ENTRY +
************************************************************/
CHGVAR VAR(%BIN(&POS)) VALUE(125)
CHGVAR VAR(%BIN(&LEN)) VALUE(4)
CALL PGM(QUSRTVUS) PARM(&USRSPC &POS &LEN &TEMP)
CHGVAR VAR(&OFFSET) VALUE(%BIN(&TEMP))
CHGVAR VAR(%BIN(&POS)) VALUE(133)
CALL PGM(QUSRTVUS) PARM(&USRSPC &POS &LEN &TEMP)
CHGVAR VAR(&ENTCOUNT) VALUE(%BIN(&TEMP))
CHGVAR VAR(%BIN(&POS)) VALUE(137)
CALL PGM(QUSRTVUS) PARM(&USRSPC &POS &LEN &TEMP)
CHGVAR VAR(&ENTSIZE) VALUE(%BIN(&TEMP))
/********************************************************** +
* READ THE LIST OF ENTRIES FROM THE USER SPACE +
************************************************************/
CHGVAR VAR(%BIN(&POS)) VALUE(1 + &OFFSET)
CHGVAR VAR(%BIN(&LEN)) VALUE(64) /* SIZE OF &ENTRY VAR */
LOOP: IF (&ENTCOUNT *GT 0) DO
/* READ A SINGLE ENTRY FROM THE USER SPACE */
CALL PGM(QUSRTVUS) PARM(&USRSPC &POS &LEN &ENTRY)
CHGVAR VAR(&JOB) VALUE(%SST(&ENTRY 1 10))
CHGVAR VAR(&USER) VALUE(%SST(&ENTRY 11 10))
CHGVAR VAR(&JOBNBR) VALUE(%SST(&ENTRY 21 6))
CHGVAR VAR(&LOCKSTATE) VALUE(%SST(&ENTRY 27 10))
CHGVAR VAR(&LOCKSTATUS) VALUE(%BIN(&ENTRY 37 4))
CHGVAR VAR(&LOCKTYPE) VALUE(%BIN(&ENTRY 41 4))
CHGVAR VAR(&MBRNAME) VALUE(%SST(&ENTRY 45 10))
CHGVAR VAR(&SHARE) VALUE(%SST(&ENTRY 55 1))
CHGVAR VAR(&SCOPE) VALUE(%SST(&ENTRY 56 1))
CHGVAR VAR(&THREAD) VALUE(%SST(&ENTRY 57 8))
/* AT THIS POINT, THE FIELDS ABOVE SHOULD BE CORRECT +
FOR ONE OF THE JOBS IN THE LIST. YOU CAN NOW +
ISSUE A SNDMSG, SNDBRKMSG OR ENDJOB AS NEEDED */
/* FOR EXAMPLE: */
SNDMSG MSG('YOU HAVE 5 SECONDS TO GET OUT OF THAT +
PROGRAM, BUDDY.') TOUSR(&USER)
SNDPGMMSG MSG( &JOBNBR *CAT '/' *CAT +
&USER *TCAT '/' *CAT +
&JOB *BCAT 'LOCK OBJECT' *BCAT +
&LIB *TCAT '/' *CAT +
&OBJ *BCAT '.')
/* ENDJOB JOB(&JOBNBR/&USER/&JOB) OPTION(*CNTRLD) DELAY(5) */
/* MONMSG MSGID(CPF1362 CPF1363) */
/* ADVANCE TO NEXT ENTRY IN LIST */
CHGVAR VAR(%BIN(&POS)) VALUE(%BIN(&POS) + &ENTSIZE)
CHGVAR VAR(&ENTCOUNT) VALUE(&ENTCOUNT - 1)
GOTO LOOP
ENDDO
/* DELETE THE USER SPACE, WE'RE DONE! */
CALL PGM(QUSDLTUS) PARM(&USRSPC &ERRCODE)
ENDPGM
2005-06-29 如何立即判斷 AS/400 物件是否有被設定日誌(journal)功能 ?(Command CHKOBJJRN with API QUSROBJD)
如何立即判斷 AS/400 物件是否有被設定日誌(journal)功能 ?(Command CHKOBJJRN with API QUSROBJD)
前一期是從 Journal 來產生該 Journal 針對哪些物件(PF, Data Queue, Data Area) 做日誌記錄,
本期直接透過 API QUSROBJD 來判斷單一物件是否有啟動日誌功能。
File : QRPGLESRC
Member: CHKOBJJRNR
Type : RPGLE
Usage : CRTBNDRPG CHKOBJJRNR
**
** Program . . : CHKOBJJRNR
** Description : Check Object journaled or not
** Author . . : Vengoal Chang
** Published . : Dimerco Data System Corporation
** Date . . . : June 15, 2005
**
**
** Program summary
** ---------------
**
** Parameters:
** INPUT PxObjNam Object name, the object for which to
** check journaled or not.
**
** INPUT PxObjLib Object library.
**
** OUTPUT PxRtnJrn Journal library and journal name
** Value: If object wasn't journal,
** Return NONE
**
** Object - User space APIs:
** QUSROBJD Retrieve Object Description with OBJD0400 format.
**
**
** Programmer's notes:
** This program checks object journed or not.
**
**
** Compile options:
**
** CrtBndRpg Pgm( CHKOBJJRNR) SrcFile(lib/QRPGLESRC)
** SrcMbr( CHKOBJJRNR ) DbgView( *List )
** **
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) DftActGrp(*NO) Debug
**-- System information: -----------------------------------------------**
D ApiFmtTyp S 8 Based( NulPtrTyp )
D ChrTyp S 1 Based( NulPtrTyp )
D IntTyp S 10I 0 Based( NulPtrTyp )
D LglTyp S 1N Based( NulPtrTyp )
D NamTyp S 10 Based( NulPtrTyp )
D QNamTyp S 20 Based( NulPtrTyp )
D TxtTyp S 50 Based( NulPtrTyp )
D sndpgmmsg PR
D peMsgID 7A const
D peMsgDta 256A const
D outMsgType 10A const
*---------------------------------------------------------------------
* Does the object exist?
*---------------------------------------------------------------------
D ObjExists Pr Like( LglTyp )
D ObjNam Like( NamTyp ) Value
D ObjLib Like( NamTyp ) Value
* Name, *CURLIB, or *LIBL
D ObjTyp Like( NamTyp ) Value
*---------------------------------------------------------------------
* Get the description of an object
*---------------------------------------------------------------------
D GetObjDsc Pr Like( LglTyp )
D ObjNam Like( NamTyp ) Value
D ObjLib Like( NamTyp ) Value
* Name, *CURLIB, or *LIBL
D ObjTyp Like( NamTyp ) Value
D DscFmt Like( ApiFmtTyp ) Value
D ObjDsc Like( ObjDscDs )
* Description formats
D BrfObjDscFmt C 'OBJD0200'
D DtlObjDscFmt C 'OBJD0400'
* Object description returned
D ObjDscDs Ds Inz
* BrfObjDscFmt
D ObjDscLen Like( IntTyp )
D ObjDscSiz Like( IntTyp )
D ObjNam Like( NamTyp )
D ObjLib Like( NamTyp )
D ObjTyp Like( NamTyp )
D ObjRtnLib Like( NamTyp )
D ObjAsp Like( IntTyp )
D ObjOwnr Like( NamTyp )
D ObjDmn 2
D ObjCrtDat 7
D ObjCrtTim 6
D ObjChgDat 7
D ObjChgTim 6
D ObjAtr Like( NamTyp )
D ObjTxt Like( TxtTyp )
D ObjSrcFil Like( NamTyp )
D ObjSrcLib Like( NamTyp )
D ObjSrcMbr Like( NamTyp )
* DtlObjDscFmt
D ObjSrcChgDat 7
D ObjSrcChgTim 6
D ObjSavDat 7
D ObjSavTim 6
D ObjRstDat 7
D ObjRstTim 6
D ObjCrtUsr Like( NamTyp )
D ObjCrtSys 8
D ObjResDat 7
D ObjSavSiz Like( IntTyp )
D ObjSavSeq Like( IntTyp )
D ObjStg Like( NamTyp )
D ObjSavCmd Like( NamTyp )
D ObjSavVolId 71
D ObjSavDvc Like( NamTyp )
D ObjSavFil Like( NamTyp )
D ObjSavLib Like( NamTyp )
D ObjSavLbl 17
D ObjSavLvl 9
D ObjCompiler 16
D ObjLvl 8
D ObjUsrChg Like( ChrTyp )
D ObjLicPgm 16
D ObjPtf Like( NamTyp )
D ObjApar Like( NamTyp )
D ObjUseDat 7
D ObjUsgInf Like( ChrTyp )
D ObjUseDay Like( IntTyp )
D ObjSiz Like( IntTyp )
D ObjSizMlt Like( IntTyp )
D ObjCprSts Like( ChrTyp )
D ObjAlwChg Like( ChrTyp )
D ObjChgByPgm Like( ChrTyp )
D ObjUsrAtr Like( NamTyp )
D ObjOvrflwAsp Like( ChrTyp )
D ObjSavActDat 7
D ObjSavActTim 6
D ObjAudVal Like( NamTyp )
D ObjPrmGrp Like( NamTyp )
D ObjJrnSts Like( ChrTyp )
D ObjJrnNam Like( NamTyp )
D ObjJrnLib Like( NamTyp )
D ObjJrnImg Like( ChrTyp )
D ObjJrnEntOmt Like( ChrTyp )
D ObjJrnStrDat 13
D ObjDgtSgn Like( ChrTyp )
D ObjSavUnt Like( IntTyp )
D ObjSavMul Like( IntTyp )
D ObjLibAsp Like( IntTyp )
D ObjAspDev Like( NamTyp )
D ObjLibAspDev Like( NamTyp )
D ObjDgtSgnSrc Like( ChrTyp )
D ObjDgtSgnMor Like( ChrTyp )
**-- Parameters: -------------------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxRtnJrn s 20a
**
D ExistLgl S 1N
D PeMsg S 256
C *Entry Plist
C Parm PxObjNam
C Parm PxObjLib
C Parm PxObjTyp
C* Parm PxRtnJrn
C If GetObjDsc( PxObjNam: PxObjLib:
C PxObjTyp: DtlObjDscFmt:
C ObjDscDs )
C If ObjJrnLib <> *blanks
C Eval PeMsg = 'Object ' + %trim(ObjRtnLib) +
C '/' + %trim(PxObjNam) +
C ' with type ' + %trim(PxObjTyp) +
C ' journaled by Journal ' +
C %trim(ObjJrnLib) + '/' +
C %trim(ObjJrnNam)
C Eval PxRtnJrn = ObjJrnLib + ObjJrnNam
C Else
C Eval PeMsg = 'Object ' + %trim(ObjRtnLib) +
C '/' + %trim(PxObjNam) +
C ' with type ' + %trim(PxObjTyp) +
C ' wasn''t journaled'
C Eval PxRtnJrn = 'NONE'
C EndIf
C callp sndpgmmsg('CPF9898' : PeMsg : '*INFO')
C EndIf
C* dump
C
C Return
*==================================================================
P ObjExists B
*==================================================================
D Pi Like( LglTyp )
D ObjNam Like( NamTyp ) Value
D ObjLib Like( NamTyp ) Value
* Name, *CURLIB, or *LIBL
D ObjTyp Like( NamTyp ) Value
C Return GetObjDsc( ObjNam: ObjLib:
C ObjTyp: BrfObjDscFmt:
C ObjDscDs )
P E
*=====================================================================
P GetObjDsc B
*====================================================================
D Pi Like( LglTyp )
D ObjNam Like( NamTyp ) Value
D ObjLib Like( NamTyp ) Value
* Name, *CURLIB, or *LIBL
D ObjTyp Like( NamTyp ) Value
D DscFmt Like( ApiFmtTyp ) Value
D ObjDsc Like( ObjDscDs )
D QObjNam S Like( QNamTyp )
D BrfObjDscSiz C 180
D DtlObjDscSiz C %Size( ObjDscDs )
**-- Api error data structure: ----------------------------------
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 256a
C Reset ObjDscDs
C Eval QObjNam = ObjNam + ObjLib
C If DscFmt = BrfObjDscFmt
C Eval ObjDscSiz = BrfObjDscSiz
C Else
C Eval ObjDscSiz = DtlObjDscSiz
C EndIf
C Eval ObjDsc = ObjDscDs
C Call 'QUSROBJD'
C Parm ObjDsc
C Parm ObjDscSiz
C Parm DscFmt
C Parm QObjNam
C Parm ObjTyp
C Parm ApiError
C If AeBytAvl > *Zero
C callp sndpgmmsg(AeMsgID: AeMsgDta : '*ESCAPE')
C EndIf
C Return ( AeBytAvl = 0 )
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This ends this program abnormally, and sends back an escape.
* message explaining the failure.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P sndpgmmsg B
D sndpgmmsg PI
D peMsgID 7A const
D peMsgDta 256A const
D outMsgType 10A const
D QMHSNDPM PR ExtPgm('QMHSNDPM')
D MessageID 7A Const
D QualMsgF 20A Const
D MsgData 256A Const
D MsgDtaLen 10I 0 Const
D MsgType 10A Const
D CallStkEnt 10A Const
D CallStkCnt 10I 0 Const
D MessageKey 4A
D ErrorCode 32766A options(*varsize)
D dsEC DS
D dsECBytesP 1 4I 0 INZ(256)
D dsECBytesA 5 8I 0 INZ(0)
D dsECMsgID 9 15
D dsECReserv 16 16
D dsECMsgDta 17 256
D wwMsgLen S 10I 0
D wwTheKey S 4A
c eval wwMsgLen = %len(%trimr(peMsgDta))
c if wwMsgLen<1
c return
c endif
c callp QMHSNDPM (PeMsgID : 'QCPFMSG *LIBL':
c peMsgDta: wwMsgLen: %trim(outMsgType):
c '*PGMBDY': 1: wwTheKey: dsEC)
c return
P E
File : QCMDSRC
Member: CHKOBJJRN
Type : CMD
Usage : CRTCMD CMD(CHKOBJJRN) PGM(CHKOBJJRNR)
/********************************************************************/
/* Title: CHKOBJJRN : Check Object Journaled or not */
/* */
/* Author: Vengoal Chang */
/* Date : June 15,2005 */
/* */
/* The Create Command command should include the following: */
/* */
/* CRTCMD CMD(CHKOBJJRN) PGM(CHKOBJJRNR) */
/* */
/********************************************************************/
/*------------------------------------------------*/
/* Command Definition */
/*------------------------------------------------*/
CMD PROMPT('Check Object Journaled')
PARM KWD(OBJECT) TYPE(*NAME) LEN(10) MIN(1) +
EXPR(*YES) PROMPT('Object')
PARM KWD(LIBRARY) +
TYPE(*NAME) +
LEN(10) +
DFT(*LIBL) +
SPCVAL( +
(*LIBL ) +
(*CURLIB *CURLIB )) +
EXPR(*YES) +
PROMPT('Library')
PARM KWD(OBJTYPE) +
TYPE(*CHAR) +
LEN(10) +
RSTD(*YES) +
SPCVAL( +
(*ALRTBL *ALRTBL) +
(*AUTL *AUTL) +
(*BNDDIR *BNDDIR) +
(*CFGL *CFGL) +
(*CHTFMT *CHTFMT) +
(*CLD *CLD) +
(*CLS *CLS) +
(*CMD *CMD) +
(*CNNL *CNNL) +
(*COSD *COSD) +
(*CRG *CRG) +
(*CRQD *CRQD) +
(*CSI *CSI) +
(*CSPMAP *CSPMAP) +
(*CSPTBL *CSPTBL) +
(*CTLD *CTLD) +
(*DEVD *DEVD) +
(*DOC *DOC) +
(*DTAARA *DTAARA) +
(*DTADCT *DTADCT) +
(*DTAQ *DTAQ) +
(*EDTD *EDTD) +
(*EXITRG *EXITRG) +
(*FCT *FCT) +
(*FILE *FILE) +
(*FLR *FLR) +
(*FNTRSC *FNTRSC) +
(*FNTTBL *FNTTBL) +
(*FORMDF *FORMDF) +
(*FTR *FTR) +
(*GSS *GSS) +
(*IGCDCT *IGCDCT) +
(*IGCSRT *IGCSRT) +
(*IGCTBL *IGCTBL) +
(*IMGCLG *IMGCLG) +
(*IPXD *IPXD) +
(*JOBD *JOBD) +
(*JOBQ *JOBQ) +
(*JOBSCD *JOBSCD) +
(*JRN *JRN) +
(*JRNRCV *JRNRCV) +
(*LIB *LIB) +
(*LIND *LIND) +
(*LOCALE *LOCALE) +
(*MEDDFN *MEDDFN) +
(*MENU *MENU) +
(*MGTCOL *MGTCOL) +
(*MODD *MODD) +
(*MODULE *MODULE) +
(*MSGF *MSGF) +
(*MSGQ *MSGQ) +
(*M36 *M36) +
(*M36CFG *M36CFG) +
(*NODGRP *NODGRP) +
(*NODL *NODL) +
(*NTBD *NTBD) +
(*NWID *NWID) +
(*NWSD *NWSD) +
(*OUTQ *OUTQ) +
(*OVL *OVL) +
(*PAGDFN *PAGDFN) +
(*PAGSEG *PAGSEG) +
(*PDG *PDG) +
(*PGM *PGM) +
(*PNLGRP *PNLGRP) +
(*PRDDFN *PRDDFN) +
(*PRDLOD *PRDLOD) +
(*PSFCFG *PSFCFG) +
(*QMFORM *QMFORM) +
(*QMQRY *QMQRY) +
(*QRYDFN *QRYDFN) +
(*RCT *RCT) +
(*SBSD *SBSD) +
(*SCHIDX *SCHIDX) +
(*SPADCT *SPADCT) +
(*SQLPKG *SQLPKG) +
(*SQLUDT *SQLUDT) +
(*SRVPGM *SRVPGM) +
(*SSND *SSND) +
(*SVRSTG *SVRSTG) +
(*S36 *S36) +
(*TBL *TBL) +
(*USRIDX *USRIDX) +
(*USRPRF *USRPRF) +
(*USRQ *USRQ) +
(*USRSPC *USRSPC) +
(*VLDL *VLDL) +
(*WSCST *WSCST)) +
MIN(1) +
EXPR(*YES) +
PROMPT('Object type')
星期一, 11月 06, 2023
2004-04-21 如何檢查使用者對某一物件事否有權限 ?
如何檢查使用者對某一物件事否有權限 ?
APIs BY EXAMPLE: CHECK USER AUTHORITY
In this issue of APIs by Example, Carsten Flensburg demonstrates checking a
user's authority to an object.
The first sample program is called CBX5031. It checks to see if a given user
has private authority to an object, such as that provided when a user is
listed in an authorization list. It does not check other sources of
authority.
Here's an example that calls CBX5031 from an ILE RPG program to see if a
user has *ALL authority to object MYLIBRARY/MYOBJECT via an authorization
list:
C Call 'CBX5031'
C Parm 'MYOBJECT' PxObjNam
C Parm 'MYLIBRARY' PxObjLib
C Parm '*AUTL' PxObjTyp
C Parm 'MYUSERID' PxUsrPrf
C Parm '*ALL' PxAut
C Parm PxRtnCod
C if PxRtnCod = '1'
C*** user has authority.
C else
C*** user does not have authority.
C endif
The second sample program is called CBX5032. It checks to see if a given
user has authority to an object. All means of providing authority are taken
into account, including group profiles, adopted authority, *PUBLIC, *ALLOBJ,
and authorization lists.
Here's an example that calls CBX5032 from an ILE RPG program to see if a
user has *USE authority to MYPGM, which is a program that's located in his
library list:
C Call 'CBX5032'
C Parm 'MYPGM' PxObjNam
C Parm '*LIBL' PxObjLib
C Parm '*PGM' PxObjTyp
C Parm 'MYUSERID' PxUsrPrf
C Parm '*USE' PxAut
C Parm PxRtnCod
C if PxRtnCod = '1'
C*** user has authority.
C else
C*** user does not have authority.
C endif
A third sample program, CBX503T, is provided as a demonstration of making
calls to CBX5031 and CBX5032.
The following APIs are demonstrated in this article:
Retrieve User Authority to Object (QSYRUSRA)
http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/qsyrusra.htm
List Users Authorized to Object (QSYLUSRA)
http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/qsylusra.htm
You can download the sample code for this article from
http://www.iseriesnetwork.com/noderesources/code/clubtechcode/ChkUsrAut.zip
The above source code was written by Carsten Flensburg. For questions
regarding this tip, contact Carsten at mailto:flensburg@novasol.dk
CBX5031.RPGLE
**
** Program . . : CBX5031
** Description : Check private authority
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : April 15, 2004
**
**
** Program summary
** ---------------
**
** Parameters:
** INPUT PxObjNam Object name, the object for which to
** check the specified authorization level.
**
** INPUT PxObjLib Object library.
**
** INPUT PxObjTyp Object type.
**
** INPUT PxAut Authorization level to check for.
**
** Valid values:
** *ALL
** *CHANGE
** *USE
** *EXCLUDE
** *AUTLMGT
**
** INPUT PxUsrPrf Name of user profile having it's
** authority checked.
**
** Special values:
** *CURRENT The user currently running
** the job.
**
** *PUBLIC The public authority for
** the specified object is
** checked.
**
** OUTPUT PxRtnCod A boolean value indicating the result
** of the requested action.
**
** Valid return codes:
** 0 = Authority level not found
** 1 = Authority level found
**
** Security API:
** QSYLUSRA List users authorized Creates a list of users having a
** to object private authority to the object
** specified. The list is put into
** a user space.
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
**
** Programmer's notes:
** This program checks if a user holds a private authorization of
** the specified level to an object. No other authorization sources
** are taken into account during the authorization check.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX5031 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX5031 )
** Module( CBX5031 )
**
** **
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsJobUsr 10a Overlay( PgmSts: 254 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- Global variables: -------------------------------------------------**
D Idx s 10i 0
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
**-- Create User Space Parameter: --------------------------------------**
D CuUsrSpcQ Ds
D CuUsrSpcNam 10 Inz( 'AUTLST ' )
D CuUsrSpcLib 10 Inz( 'QTEMP ' )
**-- Entry format USRA0100: --------------------------------------------**
D USRA0100 Ds Based( pLstEnt )
D U1UsrPrf 10a
D U1AutVal 10a
D U1AutLstMgt 1a
D U1ObjOpr 1a
D U1ObjMgt 1a
D U1ObjExs 1a
D U1DtaRead 1a
D U1DtaAdd 1a
D U1DtaUpd 1a
D U1DtaDlt 1a
D U1DtaExe 1a
D 10a
D U1ObjAlt 1a
D U1ObjRef 1a
**-- API format USRA0100: Header information: --------------------------**
D HdrInf Ds Based( pHdrInf )
D HiObjNam 10a
D HiLibNam 10a
D HiObjTyp 10a
D HiOwnNam 10a
D HiAutL 10a
D HiPriGrp 10a
D HiFldAut 1a
D HiAspDevLib 10a
D HiAspDevObj 10a
**-- User Space Generic Header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- Pointers: ---------------------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- List authorized users: --------------------------------------------**
D LstAutUsr Pr ExtPgm( 'QSYLUSRA' )
D LaSpcNamQ 20a Const
D LaFmtNam 8a Const
D LaObjNamQ 20a Const
D LaObjTyp 10a Const
D LaError 32767a Options( *VarSize )
D LaAspDev 10a Options( *NoPass )
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**
D CsDomain 10a Const Options( *NoPass )
**
D CsTfrSizRqs 10i 0 Const Options( *NoPass )
D CsOptSpcAlg 1a Const Options( *NoPass )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Parameters: -------------------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
C *Entry Plist
C Parm PxObjNam
C Parm PxObjLib
C Parm PxObjTyp
C Parm PxUsrPrf
C Parm PxAut
C Parm PxRtnCod
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval PxRtnCod = *Off
**
C If PxUsrPrf = '*CURRENT'
C Eval PxUsrPrf = PsCurUsr
C EndIf
**
C CallP CrtUsrSpc( CuUsrSpcQ
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstAutUsr( CuUsrSpcQ
C : 'USRA0100'
C : PxObjNam + PxObjLib
C : PxObjTyp
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP RtvPtrSpc( CuUsrSpcQ
C : pUsrSpc
C )
**
C ExSr ChkUsrAut
C EndIf
**
C CallP DltUsrSpc( CuUsrSpcQ
C : ApiError
C )
**
C Return
**
**-- Check user authority: ---------------------------------------------**
C ChkUsrAut BegSr
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 to UsNumLstEnt
**
C If U1UsrPrf = PxUsrPrf
C ExSr ChkAutVal
**
C Leave
C EndIf
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Check authority value: --------------------------------------------**
C ChkAutVal BegSr
**
C Select
C When PxAut = '*ALL ' And
C U1AutVal = '*ALL '
**
C Eval PxRtnCod = *On
**
C When PxAut = '*CHANGE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaAdd = 'Y' And
C U1DtaUpd = 'Y' And
C U1DtaDlt = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*USE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*AUTLMGT ' And
C U1AutLstMgt = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*EXCLUDE ' And
C U1AutVal = '*EXCLUDE '
**
C Eval PxRtnCod = *On
C EndSl
**
C EndSr
CBX5032.RPGLE
**
** Program . . : CBX5032
** Description : Check object authority
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : April 15, 2004
**
**
** Program summary
** ---------------
**
** Parameters:
** INPUT PxObjNam Object name, the object for which to
** check the specified authorization level.
**
** INPUT PxObjLib Object library.
**
** INPUT PxObjTyp Object type.
**
** INPUT PxAut Authorization level to check for.
**
** Valid values:
** *ALL
** *CHANGE
** *USE
** *EXCLUDE
** *AUTLMGT
**
** INPUT PxUsrPrf Name of user profile having it's
** authority checked.
**
** Special values:
** *CURRENT The user currently running
** the job.
**
** *PUBLIC The public authority for
** the specified object is
** checked.
**
** OUTPUT PxRtnCod A boolean value indicating the result
** of the requested action.
**
** Valid return codes:
** 0 = Authority level not found
** 1 = Authority level found
**
** Security API:
** QSYRUSRA Retrieve user Returns a specific user's
** authority to object authority for the specified
** object.
**
**
** Programmer's notes:
** This program checks if a user has the specified authority to an
** object. All authorization sources are taken into account during
** the authorization check (group profile(s), adopted authority as
** well as authorization lists, public and *ALLOBJ authority).
**
** The actual source of authority is specified in the returned data
** structure subfield 'U1AutSrc' as a 2-letter code. Please check
** the Security API manual for the details. It can be found online
** here:
**
** http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/qsyrusra.htm
**
**
** Compile options:
**
** CrtRpgMod Module( CBX5032 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX5032 )
** Module( CBX5032 )
**
**
**-----------------------------------------------------------------------**
** Revised . : 00.00.0000
** by . . . :
** Reference :
** Changes . :
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Api Error: --------------------------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- Receiver format USRA0100: -----------------------------------------**
D USRA0100 Ds
D U1BytRtn 10i 0
D U1BytAvl 10i 0
D U1ObjAut 10a
D U1AutLstMgt 1a
D U1ObjOpr 1a
D U1ObjMgm 1a
D U1ObjExs 1a
D U1DtaRead 1a
D U1DtaAdd 1a
D U1DtaUpd 1a
D U1DtaDlt 1a
D U1AutLst 10a
D U1AutSrc 2a
D U1AdpAut 1a
D U1AdpObjAut 10a
D U1AdpAutLstMg 1a
D U1AdpObjOpr 1a
D U1AdpObjMgm 1a
D U1AdpObjExs 1a
D U1AdpDtaRead 1a
D U1AdpDtaAdd 1a
D U1AdpDtaUpd 1a
D U1AdpDtaDlt 1a
D U1AdpDtaExe 1a
D 10a
D U1AdpObjAlt 1a
D U1AdpObjRef 1a
D 10a
D U1DtaExe 1a
D 10a
D U1ObjAlt 1a
D U1ObjRef 1a
D U1AspDevLib 10a
D U1AspDevObj 10a
**-- Retrieve user authority to object: --------------------------------**
D RtvUsrAut Pr ExtPgm( 'QSYRUSRA' )
D RuRcvVar Like( USRA0100 )
D RuRcvVarLen 10i 0 Const
D RuFmtNam 8a Const
D RuUsrPrf 10a Const
D RuObjNamQ 20a Const
D RuObjTyp 10a Const
D RuError 32767a Options( *VarSize )
D RuAspDev 10a Options( *NoPass )
**-- Parameters: -------------------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
C *Entry Plist
C Parm PxObjNam
C Parm PxObjLib
C Parm PxObjTyp
C Parm PxUsrPrf
C Parm PxAut
C Parm PxRtnCod
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval PxRtnCod = *Off
**
C CallP RtvUsrAut( USRA0100
C : %Size( USRA0100 )
C : 'USRA0100'
C : PxUsrPrf
C : PxObjNam + PxObjLib
C : PxObjTyp
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C Select
C When PxAut = '*ALL ' And
C U1ObjAut = '*ALL '
**
C Eval PxRtnCod = *On
**
C When PxAut = '*CHANGE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaAdd = 'Y' And
C U1DtaUpd = 'Y' And
C U1DtaDlt = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*USE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*AUTLMGT ' And
C U1AutLstMgt = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*EXCLUDE ' And
C U1ObjAut = '*EXCLUDE '
**
C Eval PxRtnCod = *On
C EndSl
C EndIf
C
C Return
**
CBX503T.RPGLE
**
** Program . . : CBX503T
** Description : Check authority programs - test
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : April 15, 2004
**
** Test setup:
** Please replace the object name, library and type as well as
** user profile and authorization level to check for, to values
** appropriate for your enviroment in the two call examples below
** prior to compiling this test program.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX503T ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX503T )
** Module( CBX503T )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Send program message: ---------------------------------------------**
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 128a Const
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 10i 0 Const
**-- Send completion message: ------------------------------------------**
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Program parameters: -----------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
**-- Check private authority:
**
C Call 'CBX5031'
C Parm 'QPWFSERVER' PxObjNam
C Parm 'QSYS' PxObjLib
C Parm '*AUTL' PxObjTyp
C Parm 'QSYS' PxUsrPrf
C Parm '*ALL' PxAut
C Parm PxRtnCod
**
C If PxRtnCod = '1'
**
C CallP SndCmpMsg( 'User profile ' +
C %TrimR( PxUsrPrf ) +
C ' has private authority ' +
C %TrimR( PxAut ) +
C ' to object ' +
C %TrimR( PxObjNam ) +
C '.'
C )
**
C Else
C CallP SndCmpMsg( 'User profile ' +
C %TrimR( PxUsrPrf ) +
C ' did not have ' +
C 'private authority ' +
C %TrimR( PxAut ) +
C ' to object ' +
C %TrimR( PxObjNam ) +
C '.'
C )
C EndIf
**
**-- Check object authority:
**
C Call 'CBX5032'
C Parm 'QCMD' PxObjNam
C Parm '*LIBL' PxObjLib
C Parm '*PGM' PxObjTyp
C Parm '*PUBLIC' PxUsrPrf
C Parm '*USE' PxAut
C Parm PxRtnCod
**
C If PxRtnCod = '1'
**
C CallP SndCmpMsg( 'User profile ' +
C %TrimR( PxUsrPrf ) +
C ' has object authority ' +
C %TrimR( PxAut ) +
C ' to object ' +
C %TrimR( PxObjNam ) +
C '.'
C )
**
C Else
C CallP SndCmpMsg( 'User profile ' +
C %TrimR( PxUsrPrf ) +
C ' did not have ' +
C 'object authority ' +
C %TrimR( PxAut ) +
C ' to object ' +
C %TrimR( PxObjNam ) +
C '.'
C )
C EndIf
**
C Eval *InLr = *On
C Return
**
**-- Send completion message: ------------------------------------------**
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
**
C CallP(e) SndPgmMsg( 'CPF9897'
C : 'QCPFMSG *LIBL'
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*COMP'
C : '*PGMBDY'
C : 1
C : MsgKey
C : *Zero
C )
**
C If %Error
C Return -1
**
C Else
C Return 0
C EndIf
**
P SndCmpMsg E
2003-04-29 如何容易的辨別自己所開發的物件版本？(API QLICOBJD)
如何容易的辨別自己所開發的物件版本？(API QLICOBJD)
這是一個利用物件上的使用者定義屬性(user-defined attributes)文字來將物件以
API QLICOBJD 印上註記的簡單程式，你能藉由這個 API 來改變使用者定義屬性文字，
但無法使用 IBM 的指令更改使用者定義屬性文字。
你能利用這個 API 來完成你應用軟體的版本控制，以確保程式是否有重新編譯過。
最好的方式是利用 DSPOBJD 指令，再執行這隻程式將所有物件加印註記，來分辨程式版本。
範例：
DSPOBJD OBJ(SEARCH400/FNDMSG) OBJTYPE(*PGM) OUTPUT(*OUTFILE) OUTFILE(QTEMP/QADSPOBJ)
OVRDBF FILE(QADSPOBJ) TOFILE(QTEMP/QADSPOBJ)
CALL STAMPOBJ
File : QRPGSRC
Member: STAMPOBJ
Type : RPG
Usage : CRTRPGPGM STAMPOBJ
OS Version: all
FQADSPOBJIF E DISK
I 'MY_VERSION' C VERSN
I SDS
I 1 10 @PGM
I 254 263 @USR
C*
ISYSOBJ DS
I 1 10 ODOBNM
I 11 20 ODLBNM
IOUTREC DS
I B 1 40NUMKEY
I B 5 80KEY#
I B 9 120KEYLEN
I 13 22 DATA
I 1 22 ALL
C*
C EXSR INIT
C 1 SETLLQADSPOBJ
C*
C *INLR DOUEQ*ON
C READ QADSPOBJ LR
C* PROCESS RECORDS
C *INLR IFEQ *OFF
C*
C MOVELODOBTP OUTTYP 10 P
C CALL 'QLICOBJD'
C PARM OUTLIB 10
C PARM SYSOBJ
C PARM OUTTYP 10
C PARM ALL
C PARM PERR 40
C END
C END
C*
C*****************************************************************
C* INIT - INITIALIZATION SUBROUTINE *
C*****************************************************************
C*
C INIT BEGSR
C Z-ADD1 NUMKEY
C Z-ADD9 KEY#
C Z-ADD10 KEYLEN
C MOVELVERSN DATA
C ENDSR
C*
執行 DSPOBJD 檢視更改結果
Display Object Description - Full
Library 1 of 1
Object . . . . . . . : FNDMSG Attribute . . . . . : CLP
Library . . . . . : SEARCH400 Owner . . . . . . . : QSECOFR
Library ASP device . : *SYSBAS Primary group . . . : *NONE
Type . . . . . . . . : *PGM
User-defined information:
Attribute . . . . . . . . . . . . : MY_VERSION
Text . . . . . . . . . . . . . . . : FNDMSG command processing program
Creation information:
Creation date/time . . . . . . . . : 03/02/02 14:29:36
Created by user . . . . . . . . . : QSECOFR
System created on . . . . . . . . : S1036846
Object domain . . . . . . . . . . : *USER
More...
Press Enter to continue.
F3=Exit F12=Cancel
(C) COPYRIGHT IBM CORP. 1980, 2002.
訂閱：
文章 (Atom)