|
#8 |
API - Table of Contents |
|
|
|
|
QWCRLCKI: Retrieve Lock Information
QWCRLRQI: Retrieve Lock Request Information
**
** Program . . : CBX144
** Description : Retrieve lock information APIs - sample program
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : September 29, 2005
**
**
** Program summary
** ---------------
**
**
** Work management APIs:
** QWCRLCKI Retrieve lock Generates a list of information
** information about lock holders of the object
** specified.
**
** QWCRLRQI Retrieve lock request Takes as input a lock request
** information handle that was returned in other
** APIs and returns information
** about the program that requested
** the lock.
**
** This API must be called from the
** same thread that called the API
** that returned the lock request
** handle.
**
** Message handling API:
** 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.
**
** ILE CEE APIs:
** CEERTX Register call stack Registers a procedure that runs
** entry termination when the call stack entry, for
** user exit procedure which it is registered, is ended
** by anything other than a return
** to the caller.
**
** CEEUTX Unregister call stack Unregisters a procedure that was
** entry termination previously registered by the
** user exit procedure CEERTX API.
**
** The CEEUTX API operates on the
** call stack entry termination user
** exits that are registered for the
** call stack entry from which the
** CEEUTX API is called.
**
** MI builtins:
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX144 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX144 )
** Module( CBX146 )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Api error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0 Inz
D MsgId 7a
D 1a
D MsgDta 128a
**-- Global variables:
D Idx s 10u 0
D IdxKey s 10u 0
D ApiRcvSiz s 10u 0
D MsgTxt s 512a Varying
**-- List API parameters:
D LstApi Ds Qualified Inz
D NbrKeyRtn 10i 0 Inz( %Elem( LstApi.KeyFld ))
D KeyFld 10i 0 Dim( 3 )
**-- Global constants:
D OFS_MSGDTA c 16
D NO_RTN_KEY c 0
D TYP_JOBTHR c 0
D TYP_LCKSPC c 1
D ALL_RCD c 0
D OBJ_LVL c 0
D RCD_LVL c 1
**-- Object identification:
D LOBJ0100 Ds Qualified
D ObjIdSiz 10i 0 Inz( %Size( LOBJ0100 ))
D ObjNam 10a
D ObjLib 10a
D ObjLibAps 10a
D ObjTyp 10a
D MbrNam 10a
D 2a Inz( x'0000' )
D RcdLckI 10i 0
D RelRcdNbr 10u 0
**
D LOBJ0200 Ds Qualified
D ObjHdlSiz 10i 0 Inz( %Size( LOBJ0200 ))
D ObjLckHdl 64a
**-- Lock filter:
D LKFL0100 Ds Qualified
D FltSiz 10i 0 Inz( %Size( LKFL0100 ))
D FltLckStt 10i 0 Inz( *Zero )
D FltLckScp 10i 0 Inz( *Zero )
D FltLckSts 10i 0 Inz( *Zero )
D FltLckHlrTyp 1a Inz( '0' )
D FltMbrLckTyp 1a Inz( '0' )
**-- Lock information:
D LCKI0100 Ds Qualified Based( pLckInf )
D BytRtn 10i 0
D BytAvl 10i 0
D TypEnt 10i 0
D ObjNamExt 30a
D ObjLib 10a
D ObjAsp 10a
D ObjLibAsp 10a
D ObjAspNbr 10i 0
D ObjLibAspNbr 10i 0
D ObjTyp 10a
D ExtObjAtr 10a
D NbrLckInfEntA 10i 0
D OfsLckInfEnt 10i 0
D NbrLckInfEntR 10i 0
D LenLckInfEnt 10i 0
**
D LckInfEnt Ds Based( pLckInfEnt ) Qualified
D LckStt 10a
D 2a
D LckSts 10i 0
D LckScp 1a
D 3a
D LckSpcId 20a
D LckRqsHdl 64a
D LckCnt 10i 0
D MbrNam 10a
D MbrLckTyp 1a
D 1a
D RelRcdNbr 10i 0
D DisHlrInf 10i 0
D DisKeyInf 10i 0
D NbrKeyRtn 10i 0
D HlrTyp 10i 0
**-- Key information:
D KeyInf Ds Based( pKeyInf ) Qualified
D FldInfLen 10i 0
D KeyFld 10i 0
D DtaTyp 1a
D 3a
D DtaLen 10i 0
D Data 64a
**-- Lock holder - job/thread format:
D HlrJobThr Ds Based( pJobThrFmt ) Qualified
D HlrInfSiz 10i 0
D JobNam 10a
D UsrNam 10a
D JobNbr 6a
D ThdId 8a
D 2a
D ThdHdl 10u 0
**-- Lock holder - lock space format:
D HlrLckSpc Ds Based( pLckSpcFmt ) Qualified
D HlrInfSiz 10i 0
D HldLckSpcId 20a
D UsrNam 10a
D JobNbr 6a
D ThdId 8a
D 2a
D ThdHdl 10u 0
**-- Lock request identification:
D LRQI0100 Ds 4096 Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D OfsStmIds 10i 0
D NbrStmIds 10i 0
D OfsPrcNam 10i 0
D LenPrcNam 10i 0
D PgmNam 10a
D PgmLib 10a
D PgmAsp 10a
D PgmLibAsp 10a
D PgmAspNbr 10i 0
D PgmLibAspNbr 10i 0
D MiInstNbr 10i 0
D ModNam 10a
D ModLib 10a
**-- API return information:
D PrcNam s 1024a Inz Varying
D StmIds s 10a Inz Dim( 64 )
D pJobThrFmt s * Inz( *Null )
D pLckSpcFmt s * Inz( *Null )
**
D KeyDta Ds Qualified Inz
D ActJobSts 4a
D FcnNam 10a
D MsgRpy 1a
**-- Retrieve lock information:
D RtvLckInf Pr ExtPgm( 'QWCRLCKI' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D ObjId 68a Const Options( *VarSize )
D ObjIdFmt 8a Const
D NbrKeyFld 10i 0 Const
D KeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D Filter 18a Const Options( *VarSize )
D FltFmt 8a Const
D Error 32767a Options( *VarSize )
**-- Retrieve lock request information:
D RtvLckRqsInf Pr ExtPgm( 'QWCRLRQI' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D RqsHdl 64a Const
D Error 32767a Options( *VarSize )
**-- 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 )
**-- Register termination exit:
D CeeRtx Pr ExtProc( 'CEERTX' )
D procedure * ProcPtr Const
D token * Options( *Omit )
D fb 12a Options( *Omit )
**-- Unregister termination exit:
D CeeUtx Pr ExtProc( 'CEEUTX' )
D procedure * ProcPtr Const
D fb 12a Options( *Omit )
**-- Copy memory:
D memcpy Pr * ExtProc( '_MEMMOVE' )
D pOutMem * Value
D pInpMem * Value
D iMemSiz 10u 0 Value
**-- Send completion message:
D SndCmpMsg 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
**-- Send message by type:
D SndMsgTyp Pr 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**-- Terminate program:
D TrmPgm Pr
D pPtr *
**-- Entry parameters:
D SavOfs Ds Based( pNull )
D NbrElm 5i 0
D DatFrm 7a
D TimFrm 6a
**
D CBX144 Pr
D PxObjNam_q 20a
D PxObjTyp 10a
D PxMbrNam 10a
D PxRelRcdNbr 10p 0
**
D CBX144 Pi
D PxObjNam_q 20a
D PxObjTyp 10a
D PxMbrNam 10a
D PxRelRcdNbr 10p 0
/Free
//-- Step 1:
ExSr InzParms;
//-- Step 2a:
ApiRcvSiz = 65535;
pLckInf = %Alloc( ApiRcvSiz );
LCKI0100.BytAvl = *Zero;
DoU LCKI0100.BytAvl <= ApiRcvSiz Or ERRC0100.BytAvl > *Zero;
//-- Step 2b:
If LCKI0100.BytAvl > ApiRcvSiz;
ApiRcvSiz = LCKI0100.BytAvl;
pLckInf = %ReAlloc( pLckInf: ApiRcvSiz );
EndIf;
RtvLckInf( LCKI0100
: ApiRcvSiz
: 'LCKI0100'
: LOBJ0100
: 'LOBJ0100'
: LstApi.NbrKeyRtn
: LstApi.KeyFld
: LKFL0100
: 'LKFL0100'
: ERRC0100
);
EndDo;
//-- Step 3:
CeeRtx( %Paddr( TrmPgm ): pLckInf: *Omit );
If ERRC0100.BytAvl > *Zero;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
);
Else;
//-- Step 4:
ExSr PrcLstEnt;
SndCmpMsg( 'Lock API example completed normally.' );
EndIf;
//-- Step 5:
CeeUtx( %Paddr( TrmPgm ): *Omit );
TrmPgm( pLckInf );
*InLr = *On;
Return;
BegSr InzParms;
LOBJ0100.ObjNam = %Subst( PxObjNam_q: 1: 10 );
LOBJ0100.ObjLib = %Subst( PxObjNam_q: 11: 10 );
LOBJ0100.ObjLibAps = '*';
LOBJ0100.ObjTyp = PxObjTyp;
LOBJ0100.MbrNam = PxMbrNam;
Select;
When PxRelRcdNbr = -1;
LOBJ0100.RcdLckI = RCD_LVL;
LOBJ0100.RelRcdNbr = ALL_RCD;
When PxRelRcdNbr > 0;
LOBJ0100.RcdLckI = RCD_LVL;
LOBJ0100.RelRcdNbr = PxRelRcdNbr;
Other;
LOBJ0100.RcdLckI = OBJ_LVL;
LOBJ0100.RelRcdNbr = 0;
EndSl;
LstApi.KeyFld(1) = 101;
LstApi.KeyFld(2) = 601;
LstApi.KeyFld(3) = 1307;
EndSr;
BegSr PrcLstEnt;
pLckInfEnt = pLckInf + LCKI0100.OfsLckInfEnt;
For Idx = 1 to LCKI0100.NbrLckInfEntR;
If LckInfEnt.LckStt <> '*NONE';
If LckInfEnt.HlrTyp = TYP_JOBTHR;
pJobThrFmt = pLckInfEnt + LckInfEnt.DisHlrInf;
Else;
pLckSpcFmt = pLckInfEnt + LckInfEnt.DisHlrInf;
EndIf;
ExSr GetKeyDta;
RtvLckRqsInf( LRQI0100
: %Size( LRQI0100 )
: 'LRQI0100'
: LckInfEnt.LckRqsHdl
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
ExSr PrcRqsEnt;
EndIf;
// All retrieved data available at this point:
If pJobThrFmt <> *Null;
// Job or thread information retrieved
Else;
// Lock space information retrieved
EndIf;
If Idx < LCKI0100.NbrLckInfEntR;
Reset KeyDta;
Reset StmIds;
Reset PrcNam;
Reset pJobThrFmt;
Reset pLckSpcFmt;
pLckInfEnt += LCKI0100.LenLckInfEnt;
EndIf;
EndIf;
EndFor;
EndSr;
BegSr PrcRqsEnt;
If LRQI0100.OfsPrcNam > *Zero;
PrcNam = %Subst( LRQI0100: LRQI0100.OfsPrcNam: LRQI0100.LenPrcNam );
EndIf;
If LRQI0100.OfsStmIds > *Zero;
memcpy( %Addr( StmIds )
: %Addr( LRQI0100 ) + LRQI0100.OfsStmIds
: LRQI0100.NbrStmIds * %Size( StmIds )
);
EndIf;
EndSr;
BegSr GetKeyDta;
pKeyInf = pLckInfEnt + LckInfEnt.DisKeyInf;
For IdxKey = 1 To LckInfEnt.NbrKeyRtn;
Select;
When KeyInf.KeyFld = 101;
KeyDta.ActJobSts = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
When KeyInf.KeyFld = 601;
KeyDta.FcnNam = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
When KeyInf.KeyFld = 1307;
KeyDta.MsgRpy = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
EndSl;
If IdxKey < LckInfEnt.NbrKeyRtn;
pKeyInf = pKeyInf + KeyInf.FldInfLen;
EndIf;
EndFor;
EndSr;
/End-Free
**-- Send completion message: ------------------------------------------**
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*COMP'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
**
P SndCmpMsg E
**-- 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 message by type: ---------------------------------------------**
P SndMsgTyp B
D Pi 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: PxMsgTyp
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndMsgTyp E
**-- Terminate program: ------------------------------------------------**
P TrmPgm B
D Pi
D pPtr *
/Free
DeAlloc pPtr;
*InLr = *On;
Return;
/End-Free
P TrmPgm E
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CBX144T */
/* Description : Retrieve lock information APIs - test */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : September 29, 2005 */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX144T ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm
Dcl &ObjNam_q *Char 20
Dcl &ObjTyp *Char 10
Dcl &MbrNam *Char 10
Dcl &RelRcdNbr *Dec 10
Dcl &ALL_RCD *Dec 10 -1
Dcl &IGN_RCD *Dec 10 0
/*-- Retrieve object locks: --*/
ChgVar &ObjNam_q '(obj-name)(library )'
ChgVar &ObjTyp '(obj-type)'
ChgVar &MbrNam '*NONE '
ChgVar &RelRcdNbr &IGN_RCD
Call CBX144 Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )
/*-- Retrieve file member locks: --*/
ChgVar &ObjNam_q '(filename)(library )'
ChgVar &ObjTyp '*FILE '
ChgVar &MbrNam '(mbr-name)'
ChgVar &RelRcdNbr &IGN_RCD
Call CBX144 Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )
/*-- Retrieve file record lock - specific record: --*/
ChgVar &ObjNam_q '(filename)(library )'
ChgVar &ObjTyp '*FILE '
ChgVar &MbrNam '(mbr.name)'
ChgVar &RelRcdNbr 27
Call CBX144 Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )
/*-- Retrieve file record locks - all records: --*/
ChgVar &ObjNam_q '(filename)(library )'
ChgVar &ObjTyp '*FILE '
ChgVar &MbrNam '(mbr-name)'
ChgVar &RelRcdNbr &ALL_RCD
Call CBX144 Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )
EndPgm:
EndPgm
Important note: While testing the code included with this article, I ran into
some situations where a system module would get stuck in a loop. The situation
seems to arise when more than 800–1000 locks are held against a specified object,
but it never seems to arise when fewer locks are held.
I have informed IBM of this problem and am waiting for a response. Until this
issue is resolved, please be cautious about running the sample program, to avoid
interfering with the workload in a production system. If you do get stuck in a
loop, you can exit it by pressing System Request and taking Option 2.
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Open list of authorized users
**
** Program . . : EXA511
** Description : Open list of authorized users (QGYOLAUS) API example
** Author . . : Carsten Flensburg
**
**
** Compile and setup instructions:
** CrtRpgMod Module( EXA511 )
** DbgView( *LIST )
**
** CrtPgm Pgm( EXA511 )
** Module( EXA511 )
** ActGrp( *NEW )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
**-- 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
**-- List API parameters:
D LstApi Ds Qualified Inz
D RtnRcdNbr 10i 0
D GrpNam 10a
D SltCri 10a
**-- 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
**-- User information:
D AUTU0100 Ds Qualified
D UsrPrf 10a
D UsrGrpI 1a
D GrpMbrI 1a
**-- Open list of authorized users:
D LstAutUsr Pr ExtPgm( 'QGYOLAUS' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D LstInf 80a
D NbrRcdRtn 10i 0 Const
D FmtNam 8a Const
D SltCri 10a Const
D GrpNam 10a Const
D Error 1024a Options( *VarSize )
**-- Get list entry:
D GetLstEnt 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 )
**-- Entry parameters:
D EXA511 Pr
**
D EXA511 Pi
/Free
LstApi.RtnRcdNbr = 1;
LstApi.SltCri = '*MEMBER';
// LstApi.GrpNam = 'Insert Group Profile'
LstApi.GrpNam = 'NOVAGRPIT';
LstAutUsr( AUTU0100
: %Size( AUTU0100 )
: LstInf
: 1
: 'AUTU0100'
: LstApi.SltCri
: LstApi.GrpNam
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
DoW LstInf.LstSts <> '2' Or LstInf.RcdNbrTot >= LstApi.RtnRcdNbr;
ExSr GetPrfInf;
LstApi.RtnRcdNbr = LstApi.RtnRcdNbr + 1;
GetLstEnt( AUTU0100
: %Size( AUTU0100 )
: LstInf.Handle
: LstInf
: 1
: LstApi.RtnRcdNbr
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
EndDo;
EndIf;
*InLr = *On;
Return;
BegSr GetPrfInf;
// Structure AUTU0100 now contains member user profile information...
EndSr;
/End-Free
Thanks to Carsten Flensburg
|
|
Back
Retrieve authorized users
**
** Program . . : EXA512
** Description : Retrieve authorized users (QSYRAUTU) API example
** Author . . : Carsten Flensburg
**
**
** Compile and setup instructions:
** CrtRpgMod Module( EXA512 )
** DbgView( *LIST )
**
** CrtPgm Pgm( EXA512 )
** Module( EXA512 )
** ActGrp( *NEW )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
**-- 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 variables:
D Idx s 10i 0
D BytAlc s 10i 0
D RcvVar s 65535a Based( pRcvVar )
**-- Global constants:
D PRF_NAM_GT c '0'
D PRF_NAM_GE c '1'
**-- Retrieve API parameters:
D RtvApi Ds Qualified Inz
D GrpNam 10a
D SltCri 10a
**-- List information:
D RtnRcdFbi Ds Qualified Inz
D BytRtn 10i 0
D BytAvl 10i 0
D NbrPrf 10i 0
D EntLen 10i 0
**-- User information:
D AUTU0100 Ds Qualified Based( pAUTU0100 )
D UsrPrf 10a
D UsrGrpI 1a
D GrpMbrI 1a
**-- Retrieve authorized users:
D RtvAutUsr Pr ExtPgm( 'QSYRAUTU' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D RtnRcdFbi 16a
D FmtNam 8a Const
D SltCri 10a Const
D StrPrf 10a Const
D StrPrfOpt 1a Const
D GrpNam 10a Const
D Error 1024a Options( *VarSize )
D EndPrf 10a Const Options( *NoPass )
**-- Entry parameters:
D EXA512 Pr
**
D EXA512 Pi
/Free
RtvApi.SltCri = '*MEMBER';
// RtvApi.GrpNam = 'Insert Group Profile'
RtvApi.GrpNam = 'NOVAGRPIT';
BytAlc = 4096;
pRcvVar = %Alloc( BytAlc );
DoU RtnRcdFbi.BytAvl <= BytAlc;
If RtnRcdFbi.BytAvl > BytAlc;
BytAlc = RtnRcdFbi.BytAvl;
pRcvVar = %ReAlloc( pRcvVar: BytAlc );
EndIf;
RtvAutUsr( RcvVar
: BytAlc
: RtnRcdFbi
: 'AUTU0100'
: RtvApi.SltCri
: '*FIRST'
: PRF_NAM_GE
: RtvApi.GrpNam
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
EndDo;
If ERRC0100.BytAvl = *Zero;
ExSr GetPrfInf;
EndIf;
*InLr = *On;
Return;
BegSr GetPrfInf;
pAUTU0100 = pRcvVar;
For Idx = 1 to RtnRcdFbi.NbrPrf;
// Structure AUTU0100 now contains member user profile information...
If Idx < RtnRcdFbi.NbrPrf;
pAUTU0100 += RtnRcdFbi.EntLen;
EndIf;
EndFor;
EndSr;
/End-Free
Thanks to Carsten Flensburg
|
|
Back
List authorization list IFS objects
**
** Program . . : CBX708
** Description : List authorization list IFS objects
** Author . . : Carsten Flensburg
**
**
** Compile options:
** CrtRpgMod Module( CBX708 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX708 )
** Module( CBX708 )
** ActGrp( QILE )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Global variables:
D Idx s 10u 0
D PthNam s 5000a Varying
**-- Global constants:
D OFS_MSGDTA c 16
D USRSPC c 'AUTLSTOBJ QTEMP'
**-- Api error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0 Inz
D MsgId 7a
D 1a
D MsgDta 128a
**-- API path:
D Qlg_Path_Name Ds Qualified Based( pQlg_Path_Name )
D CcsId 10i 0
D CtrId 2a
D LngId 3a
D 3a
D PthTypI 10i 0
D PthNamLen 10i 0
D PthNamDlm 2a
D 10a
D PthNam 5000a
**-- API header information:
D ApiHdrInf Ds Qualified Based( pHdrInf )
D AutLst 10a
D AutLstLib 10a
D ObjOwn 10a
D ObjPgp 10a
D RsnCod 10i 0
D OfsQsysObj 10i 0
D NbrQsysEnt 10i 0
D NbrQsysObj 10i 0
D OfsQdlsObj 10i 0
D NbrQdlsEnt 10i 0
D NbrQdlsObj 10i 0
D OfsDirEobj 10i 0
D NbrDirEent 10i 0
D NbrDirEobj 10i 0
**-- Authorization list IFS object entry:
D ATLO0210 Ds Qualified Based( pLstEnt )
D OfsPthNam 10i 0
D LenPthNam 10i 0
D ObjTyp 10a
D AutHlr 1a
D ObjOwn 10a
D ObjAtr 10a
D TxtDsc 50a
D ObjPgp 10a
D 1a
D AspDev 10
**-- User space generic header:
D UsrSpcHdr Ds Qualified Based( pUsrSpc )
D OfsHdr 10i 0 Overlay( UsrSpcHdr: 117 )
D OfsLst 10i 0 Overlay( UsrSpcHdr: 125 )
D NumLstEnt 10i 0 Overlay( UsrSpcHdr: 133 )
D SizLstEnt 10i 0 Overlay( UsrSpcHdr: 137 )
**-- User space pointers:
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- Create user space:
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D SpcNamQ 20a Const
D ExtAtr 10a Const
D InzSiz 10i 0 Const
D InzVal 1a Const
D PubAut 10a Const
D Text 50a Const
D Replace 10a Const Options( *NoPass )
D Error 32767a Options( *NoPass: *VarSize )
D Domain 10a Const Options( *NoPass )
**-- Delete user space:
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D SpcNamQ 20a Const
D Error 32767a Options( *VarSize )
**-- Retrieve pointer to user space:
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D SpcNamQ 20a Const
D Pointer *
D Error 32767a Options( *NoPass: *VarSize )
**-- List authorization list objects:
D LstAutLstObj Pr ExtPgm( 'QSYLATLO' )
D SpcNamQ 20a Const
D FmtNam 8a Const
D AutLst 10a Const
D Error 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Entry parameters:
D CBX708 Pr
D PxAutLst 10a
D CBX708 Pi
D PxAutLst 10a
/Free
CrtUsrSpc( USRSPC
: *Blanks
: 65535
: x'00'
: '*CHANGE'
: *Blanks
: '*YES'
: ERRC0100
);
LstAutLstObj( USRSPC
: 'ATLO0210'
: PxAutLst
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
ExSr PrcLstEnt;
Else;
If ERRC0100.BytAvl < OFS_MSGDTA;
ERRC0100.BytAvl = OFS_MSGDTA;
EndIf;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta
: 1
: ERRC0100.BytAvl - OFS_MSGDTA
));
EndIf;
DltUsrSpc( USRSPC: ERRC0100 );
*InLr = *On;
Return;
BegSr PrcLstEnt;
RtvPtrSpc( USRSPC: pUsrSpc );
pHdrInf = pUsrSpc + UsrSpcHdr.OfsHdr;
pLstEnt = pUsrSpc + UsrSpcHdr.OfsLst;
For Idx = 1 to UsrSpcHdr.NumLstEnt;
pQlg_Path_Name = pUsrSpc + ATLO0210.OfsPthNam;
PthNam = %Subst( Qlg_Path_Name.PthNam: 1: Qlg_Path_Name.PthNamLen );
If Idx < UsrSpcHdr.NumLstEnt;
pLstEnt += UsrSpcHdr.SizLstEnt +
( %Size( Qlg_Path_Name ) -
%Size( Qlg_Path_Name.PthNam )) +
Qlg_Path_Name.PthNamLen;
EndIf;
EndFor;
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
Two things are worth mentioning regarding the processing of the list
entries:
- The offset to the path name structure is calculated from the beginning of
the user space, as opposed to the beginning of the list entry.
- The offset to the next list entry is calculated based on the following
variables: API header list entry size + size of fixed part of Path name
structure + Path name length.
Thanks to Carsten Flensburg
|
|
Back
Retrieve Data Area
D QwcRdtAA pr ExtPgm('QWCRDTAA')
D aRcvVar Like(DtaAraRcv)
D aRcvVarLen 10i 0 Const
D aDtaAra 20a Const
D aStrPos 10i 0 Const
D aDtaLen 10i 0 Const
D ApiError Like(ApiError)
D DtaAraRcv ds
D AraBytes 10i 0
D AraBytesOut 10i 0
D AraDtaType 10a
D AraLibrary 10a
D AraLength 10i 0
D AraDecimals 10i 0
D AraValue 2000a
D RtvDtaAra pr 2000a Varying
D iDtaAra 10a Const
D iDtaAraLib 10a Const Options(*NoPass)
D iStrPos 5p 0 Const Options(*NoPass)
D iDtaLen 5p 0 Const Options(*NoPass)
P RtvDtaAra b Export
D RtvDtaAra pi 2000a Varying
D iDtaAra 10a Const
D iDtaAraLib 10a Const Options(*NoPass)
D iStrPos 5p 0 Const Options(*NoPass)
D iDtaLen 5p 0 Const Options(*NoPass)
D wDtaAra s 10a
D wDtaAraLib s 10a
D wStrPos s 5p 0
D wDtaLen s 5p 0
D qDtaAra s 20a
* Prepare all input parameters...
C Eval wDtaAra = iDtaAra
C If %Parms < 2
C Eval wDtaAraLib = '*LIBL'
C Else
C Eval wDtaAraLib = iDtaAraLib
C EndIf
C If %Parms < 3
C Eval wStrPos = 1
C Else
C Eval wStrPos = iStrPos
C EndIf
* Prepare API parameters...
C If wDtaAra = '*LDA' or
C wDtaAra = '*GDA' or
C wDtaAra = '*PDA'
C Eval wDtaAraLib = *Blanks
C EndIf
C Eval qDtaAra = wDtaAra + wDtaAraLib
* Call the API to retrieve the data area...
C Reset ApiError
C CallP QwcRdtAA(DtaAraRcv :
C %Size(DtaAraRcv):
C qDtaAra :
C -1 :
C 2000 :
C ApiError )
* If any errors were detected then return an error flag...
C If AraBytesOut = 0
C Return '*ERROR'
C EndIf
* Return the data area value...
C If %Parms < 4
C Eval wDtaLen = araLength - wStrPos + 1
C Else
C Eval wDtaLen = iDtaLen
C EndIf
C Return %Subst(AraValue : wStrPos : wDtaLen)
P RtvDtaAra e
Thanks to Jonathan Mason
|
|
Back
Export LDIF File (LDAP)
Q: I'm looking for an RPG example of using the QgldExportLdif API. This
API creates a .LDIF file of your entire LDAP on the iSeries so it can be
exported to another iSeries LDAP.
A: Okay, here's an example that I wrote up real quick:
H DFTACTGRP(*NO)
D QgldExportLdif PR Extproc('QgldExportLdif')
D InputData 32767A const options(*varsize)
D InputLen 10I 0 value
D Format 8A const
D ErrorCode 32767A options(*varsize)
D LDIF0100 DS
D File_off 10I 0
D File_len 10I 0
D AdminDN_off 10I 0
D AdminDN_len 10I 0
D AdminPW_off 10I 0
D AdminPW_len 10I 0
D Subtree_off 10I 0
D Subtree_len 10I 0
D File 200C CCSID(13488)
D AdminDN 200C CCSID(13488)
D AdminPW 200C CCSID(13488)
D Subtree 200C CCSID(13488)
D ErrorCode ds
D BytesProv 10I 0 inz(0)
D BytesAvail 10I 0 inz(0)
/free
// Set parameters
// FIXME: Change these to appropriate values!!
File = %ucs2('/tmp/dirsrv_output.ldif');
AdminDN = %ucs2('cn=Administrator');
AdminPW = %ucs2('mySecretPassword');
Subtree = *blanks;
// Calculate offsets
File_off = %addr(file) - %addr(LDIF0100);
AdminDN_off = %addr(AdminDN) - %addr(LDIF0100);
AdminPW_off = %addr(AdminPW) - %addr(LDIF0100);
Subtree_off = %addr(Subtree) - %addr(LDIF0100);
// Calculate lengths
File_len = %len(%trimr(file));
AdminDN_len = %len(%trimr(AdminDN));
AdminPW_len = %len(%trimr(AdminPW));
Subtree_len = 0;
// Call API
QgldExportLdif( LDIF0100
: %size(LDIF0100)
: 'LDIF0100'
: ErrorCode );
*inlr = *on;
/end-free
In this example, it dumps the whole directory server (since I set the
subtree length to zero, it won't do a subtree, it'll do everything) to a
file named /tmp/dirsrv_output.ldif in the IFS.
Obviously, you'll have to change the userid, password and maybe the IFS
filename to be something appropriate for your system.
> Also, if anyone has an RPG example of the QgldImportLdif API that will
> load the .LDIF file into the destination iSeries.
I haven't used QgldImportLdif. (I export it for import into an OpenLDAP2
server, not for another iSeries) but I took a quick peek at the docs, and
they appear to be just about identical to those for QgldExportLdif, so you
might be able to use the same program, just change the prototype name (and
the EXTPROC keyword) from Export to Import.
Note that the contents of the ExtProc() keyword are case-sensitive. Make
sure you capitalize it the same way I did.
Note also that the 2nd parameter to QgldExportLdif is passed by VALUE...
this one was tricky at first, since it doesn't say anything about this in
the IBM docs (unless they've changed them since I wrote this?) You have
to look at the C prototype to know this :)
> I realize that the export and import can be done via iSeries Navigator,
> but I want to do the export and import as scheduled jobs that will run
> unattended during the middle of the night. Any help is greatly
> appreciated.
It's probably also possible from QShell using ldapsearch, but I haven't
tried it. This API seems simpler, actually :)
Thanks to Scott Klement
|
|
Back
List Record Formats - and other DBF API's below
'*---------------------------------------------------------------*
h option(*nodebugio)
'* Program Name: LISTPF Program Author: Tommy Holden *
'* Program Date: 08/09/2004 Program Purpose: *
'*---------------------------------------------------------------*
'* Report Output
FQSysPrt o f 132 Printer OflInd(*InOF)
'* Create User Space API Procedure
DCrtUsrSpc pr ExtPgm('QUSCRTUS')
DCUSQualUSName 20a CONST
DCUSExtAttribut 10a CONST
DCUSInitSize 10I 0 CONST
DCUSInitValue 1a CONST
DCUSPublicAuth 10a CONST
DCUSDescription 50a CONST
DCUSReplace 10a CONST
DErrorCode 32766A options(*varsize)
'* List Record Formats API Procedure
DListRcdFmts pr ExtPgm('QUSLRCD')
d CUSQualUSName 20a Const
d CUSRcdFmt 8a Const
d CUSPFName 20a Const
d OverrideProc 1a Const
d ErrorCode 32766a options(*varsize)
'* List Fields API Procedure
DListFields pr ExtPgm('QUSLFLD')
d CUSFldUSName 20a Const
d CUSRcdFmt 8a Const
d CUSPFName 20a Const
D PFRcdFmt 10a Const
d OverrideProc 1a Const
d ErrorCode 32766a options(*varsize)
'* List Key Fields (QDBRTVFD retrieve file desc)API Procedure
DListFileDesc pr ExtPgm('QDBRTVFD')
d OutputData 32766a Options(*Varsize)
d OutputDataLen 10i 0 Const
d CUSPFNameRet 20a
D PFRcdFmt 8a Const
d CUSPFName 20a Const
D RcdFmt 8a Const
d OverrideProc 1a Const
d System 10a Const
d FormatType 10a Const
d ErrorCode 32766a options(*varsize)
'* List Members API Procedure
DListMembers pr ExtPgm('QUSLMBR')
d CUSMbrUSName 20a Const
d CUSRcdFmt 8a Const
d CUSPFName 20a Const
D Members 10a Const
d OverrideProc 1a Const
d ErrorCode 32766a options(*varsize)
'* List Database Relations API Procedure
DListDBR pr ExtPgm('QDBLDBR')
d CUSDBRUSName 20a Const
d CUSRcdFmt 8a Const
d CUSPFName 20a Const
D Members 10a Const
d RcdFmt 10a Const
d ErrorCode 32766a options(*varsize)
'* List Members Info (QUSRMBRD retrieve member desc)API Procedure
DListMemberInfo pr ExtPgm('QUSRMBRD')
d OutputData 32766a Options(*Varsize)
d OutputDataLen 10i 0 Const
D PFRcdFmt 8a Const
d CUSPFName 20a Const
d Member 10a Const
d OverrideProc 1a Const
d ErrorCode 32766a options(*varsize)
'* ReSend Message API Procedure
D SendMsg PR ExtPgm('QMHRSNEM')
D MsgKey 4A const
D ErrorCode 32766A options(*varsize)
D ToStkEntry 32766A options(*varsize: *nopass)
d ToStkEntryLn 10I 0 const options(*nopass)
D Format 8A const options(*nopass)
D FromEntry * const options(*nopass)
D FromCounter 10I 0 const options(*nopass)
'* Get User Space Pointer API Procedure
D UserSpacePntr PR ExtPgm('QUSPTRUS')
D CUSQualUSName 20A CONST
D CUSPointer *
'* Error Code DS For API Calls
D ErrorDS DS
D dsEC1 10I 0 inz(0)
D dsEC2 10I 0 inz(0)
'* Program Stack DS For API Calls
D StackDS ds
d dsRS_StkCnt 10I 0 inz(2)
D dsRS_StkQual 20A inz('*NONE *NONE')
D dsRS_IDLen 10I 0 inz(7)
D dsRS_StkID 7A inz('*')
'* User Space Header DS
D USHeader ds Based(CUSPointer)
d HdrUserArea 64a
d HdrHdrSize 10i 0
d HdrStrLvl 4a
d HdrFormat 8a
d HdrAPIUsed 10a
d HdrCrtDate 13a
d HdrInfoSts 1a
d HdrSizeOfUS 10i 0
d HdrOffsetToInp 10i 0
d HdrSizeOfInp 10i 0
d HdrOffsetToHdr 10i 0
d HdrSizeOfHdr 10i 0
d HdrOffsetToDtl 10i 0
d HdrSizeOfDtl 10i 0
d HdrNumberOfDtl 10i 0
d HdrEntrySize 10i 0
d HdrCCSID 10i 0
d HdrCountry 2a
d HdrLangID 3a
d HdrSubsetInd 1a
d HdrReserved1 42a
DSaveHdrDS ds
d SavUserArea 64a
d SavHdrSize 10i 0
d SavStrLvl 4a
d SavFormat 8a
d SavAPIUsed 10a
d SavCrtDate 13a
d SavInfoSts 1a
d SavSizeOfUS 10i 0
d SavOffsetToInp 10i 0
d SavSizeOfInp 10i 0
d SavOffsetToHdr 10i 0
d SavSizeOfHdr 10i 0
d SavOffsetToDtl 10i 0
d SavSizeOfDtl 10i 0
d SavNumberOfDtl 10i 0
d SavEntrySize 10i 0
d SavCCSID 10i 0
d SavCountry 2a
d SavLangID 3a
d SavSubsetInd 1a
d SavReserved1 42a
DSav2HdrDS ds
d Sv2UserArea 64a
d Sv2HdrSize 10i 0
d Sv2StrLvl 4a
d Sv2Format 8a
d Sv2APIUsed 10a
d Sv2CrtDate 13a
d Sv2InfoSts 1a
d Sv2SizeOfUS 10i 0
d Sv2OffsetToInp 10i 0
d Sv2SizeOfInp 10i 0
d Sv2OffsetToHdr 10i 0
d Sv2SizeOfHdr 10i 0
d Sv2OffsetToDtl 10i 0
d Sv2SizeOfDtl 10i 0
d Sv2NumberOfDtl 10i 0
d Sv2EntrySize 10i 0
d Sv2CCSID 10i 0
d Sv2Country 2a
d Sv2LangID 3a
d Sv2SubsetInd 1a
d Sv2Reserved1 42a
'* List Record Format Header DS
D RcdFmtHdrPtr s *
DRcdFmtHdrDS ds Based(RcdFmtHdrPtr)
D RcdPFName 10a
D RcdPFLib 10a
D RcdPFType 10a
D RcdPFText 50a
D RcdPFCCSID 10i 0
D RcdPFCrtDate 13a
'* List Record Formats DS
D RcdFmtPtr s *
DRcdFmtDS ds Based(RcdFmtPtr)
D RcdFmtName 10a
D RcdLvlChkID 13a
D RcdReserved 1a
D RcdLength 10i 0
D RcdNumFlds 10i 0
D RcdFmtDesc 50a
D RcdReserved1 2a
D RcdCCSID 10i 0
'* List Fields DS
D FldPtr s *
DLstFldDS ds Based(FldPtr)
D FldName 10a
D FldDataType 1a
D FldUsage 1a
D FldOutBuffPos 10i 0
D FldInBuffPos 10i 0
D FldLength 10i 0
D FldDigits 10i 0
D FldDecimals 10i 0
D FldDesc 50a
D FldEditC 2a
D FldEditWLen 10i 0
D FldEditWord 64a
D FldColHdg1 20a
D FldColHdg2 20a
D FldColHdg3 20a
D FldIntName 10a
D FldAltName 30a
D FldAltLen 10i 0
D FldDBCS# 10i 0
D FldAllowNull 1a
D FldHostVar 1a
D FldDateFormat 4a
D FldDateSep 1a
D FldVarSize 1a
D FldDescCCSID 10i 0
D FldDataCCSID 10i 0
D FldColHCCSID 10i 0
D FldEdtWCCSID 10i 0
D FldUSC2Len 10i 0
D FldDataEncode 10i 0
D FldMaxObjLen 10i 0
D FldPadLen 10i 0
D FldUDTLen 10i 0
D FldUDTName 132a
D FldUDTLib 10a
D FldDLCntl 1a
D FldDLInteg 1a
'* List File Description Header DS
D FDHDS ds
D FDHBytesRet 10i 0
D FDHBytesAvail 10i 0
D FDHMaxKeyLen 5i 0
D FDHKeyCount 5i 0
D FDHReserved 10a
D FDHFormatCnt 5i 0
D KeyRecFmt 10a
D KeyReserve 2a
D Key#OfKeys 5i 0
D KeyReserv1 14a
D KeyInfoOffset 10i 0
'* List Key Information DS
D KeyDS ds
D KeyIntName 10a
D KeyExtName 10a
D KeyDtaType 5i 0
D KeyFldLen 5i 0
D Key#OfDigits 5i 0
D KeyDecPos 5i 0
D KeyAttrFlg 1a
D KeyAltLen 5i 0
D KeyAltName 30a
D KeyReserv3 1a
D KeyAttrFlg1 1a
D KeyReserv4 1a
'* List Members Header DS
D MbrHdrPtr s *
D MbrHdrDS ds Based(MbrHdrPtr)
D MbrQualPF 20a
D MbrPFAttr 10a
D MbrPFText 50a
D #OfMembers 10i 0
D MbrSrcFile1 1a
D MbrRsv 3a
D MbrPFCCSID 10i 0
'* Member Information DS
D MemberDS ds
D MbrBytesRet 10i 0
D MbrBytesAvail 10i 0
D MbrPFName 10a
D MbrPFLib 10a
D MbrName 10a
D MbrFileAttr 10a
D MbrSrcType 10a
D MbrCrtDate 13a
D MbrLSrcChg 13a
D MbrText 50a
D MbrSrcFile 1a
D MbrRemote 1a
D MbrLForPF 1a
D MbrODPShare 1a
D MbrReserved 2a
D MbrCurrRcds 10i 0
D MbrDltRcds 10i 0
D MbrDataSpcSize 10i 0
D MbrAccPthSize 10i 0
D Mbr#BasedOn 10i 0
D MbrChgDate 13a
D MbrSaveDate 13a
D MbrRstDate 13a
D MbrExpDate 7a
D MbrReserv1 6a
D Mbr#DaysUsed 10i 0
D MbrLstUsed 7a
D MbrUseReset 7a
D MbrReserv2 2a
D MbrDtaSpcMult 10i 0
D MbrAccPthMult 10i 0
D MbrOffset1 10i 0
D Mbr1Len 10i 0
D MbrCurrBORcds 10u 0
D MbrDltBORcds 10u 0
D MbrReserv3 6a
D MbrJoinMbr 1a
D MbrAccPthMaint 1a
D MbrSQLType 10a
D MbrReserv4 1a
d MbrAllowRead 1a
D MbrAllowWrite 1a
D MbrAllowUpdate 1a
D MbrAllowDelete 1a
D MbrReserv5 1a
D MbrRcdFrcWrite 10i 0
D MbrMaxPctDlt 10i 0
D MbrInit#Rcds 10i 0
D MbrIncr#Rcds 10i 0
D MbrMaxIncrem 10i 0
D MbrCurIncrem 10u 0
D MbrRcdCapacity 10u 0
D MbrRcdFmtPgm 10a
D MbrRcdFmtLib 10a
D Mbr#Constraint 5i 0
D MbrOffsetConst 10i 0
D MbrReserv6 46a
'* Based On PF DS
D BasedOnDS DS
D BOPFName 10a
D BOPFLib 10a
D BOPFMember 10a
D BORcdFmt 10a
D BORest 41 112a
'* DBR DS
D DBRPtr s *
D DBRDS ds Based(DBRPtr)
d DBRPFName 10a
d DBRPFLib 10a
D DBRDepFile 10a
D DBRDepLib 10a
D DBRDepType 1a
D DBRReserve 3a
D DBRJoinRef# 10i 0
D DBRCstLib 10a
D DBRCstNameLen 10i 0
D DBRCstName 258a
'* Work Fields
DCUSQualUSName s 20a
DCUSFldUSName s 20a
DCUSDBRUSName s 20a
DCUSPFNameRet s 20a
DInputPFName s 20a
DCUSExtAttribut s 10a
DCUSInitSize s 10I 0
DOutputDataLen s 10I 0 inz(32766)
DOutputData s 32766a
DCUSInitValue s 1a
DCUSPublicAuth s 10a
DCUSDescription s 50a
DCUSReplace s 10a
DCUSMbrUSName s 20a
D MbrPtr s *
D Member s 10a Based(MbrPtr)
DFilNam s 10a
DStrPos s 10i 0
DOffset s 10i 0
DTimes s 10i 0
DEndBuf s 5 0
DSeq# s 8 0
D #OfDepFiles s 10i 0
Dtmpdate s d inz(D'1995-01-01') datfmt(*usa/)
Dlines s 132a inz(*All'_')
d OverrideProc s 1a Inz('0')
D Dependancy s 50a
D a s 10i 0
D b s 10i 0
D c s 10i 0
D i s 10i 0
D j s 10i 0
D k s 10i 0
C *Entry PList
C Parm CUSPFName 20
'* Set up Date & Time Output Field...
c movel *date tmpdate
C time utime 6 0
C Eval FilNam=%Subst(CUSPFName:1:10)
'* Create The User Space For The Record Format List
c Eval CUSQualUSName='RCDFMT QTEMP'
c Eval CUSExtAttribut='USRSPC'
c Eval CUSInitSize=1024
c Eval CUSInitValue=x'00'
c Eval CUSPublicAuth='*ALL'
c Eval CUSDescription='Record Formats'
c Eval CUSReplace='*YES'
c CallP(E) CrtUsrSpc(CUSQualUSName:
c CUSExtAttribut:CUSInitSize:
c CUSInitValue:CUSPublicAuth:
c CUSDescription:CUSReplace:
c ErrorDS)
'* Create Failed
c If %Error
c callp SendMsg(*blanks:
c ErrorDS:
c StackDS:
c %size(StackDS):
c 'RSNM0100':
c *NULL:
c 0)
c endif
'* List Record Formats Into User Space
c CallP(E) ListRcdFmts(CUSQualUSName:
c 'RCDL0200':
c CUSPFName:
c OverrideProc:
c ErrorDS)
'* Access The Data via Pointer
c CallP(E) UserSpacePntr(CUSQualUSName:CUSPointer)
c Eval SaveHdrDS=USHeader
c Eval RcdFmtHdrPtr=CUSPointer+SavOffsetToHdr
c + ((a-1) * %Size(RcdFmtHdrDS))
'* Process The Detail Data
c Do SavNumberOfDtli
c Eval RcdFmtPtr=CUSPointer+SavOffsetToDtl
c + ((i-1) * %Size(RcdFmtDS))
C Except Heads
C Except Head1
'* Get Record Format Info Printed
c ExSR RcdFmtSR
'* Get Key Data Info Printed
c ExSR KeyDataSR
'* Get Member Data Info Printed
c ExSR MbrDataSR
c EndDo
'* Terminate
c ExSR Terminate
'* Record Format Information
c RcdFmtSR BegSR
'* Create The User Space For The Field List
c Z-Add 0 Seq#
c Eval CUSFldUSName='FLDLST QTEMP'
c Eval CUSExtAttribut='USRSPC'
c Eval CUSInitSize=1024
c Eval CUSInitValue=x'00'
c Eval CUSPublicAuth='*ALL'
c Eval CUSDescription='Field List'
c Eval CUSReplace='*YES'
c CallP(E) CrtUsrSpc(CUSFldUSName:
c CUSExtAttribut:CUSInitSize:
c CUSInitValue:CUSPublicAuth:
c CUSDescription:CUSReplace:
c ErrorDS)
'* Create Failed
c If %Error
c callp SendMsg(*blanks:
c ErrorDS:
c StackDS:
c %size(StackDS):
c 'RSNM0100':
c *NULL:
c 0)
c endif
'* Create Field List
c CallP(E) ListFields(CUSFldUSName:
c 'FLDL0100':
c CUSPFName:
c RcdFmtName:
c OverrideProc:
c ErrorDS)
'* Access Data via Pointer
c CallP(E) UserSpacePntr(CUSFldUSName:CUSPointer)
c Eval OutputData=*Blanks
'* Process Detail Data
c Do HdrNumberOfDtlj
c Eval FldPtr=CUSPointer+HdrOffsetToDtl
c + ((j-1) * %Size(LstFldDS))
'* Get the Ending Buffer Position
c Eval EndBuf=FldOutBuffPos+(FldLength-1)
'* If Numeric Field Set On Indicator 10
c If FldDataType ='B'
c OR FldDataType='D'
c OR FldDataType='F'
c OR FldDataType='M'
c OR FldDataType='N'
c OR FldDataType='P'
c OR FldDataType='S'
c Eval *In10=*On
c Else
c Eval *In10=*Off
c EndIf
'* Increment the Sequence Number & Write The Details
c Add 10 Seq#
c OF Except Heads
C OF Except Head1
c Except Detail
c Eval *InOF=*Off
c EndDo
'* Save The Number Of Fields For Total Printing
c Z-Add RcdNumFlds FldCnt 10 0
c EndSR
'* Key Data Information
c KeyDataSR BegSR
'* Get The Key Information From API Into Output Variable
c Except KeyHed
c Eval OutputDataLen=32766
c Eval CUSPFNameRet=*Blanks
c CallP(E) ListFileDesc(OutputData:
c OutputDataLen:
c CUSPFNameRet:
c 'FILD0300':
C CUSPFName:
c RcdFmtName:
c OverrideProc:
c '*LCL':
c '*EXT':
c ErrorDS)
'* If Any Errors Occur or No Key Fields Found, Set Number Of Keys To 0
c If OutputData=*Blanks
C OR %Error
c OR %len(%Trim(OutputData))=0
c Eval Key#OfKeys=0
c Else
c MoveL OutputData FDHDS
c EndIf
'* Process Key Information Stored in the OutputData Variable
c Eval StrPos=KeyInfoOffset+1
c Do Key#OfKeys
c Eval KeyDS=%Subst(OutputData:StrPos:
c +%Size(KeyDS))
'* Print Key Information
c OF Except Heads
c OF Except KeyHed
c Except KeyLine
c Eval *InOF=*Off
c Eval StrPos=StrPos+%Size(KeyDS)
c EndDo
c EndSR
'* Member Information
c MbrDataSR BegSR
'* Create The User Space For The Member List
c Except MbrHed
c Eval CUSMbrUSName='MBRLST QTEMP'
c Eval CUSExtAttribut='USRSPC'
c Eval CUSInitSize=1024
c Eval CUSInitValue=x'00'
c Eval CUSPublicAuth='*ALL'
c Eval CUSDescription='MembersList'
c Eval CUSReplace='*YES'
c CallP(E) CrtUsrSpc(CUSMbrUSName:
c CUSExtAttribut:CUSInitSize:
c CUSInitValue:CUSPublicAuth:
c CUSDescription:CUSReplace:
c ErrorDS)
'* Create Failed
c If %Error
c callp SendMsg(*blanks:
c ErrorDS:
c StackDS:
c %size(StackDS):
c 'RSNM0100':
c *NULL:
c 0)
c endif
'* Get Member List
c CallP(E) ListMembers(CUSMbrUSName:
c 'MBRL0100':
c CUSPFName:
c '*ALL':
c OverrideProc:
c ErrorDS)
'* Access Member List via Pointer
c CallP(E) UserSpacePntr(CUSMbrUSName:CUSPointer)
c Eval Sav2HdrDS=USHeader
c Eval MbrHdrPtr=CUSPointer
c Eval MbrHdrPtr=MbrHdrPtr+Sv2OffsetToHdr
C Eval InputPFName=CUSPFName
'* Process The Member List
c Do Sv2NumberOfDtlk
c Eval MbrPtr=CUSPointer+Sv2OffsetToDtl
c + ((k-1) * %Size(Member))
c Eval OutputDataLen=32766
c Eval OverrideProc='0'
'* Retrieve The Member Information via API
c If Member<>*Blanks
c CallP(E) ListMemberInfo(OutputData:
c OutputDataLen:
c 'MBRD0300':
c InputPFName:
c Member:
c OverrideProc:
c ErrorDS)
'* Error During Retrieve The Member Information via API
c If OutputData=*Blanks
C OR %Error
c OR %len(%Trim(OutputData))=0
c Eval Mbr#BasedOn=0
c Else
c MoveL OutputData MemberDS
c EndIf
'* Print Member Information
c OF Except Heads
c OF Except MbrHed
c Except MbrLine
'* If This is a LF, List the Based On PF Information
c If MbrLForPF='1'
c Eval StrPos=384
c If Mbr#BasedOn>0
c SetOn 11
c SetOff 12
c Except BasedOnHdr
c Do Mbr#BasedOn
c Eval BasedOnDS=%Subst(OutputData:StrPos:112)
c Except BasedOnDtl
c Eval StrPos=StrPos+112
c EndDo
c EndIf
'* If This is a PF, List the Dependent File Information
c Else
c SetOn 12
c SetOff 11
c ExSR ListDBRSR
c EndIf
c EndIf
c EndDo
'* Print File Totals
c Except Totals
c EndSR
'* List Database Relations Subroutine
c ListDBRSR BegSR
'* Create The User Space For The DBR List
c Eval CUSDBRUSName='DBRLST QTEMP'
c Eval CUSExtAttribut='USRSPC'
c Eval CUSInitSize=1024
c Eval CUSInitValue=x'00'
c Eval CUSPublicAuth='*ALL'
c Eval CUSDescription='DBR List'
c Eval CUSReplace='*YES'
c CallP(E) CrtUsrSpc(CUSDBRUSName:
c CUSExtAttribut:CUSInitSize:
c CUSInitValue:CUSPublicAuth:
c CUSDescription:CUSReplace:
c ErrorDS)
'* Create Failed
c If %Error
c callp SendMsg(*blanks:
c ErrorDS:
c StackDS:
c %size(StackDS):
c 'RSNM0100':
c *NULL:
c 0)
c endif
'* List DBR Into User Space
c CallP(E) ListDBR(CUSDBRUSName:
c 'DBRL0100':
c CUSPFName:
c '*ALL':
c '*ALL':
c ErrorDS)
'* Access Data via Pointer
c CallP(E) UserSpacePntr(CUSDBRUSName:CUSPointer)
c If HdrNumberOfDtl>0
C Except DBRHeads
c Eval #OfDepFiles=HdrNumberOfDtl
'* Process All Dependancies
c Do HdrNumberOfDtlc
c Eval DBRPtr=CUSPointer+HdrOffsetToDtl
c + ((c-1) * %Size(DBRDS))
'* Load Dependancy Type For Print
c Select
c When DBRDepType='C'
c Eval Dependancy='Constraint'
'*
c When DBRDepType='D'
c Eval Dependancy='Extracted Data'
'*
c When DBRDepType='I'
c Eval Dependancy='Extracted Data(Shared AccPth)'
'*
c When DBRDepType='O'
c Eval Dependancy='Extracted Data(Owned AccPth)'
'*
c When DBRDepType='V'
c Eval Dependancy='SQL View'
'*
c Other
c Eval Dependancy='Unknown'
c EndSL
'* Print Dependent File Information
C Except DBRDtl
c EndDo
c EndIf
c EndSR
'* Termination
c Terminate BegSR
c Eval *InLR=*On
c Return
c EndSR
'* Output Specs...
Oqsysprt e heads 1 03
O 'Date:'
O tmpdate +1
O 40 'File Name:'
o filnam +1
o +1 'In Library:'
o RcdPFLib +1
O 123 'Time:'
O utime 132 ' : : '
'*
O e heads 1
O 42 'Rec. Format:'
O RcdFmtName +1
o RcdPFText +1
O 123 'Page:'
O page z 132
'*
O e heads 0
o lines
'*
O e head1 1
O 8 'Seq. Nbr'
O +1 'Field Name'
O +1 'Description'
O 89 'Buffer Pos.'
O 109 'Attributes'
'*
O e detail 1
o seq# z 8
o FldName +1
o FldDesc +1
o FldOutBuffPos z +1
o +1 '-'
o endbuf z +1
o 10 FldDigits z +1
o 10 FldDataType +0
o 10 FldDecimals +2 ' 0 '
O N10 FldLength z 100
o n10 FldDataType 101
'*
o e keyhed 2 1
O 'Keyed By'
'*
o e keyline 1
O KeyExtName +10
'*
o e mbrhed 2 1
O 'Members In File:'
'*
o e mbrline 1
O Member +10
O MbrText +1
'*
O e BasedOnHdr 1
o 'Based On:'
'*
o e BasedOnHdr 1
o 'Physical File'
o 25 'Library'
o 35 'Member'
o 53 'Record Format'
'*
o e BasedOnDtl 1
o BOPFName
o BOPFLib 27
o BOPFMember 38
o BORcdFmt 49
'*
o e DBRHeads 1
o 'Dependent Files:'
'*
o e DBRHeads 1
o 'File '
o +1 'Library '
o +1 'Dependancy Type'
'*
o e DBRDtl 1
o DBRDepFile
o DBRDepLib +1
o Dependancy +1
'*
o e totals 2 1
o lines
'*
o e totals 1
o 'Number Of Fields:'
o FldCnt 37 ' 0 '
'*
o e totals 1
o 'Number Of Keys:'
o Key#OfKeys 37 ' 0 '
'*
o e totals 1
o 'Number Of Members:'
o #OfMembers 37 ' 0 '
'*
o e 11 totals 1
o 'Number Of Based On Files:'
o Mbr#BasedOn 37 ' 0 '
'*
o e 12 totals 1
o 'Number Of Dependent Files:'
o #OfDepFiles 37 ' 0 '
Thanks to Tommy Holden
|
|
Back
How to tell if the user pressed F3 when a command was running?
This is the code you can use to retrieve the F3/F12.
QWCRTVCA - Retrieve Current Attributes
QWCCCJOB - Change Current Job
d*-------------------------------------------------------------------------
d*.Parameters
d*-------------------------------------------------------------------------
d F3 s 1
d F12 s 1
d*-------------------------------------------------------------------------
d*.API QWCRTVCA
d*-------------------------------------------------------------------------
d** current attributes
d §ca ds
d 9b 0
d**
d 16a
d cancel_key 1
d 3
d**
d 16a
d exit_key 1
d 3
d** current attributes length
d §caŁ s 9b 0 inz(%len(§ca))
d** format name
d §cafmt s 8 inz('RTVC0100')
d** no. of fields to return
d §caflds s 9b 0 inz(2)
d** keys fields to return
d §cakey ds
d** ... cancel key
d 9b 0 inz(301)
d** ... exit key
d 9b 0 inz(503)
d*-------------------------------------------------------------------------
d*.API QWCCCJOB
d*-------------------------------------------------------------------------
d** reset keys
d §cj ds
d 9b 0 inz(2)
d** ... reset cancel key
d 9b 0 inz(1)
d 9b 0 inz(1)
d 1 inz('0')
d** ... reset job key
d 9b 0 inz(2)
d 9b 0 inz(1)
d 1 inz('0')
d**---------------------------------------------------------------
d*.API error std
d**---------------------------------------------------------------
d §apierror ds
d §rr1 1 4b 0 inz(8)
d §rr2 5 8b 0 inz(0)
c*****************************************************************
c*.MAINLINE
c*****************************************************************
c *entry plist
c parm F3
c parm F12
c eval F3 = *off
c eval F12 = *off
c*-------------------------------------------------------------------------
c*.retrieve cancel/exit key
c*-------------------------------------------------------------------------
c call 'QWCRTVCA'
c parm §ca
c parm §caŁ
c parm §cafmt
c parm §caflds
c parm §cakey
c parm §apierror
c*-------------------------------------------------------------------------
c*.reset keys
c*-------------------------------------------------------------------------
c call 'QWCCCJOB'
c parm §cj
c parm §apierror
c*-------------------------------------------------------------------------
c*.return F3 or F12
c*-------------------------------------------------------------------------
c eval F3 = exit_key
c eval F12 = cancel_key
c return
Thanks to Beppe Costagliola
|
|
Back
QGYOLSPL - Open List of Spooled Files
h NoMain
*--------------------------------------------------------------------------------------------
* Program . . : LSTSPLF Author . . : Rick Chevalier
* Date . . . . : 6/04/2002
* Purpose . . : Generate a list of selected spool files
*--------------------------------------------------------------------------------------------
* Modifications: Date/Prgrmmr
*--------------------------------------------------------------------------------------------
* None to this point.
*--------------------------------------------------------------------------------------------
*--------------------------------------------------------------------------------------------
* File definitions
*--------------------------------------------------------------------------------------------
*--------------------------------------------------------------------------------------------
* External procedure prototypes
*--------------------------------------------------------------------------------------------
* Open list of spooled files
d OpnLstSplF Pr ExtPgm('QGY/QGYOLSPL')
d 32000 Receiver variable
d 10i 0 Receiver var length
d 80 List information
d 10i 0 Nbr of rec to retur
d 1024 Sort information
d 1024 Filter information
d 26 Qualified job name
d 8 Format of list
d 256 Error code
*--------------------------------------------------------------------------------------------
* Internal procedure prototypes
*--------------------------------------------------------------------------------------------
d LstSplF Pr 4
d 80 List information
d * Const Receiver variable
d 10i 0 Receiver var length
d 10i 0 Options(*Omit: *NoPass) Nbr of rec to retur
d 26 Options(*Omit: *NoPass) Qualified job name
d 1024 Options(*Omit: *NoPass) Filter information
d 1024 Options(*Omit: *NoPass) Sort information
d 8 Options(*NoPass) Format of list
*--------------------------------------------------------------------------------------------
* LstSplF - Open list of selected spool files
*--------------------------------------------------------------------------------------------
p LstSplF b Export
d LstSplF pi 4
d pLstInf 80
d pRcvVar@ * Const
d pRcvLen 10i 0
d pNbrRtn 10i 0 Options(*Omit: *NoPass)
d pQualJob 26 Options(*Omit: *NoPass)
d pFltrInf 1024 Options(*Omit: *NoPass)
d pSortInf 1024 Options(*Omit: *NoPass)
d pLstFmt 8 Options(*NoPass)
* Variables for optional parameters and pointers
d lsRcvVar s 32000 Based(pRcvVar@)
d lsLstInf ds 80 List information
d liTotRec 10i 0 Inz(0)
d liRecTrn 10i 0 Inz(0)
d liReqHdle 4
d liRecLen 10i 0 Inz(0)
d liInfCmp 1
d liCrtDtTm 13
d liStsInd 1
d liRsv1 1
d liInfRtnLen 10i 0 Inz(0)
d liRec1 10i 0 Inz(0)
d liRsv2 40
d lsNbrRtn s 10i 0 Inz(1)
d lsSortInf ds 1024 Sort information
d siNbrKeys 10i 0 Inz(0)
d siStrPos 10i 0 Inz(0)
d siFldLen 10i 0 Inz(0)
d siDtaTyp 5i 0 Inz(x'00')
d siSrtOrd 1 Inz(x'00')
d siRsv1 1 Inz(x'00')
d lsFltrInf ds 1024 Filter information
d* fiNbrUsr 10i 0
d* fiUsrNme 60
d* fiNbrOutQ 10i 0
d* fiOutQ 100
d* fiFrmType 10
d* fiUsrDta 10
d* fiNbrSts 10i 0
d* fiSplSts 60
d* fiNbrDev 10i 0
d* fiDevNme 60
d lsQualJob s 26
d lsLstFmt s 8 Inz('OSPL0300')
* Error structure
d lsErrCd ds 256
d lsErrPrv 10i 0 Inz(256)
d lsErrAvl 10i 0 Inz(0)
d lsErrID 7
d lsErrDta 132
*--------------------------------------------------------------------------------------------
* Calculations
*--------------------------------------------------------------------------------------------
/Free
// If job information is passed us it
If %Parms > 4 And %Addr(pQualJob) <> *Null;
lsQualJob = pQualJob;
EndIf;
// If filter information is passed us it
If %Parms > 5 And %Addr(pFltrInf) <> *Null;
lsFltrInf = pFltrInf;
EndIf;
// If sort information is passed us it
If %Parms > 6 And %Addr(pSortInf) <> *Null;
lsSortInf = pSortInf;
EndIf;
// If list format value is passed us it
If %Parms > 7 And %Addr(pLstFmt) <> *Null;
lsLstFmt = pLstFmt;
EndIf;
CallP OpnLstSplF(lsRcvVar: pRcvLen: lsLstInf: pNbrRtn: lsSortInf:
lsFltrInf: lsQualJob: lsLstFmt: lsErrCd);
// Place list information into return parameter
pLstInf = lsLstInf;
Return liReqHdle;
/End-Free
p LstSplF e
h nomain
*--------------------------------------------------------------------------------------------
* Program . . : RtvLstEnt Author . . : Rick Chevalier
* Date . . . . : 6/05/2002
* Purpose . . : Retrieve entry or entries from a generated list
*--------------------------------------------------------------------------------------------
* Modifications: Date/Prgrmmr
*--------------------------------------------------------------------------------------------
* None to this point.
*--------------------------------------------------------------------------------------------
* Required Parameter Group:
* 1 Parm 1 Input Char(10)
* 2 Parm 2 Input Dec(5,0)
* 3 Parm 3 Input Binary(4)
* 4 Parm 4 Input *
*--------------------------------------------------------------------------------------------
* Internal procedure prototypes
*--------------------------------------------------------------------------------------------
d RtvLstEnt pr
d 4 List handle
d * Const Receiver variable
d 10i 0 Receiver length
d 10i 0 Records to return
d 10i 0 Starting record
d 80 List information
*--------------------------------------------------------------------------------------------
* External procedure prototypes
*--------------------------------------------------------------------------------------------
d GetLstEnt pr ExtPgm('QGY/QGYGTLE')
d 32000 Receiver variable
d 10i 0 Receiver length
d 4 List handle
d 80 List information
d 10i 0 Records to return
d 10i 0 Starting record
d 256 Error information
*--------------------------------------------------------------------------------------------
* Internal procedure
*--------------------------------------------------------------------------------------------
p RtvLstEnt b export
d RtvLstEnt pi
d LstHdl 4
d RcvVar@ * Const
d RcvLen 10i 0
d NbrToRtn 10i 0
d StartRec 10i 0
d ListInfo 80
d RcvVar s 32000 Based(RcvVar@)
* API standard error structure
d Error ds 256
d Provid 10i 0 Inz(128)
d Avail 10i 0 Inz(0)
d ErrID 7
d ErrData 128 a
/Free
CallP GetLstEnt(RcvVar: RcvLen: LstHdl: ListInfo: NbrToRtn: StartRec:
Error);
/End-Free
p RtvLstEnt e
h BndDir('RMVSPLF') DftActGrp(*No) ActGrp(*Caller)
*--------------------------------------------------------------------------------------------
* Program . . : RMVSPLF Author . . : Rick Chevalier
* Date . . . . : 6/04/2002
* Purpose . . : Remove selected spool files
*--------------------------------------------------------------------------------------------
* Modifications: Date/Prgrmmr
*--------------------------------------------------------------------------------------------
* None to this point.
*--------------------------------------------------------------------------------------------
*--------------------------------------------------------------------------------------------
* File definitions
*--------------------------------------------------------------------------------------------
*--------------------------------------------------------------------------------------------
* External procedure prototypes
*--------------------------------------------------------------------------------------------
* Open list of spooled files
d LstSplF Pr 4
d 80 List information
d * Const Receiver variable
d 10i 0 Receiver var length
d 10i 0 Options(*Omit: *NoPass) Nbr of rec to retur
d 26 Options(*Omit: *NoPass) Qualified job name
d 1024 Options(*Omit: *NoPass) Filter information
d 1024 Options(*Omit: *NoPass) Sort information
d 8 Options(*NoPass) Format of list
* Retrieve additional list entries
d RtvLstEnt pr
d 4 List handle
d * Const Receiver variable
d 10i 0 Receiver length
d 10i 0 Records to return
d 10i 0 Starting record
d 80 List information
* Close list
d CloseList Pr ExtPgm('QGY/QGYCLST')
d 4 Request handle
d 128 Error code
* Process or run a command.
dprccmd pr *
d 32702 Command string
d 1 options(*nopass: *omit) Prompt type
* Send a message to the program message queue.
d SndPgmMsg pr 4
d 7 Message ID
d 20 Qualified msg file
d * Const Message data
d 10 Options(*NoPass) Message type
d 10 Options(*NoPass) Stack entry
d 9b 0 Options(*NoPass) Stack counter
*--------------------------------------------------------------------------------------------
* Internal procedure prototypes
*--------------------------------------------------------------------------------------------
*--------------------------------------------------------------------------------------------
* Data definitions
*--------------------------------------------------------------------------------------------
* Program entry parameter definitions
d pFile s 10
d pJob s 26
d pUsrLst ds 52
d pNbrUsr 5i 0 Overlay(pUsrLst: 1)
d pUsers 50 Overlay(pUsrLst: 3)
d pDltDate s 7
d pOutQLst ds 102
d pNbrOutQ 5i 0 Overlay(pOutQLst: 1)
d pOutQs 100 Overlay(pOutQLst: 3)
d pFrmType s 10
d pUsrDta s 10
d pStsLst ds 52
d pNbrSts 5i 0 Overlay(pStsLst: 1)
d pStatus 50 Overlay(pStsLst: 3)
d pDevLst ds 52
d pNbrDev 5i 0 Overlay(pDevLst: 1)
d pDevices 50 Overlay(pDevLst: 3)
* Parameters for call to SndPgmMsg
d spmMsgID s 7 Inz(' ')
d spmMsgF s 20 Inz(' ')
d spmMsgDta@ s * Inz(%Addr(spmMsgDta))
d spmMsgDta s 1024
d spmMsgTyp s 10 Inz('*INFO')
d spmStkEnt s 10 Inz('*')
d spmStkCtr s 9b 0 Inz(3)
* Parameters for call to LstSplF
d lsRcvVar@ s *
d lsRcvVar s 32000 Receiver variable
d lsRcvLen s 10i 0 Inz(%Size(lsRcvVar)) Receiver var length
d lsLstInf ds 80 List information
d liTotRec 10i 0 Inz(0)
d liNbrRtn 10i 0 Inz(0)
d liReqHdle 4
d liRecLen 10i 0 Inz(0)
d liInfCmp 1
d liCrtDtTm 13
d liStsInd 1
d liRsv1 1
d liInfRtnLen 10i 0 Inz(0)
d liRec1 10i 0 Inz(0)
d liRsv2 40
d lsNbrRtn s 10i 0 Inz(50) Nbr of ent to retur
d lsSortInf ds 1024 Sort parameters
d siNbrKeys 10i 0 Inz(0)
d siStrPos 10i 0 Inz(0)
d siFldLen 10i 0 Inz(0)
d siDtaTyp 5b 0 Inz(x'00')
d siSrtOrd 1 Inz(x'00')
d siRsv1 1 Inz(x'00')
d lsFltrInf s 1024 Filter parameters
d lsQualJob s 26 Qualified job name
d lsLstFmt s 8 Returned list forma
* Returned spool entry information
d spRcvVar@ s *
d spRcvVar ds Based(spRcvVar@)
d spJobNme 10
d spUsrNme 10
d spJobNbr 6
d spSplNme 10
d spSplNbr 10i 0
d spSts 10i 0
d spDteOpn 7
d spTmeOpn 6
d spSplSch 1
d spSysNme 10
d spUsrDta 10
d spFrmType 10
d spOutQ 10
d spOutQLib 10
d spAuxStg 10i 0
d spSplSize 10i 0
d spSizeMlt 10i 0
d spTotPgs 10i 0
d spCpyRmn 10i 0
d spPrty 1
d spRsv1 3
* Error structure
d lsErrCd ds 256
d lsErrPrv 10i 0 Inz(256)
d lsErrAvl 10i 0 Inz(0)
d lsErrID 7
d lsErrDta 132
* Returned list handle
d LstHdl s 4
* Miscellaneous variables
d DltCmd s 32702
d Start s 10i 0 Inz(1)
d x s 10i 0
d y s 10i 0
d EndOfList s n Inz(*Off) End of list flag
d DltEntry s n Inz(*Off) Delete entry flag
d NbrRmv s 10i 0 Number removed
d NbrRead s 10i 0 Number read
d ds 4
d Bin4 10i 0 Convert from 2 to 4
d chrBin4 4 Overlay(Bin4) Substring field
*--------------------------------------------------------------------------------------------
* Calculations
*--------------------------------------------------------------------------------------------
/Free
// Format input parameters for list generation
lsQualJob = pJob;
Bin4 = pNbrUsr;
lsFltrInf = chrBin4;
y = 5;
For x = 1 to pNbrUsr;
%Subst(lsFltrInf: y) = %Subst(pUsers: (x * 10) - 9: 10);
y = y + 12;
EndFor;
Bin4 = pNbrOutQ;
%Subst(lsFltrInf: y) = chrBin4;
y = y + 4;
For x = 1 to pNbrOutQ;
%Subst(lsFltrInf: y) = %Subst(pOutQs: (x * 20) - 19: 20);
y = y + 20;
EndFor;
%Subst(lsFltrInf: y: 10) = pFrmType;
y = y + 10;
%Subst(lsFltrInf: y :10) = pUsrDta;
y = y + 10;
Bin4 = pNbrSts;
%Subst(lsFltrInf: y) = chrBin4;
y = y + 4;
For x = 1 to pNbrSts;
%Subst(lsFltrInf: y) = %Subst(pStatus: (x * 10) - 9: 10);
y = y + 12;
EndFor;
Bin4 = pNbrDev;
%Subst(lsFltrInf: y) = chrBin4;
y = y + 4;
For x = 1 to pNbrDev;
%Subst(lsFltrInf: y) = %Subst(pDevices: (x * 10) - 9: 10);
y = y + 12;
EndFor;
// Begin list generation
lsRcvVar@ = %Addr(lsRcvVar);
LstHdl = LstSplF(lsLstInf: lsRcvVar@: lsRcvLen: lsNbrRtn: lsQualJob:
lsFltrInf);
// If no entries are returned set end of list flag
If liNbrRtn <= 0;
EndOfList = *On;
EndIf;
// Substring return field into it's parts
DoW Not EndOfList;
spRcvVar@ = %Addr(lsRcvVar);
// Process list entries
For x = 1 to liNbrRtn;
// File and date are not selected by the API. Check relationships
// and set delete flag accordingly.
Select;
When pFile = *Blanks or pFile = spSplNme;
Select;
When pDltDate = *Zeros;
DltEntry = *On;
When pDltDate <> *Zeros and spDteOpn < pDltDate;
DltEntry = *On;
When pDltDate <> *Zeros and spDteOpn >= pDltDate;
DltEntry = *Off;
EndSl;
When pFile <> spSplNme;
DltEntry = *Off;
EndSl;
// If entry matches selection criteria remove it
If DltEntry;
DltCmd = 'DLTSPLF FILE(' + %TrimR(spSplNme) + ') JOB(' +
spJobNbr + '/' + %TrimR(spUsrNme) + '/' +
%TrimR(spJobNme) + ') SPLNBR(' + %Char(spSplNbr) +
')';
PrcCmd(DltCmd);
NbrRmv += 1;
EndIf;
spRcvVar@ = spRcvVar@ + liRecLen;
EndFor;
// If list is not complete retrieve next group of list entries
NbrRead += liNbrRtn;
If (NbrRead < liTotRec and liStsInd = '2') or
(liStsInd <> '2' and liStsInd <> '3');
Start = Start + liNbrRtn;
Clear lsRcvVar;
lsNbrRtn = %Size(lsRcvVar)/liRecLen;
CallP RtvLstEnt(LstHdl: lsRcvVar@: lsRcvLen: lsNbrRtn:
Start: lsLstInf);
// If list is complete set end of list flag
Else;
EndOfList = *On;
EndIf;
EndDo;
// Close the list
CallP CloseList(LstHdl: lsErrCd);
// Send completion message
spmMsgDta = %Char(NbrRmv) + ' spool file entries removed.';
CallP SndPgmMsg(spmMsgID: spmMsgF: spmMsgDta@:
spmMsgTyp :spmStkEnt :spmStkCtr);
*InLR = *On;
/End-Free
*--------------------------------------------------------------------------------------------
* Define - Define key lists and parameter lists
*--------------------------------------------------------------------------------------------
c Define BegSr
c *Entry PList
c Parm pFile
c Parm pJob
c Parm pUsrLst
c Parm pDltDate
c Parm pOutqLst
c Parm pFrmType
c Parm pUsrDta
c Parm pStsLst
c Parm pDevLst
c EndSr
h nomain
*--------------------------------------------------------------------------------------------
* Program . . : PRCCMD Author . . : Rick Chevalier
* Date . . . . : 1/19/2000
* Purpose . . : Process or run a command.
*--------------------------------------------------------------------------------------------
* Modifications: Date/Prgrmmr
*--------------------------------------------------------------------------------------------
* None to this point.
*--------------------------------------------------------------------------------------------
* Required Parameter Group:
* 1 Source command string Input Char(*)
* Optional Parameter Group:
* 2 Processing type Input Char(1)
* '0' - Never prompt the command
* '1' - Always prompt the command
* Dft '2' - Prompt the command if selective prompting characters are present in the comman
* '3' - Show help
*--------------------------------------------------------------------------------------------
* Internal procedure prototypes
*--------------------------------------------------------------------------------------------
* Prototype for process command procedure (PrcCmd)
d PrcCmd pr *
d 32702 Command
d 1 options(*nopass: *omit) Prompt type
*--------------------------------------------------------------------------------------------
* External procedure prototypes.
*--------------------------------------------------------------------------------------------
* Send program message.
dsndpgmmsg pr 4
d##_msgid 7
d##_msgf 20
d##_msgdta@ * const
d##_msgtyp 10 options(*nopass) Defaults to *DIAG
*--------------------------------------------------------------------------------------------
* Process command (QCAPCMD) API. Check or run a CL command.
*--------------------------------------------------------------------------------------------
pprccmd b export
dprccmd pi *
d##_cmd 32702
d##_pmttyp 1 options(*nopass: *omit) Default = 2
* 1 Length of source command string Input Binary(4)
* 2 Options control block Input Char(*)
* 3 Options control block length Input Binary(4)
* 4 Options control block format Input Char(8)
* 5 Changed command string Output Char(*)
* 6 Length available for changed command string Input Binary(4)
* 7 Length of changed command string available to return Output Binary(4)
* 8 Error code I/O Char(*)
d##_cmdlen s 9b 0
d##_ocb ds
d ##_typprc 9b 0 inz(2) Type of processing
d ##_dbcs 1 inz('0') DBCS data handling
d ##_pmtact 1 Prompter action
d ##_cmdstx 1 inz('0') Command syntax
d ##_msgkey 4 inz(*blanks) Msg retrieve key
d ##_reserve 9 inz(x'000000000000000000') Reserved
d##_ocblen s 9b 0 inz(20)
d##_ocbfmt s 8 inz('CPOP0100')
d##_chgcmd s 32702
d##_chglen s 9b 0
d##_chgavl s 9b 0 inz(32702)
d##_error ds
d ##_erbp 1 4B 0 inz(128) Bytes provided
d ##_erba 5 8B 0 Bytes available
d ##_erexid 9 15 Exception ID
d ##_erexdta 17 116 Exception data
d##_msgf s 20 inz('QCPFMSG *LIBL ')
* Parameter list for API call.
c qcapcmd plist
c parm ##_cmd
c parm ##_cmdlen
c parm ##_ocb
c parm ##_ocblen
c parm ##_ocbfmt
c parm ##_chgcmd
c parm ##_chglen
c parm ##_chgavl
c parm ##_error
* Determine the length of the command string to process.
c eval ##_cmdlen = %len(%trim(##_cmd))
* Determine the length of the command string to process.
c if (%parms = 2 and %addr(##_pmttyp) = *null) or
c %parms = 1
c eval ##_pmtact = '2'
c else
c eval ##_pmtact = ##_pmttyp
c endif
* Process command.
c call 'QCAPCMD' qcapcmd
* If no error return address of attribute information.
c if ##_erexid = *blanks
c return %addr(##_chgcmd)
* Send error message to job log and return null address.
c else
c callp sndpgmmsg(##_erexid: ##_msgf:
c %addr(##_erexdta))
c return *null
c endif
pprccmd e
h nomain
*--------------------------------------------------------------------------------------------
* Program . . : SNDPGMMSG Author . . : Rick Chevalier
* Date . . . . : 12/11/2000
* Purpose . . : Send a program message.
*--------------------------------------------------------------------------------------------
* Modifications: Date/Prgrmmr
*--------------------------------------------------------------------------------------------
* None to this point.
*--------------------------------------------------------------------------------------------
* Parameter definitions
* 1 Message identifier Input Char(7)
* 2 Qualified message file name Input Char(20)
* 3 Message data or immediate text Input Char(*)
* 4 Message type Input Char(10)
* 5 Call stack counter Input Binary(4)
*--------------------------------------------------------------------------------------------
* Internal procedure prototypes.
*--------------------------------------------------------------------------------------------
dsndpgmmsg pr 4
d##_msgid 7
d##_msgf 20
d##_msgdta@ * const
d##_msgtyp 10 options(*nopass)
d##_stkent 10 options(*nopass)
d##_stkctr 9b 0 options(*nopass)
*--------------------------------------------------------------------------------------------
* Send program message.
*--------------------------------------------------------------------------------------------
psndpgmmsg b export
dsndpgmmsg pi 4
d##_msgid 7
d##_msgf 20
d##_msgdta@ * const
d##_msgtypi 10 options(*nopass)
d##_stkenti 10 options(*nopass)
d##_stkctri 9b 0 options(*nopass)
* Additional API parameters.
* 4 Length of message data or immediate text Input Binary(4)
* 6 Call stack entry Input Char(*) or Pointer
* 7 Call stack counter Input Binary(4)
* 8 Message key Output Char(4)
* 9 Error code I/O Char(*)
* Parameters for Send Program Message (QMHSNDPM) API
d##_msgdta ds 1024 based(##_msgdta@)
d##_dtalen s 9b 0
d##_msgtyp s 10
d##_stkent s 10 inz('*')
d##_stkctr s 9b 0
d##_msgkey s 4
d##_error ds 128
d ##_erbp 1 4B 0 inz(0) Bytes provided
d ##_erba 5 8B 0 inz(0) Bytes available
d ##_erexid 9 15 Exception ID
d ##_erexdta 17 116 Exception data
c eval ##_dtalen = %len(%trimr(##_msgdta))
* If message type is passed use it. If not default to *DIAG.
c if %parms >= 4
c eval ##_msgtyp = ##_msgtypi
c else
c eval ##_msgtyp = '*DIAG'
c endif
* If stack entry is passed use it. If not default to current entry (*).
c if %parms >= 5
c eval ##_stkent = ##_stkenti
c else
c eval ##_stkent = '*'
c endif
* If stack counter is passed use it. If not default to 0.
c if %parms >= 6
c eval ##_stkctr = ##_stkctri
c else
c eval ##_stkctr = 0
c endif
* Send message.
c call 'QMHSNDPM'
c parm ##_msgid
c parm ##_msgf
c parm ##_msgdta
c parm ##_dtalen
c parm ##_msgtyp
c parm ##_stkent
c parm ##_stkctr
c parm ##_msgkey
c parm ##_error
c return ##_msgkey
psndpgmmsg e
Thanks to Rick Chevalier
|
|
Back
QSYLOBJA - List Objects User Is Authorized to, Owns, or Is Primary Group of
**
** Program . . : CBX9562
** Description : List user's objects
** Author . . : Carsten Flensburg
**
**
**
** Compile instructions:
** CrtRpgMod Module( CBX9562 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX9562 )
** Module( CBX9562 )
** ActGrp( *NEW )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts sDs Qualified
D JobUsr 10a Overlay( PgmSts: 254 )
D CurUsr 10a Overlay( PgmSts: 358 )
**-- 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 USR_SPC_Q c 'AUTOBJLST QTEMP'
D OFS_MSGDTA c 16
**-- Global variables:
D Idx s 10i 0
D CntHdl s 20a Inz
**-- Entry format OBJA0100:
D OBJA0100 Ds Qualified Based( pLstEnt )
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
D AutHlr 1a
D ObjOwn 1a
D AspDevLib 10a
D AspDevObj 10a
**-- Entry format OBJA0110:
D OBJA0110 Ds 5120 Qualified Based( pLstEnt )
D OfsPthNam 10i 0
D LenPthNam 10i 0
D ObjTyp 10a
D AutHlr 1a
D ObjOwn 1a
D AspDevNam 10a
**
D Path Ds Qualified Based( pPath )
D PthCcsId 10i 0
D CtrRegId 2a
D LngId 3a
D 3a
D FlgByt 10i 0
D PthNamLen 10i 0
D PthDlm 2a
D 10a
D PthNam 5000a
**
D PthNam s 5000a Varying
**-- API input parameter information:
D InpPrm Ds Qualified Based( pInpPrm )
D UsrSpc 10a
D UsrSpcLib 10a
D FmtNam 8a
D UsrPrf 10a
D ObjTyp 10a
D RtnObj 10a
D CntHdl 20a
D OfsRqsLst 10i 0
D NbrLstEnt 10i 0
D RqsLst 30a
**-- API header information:
D HdrInf Ds Qualified Based( pHdrInf )
D UsrPrf 10a
D CntHdl 20a
D RsnCod 10i 0
**-- User space generic header:
D UsrSpc Ds Qualified Based( pUsrSpc )
D HdrSiz 10i 0 Overlay( UsrSpc: 65 )
D RelLvl 4a Overlay( UsrSpc: 69 )
D FmtNam 8a Overlay( UsrSpc: 73 )
D ApiNam 10a Overlay( UsrSpc: 81 )
D CrtDtm 13a Overlay( UsrSpc: 91 )
D InfSts 1a Overlay( UsrSpc: 104 )
D UsrSpcSiz 10i 0 Overlay( UsrSpc: 105 )
D OfsInp 10i 0 Overlay( UsrSpc: 109 )
D SizInp 10i 0 Overlay( UsrSpc: 113 )
D OfsHdr 10i 0 Overlay( UsrSpc: 117 )
D SizHdr 10i 0 Overlay( UsrSpc: 121 )
D OfsLst 10i 0 Overlay( UsrSpc: 125 )
D SizLst 10i 0 Overlay( UsrSpc: 129 )
D NumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D SizLstEnt 10i 0 Overlay( UsrSpc: 137 )
D LstCcsId 10i 0 Overlay( UsrSpc: 141 )
D CtrRegId 2a Overlay( UsrSpc: 145 )
D LngId 3a Overlay( UsrSpc: 147 )
D SubSetInd 1a Overlay( UsrSpc: 149 )
**-- Space pointers:
D pUsrSpc s * Inz( *Null )
D pInpPrm s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- List user objects:
D LstUsrObj Pr ExtPgm( 'QSYLOBJA' )
D SpcNamQ 20a Const
D FmtNam 8a Const
D UsrPrf 10a Const
D ObjTyp 10a Const
D RtnObj 10a Const
D CntHdl 20a Const
D Error 32767a Options( *VarSize )
D RqsLst 30a Options( *VarSize: *NoPass )
**-- Create user space:
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D SpcNamQ 20a Const
D ExtAtr 10a Const
D InzSiz 10i 0 Const
D InzVal 1a Const
D PubAut 10a Const
D Text 50a Const
D Replace 10a Const Options( *NoPass )
D Error 32767a Options( *NoPass: *VarSize )
D Domain 10a Const Options( *NoPass )
D TfrSizRqs 10i 0 Const Options( *NoPass )
D OptSpcAlg 1a Const Options( *NoPass )
**-- Retrieve pointer to user space:
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D SpcNamQ 20a Const
D Pointer *
D Error 32767a Options( *NoPass: *VarSize )
**-- Delete user space:
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D SpcNamQ 20a Const
D Error 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send completion message:
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
D CBX9562 Pr
D PxUsrPrf 10a
**
D CBX9562 Pi
D PxUsrPrf 10a
/Free
CrtUsrSpc( USR_SPC_Q
: *Blanks
: 65535
: x'00'
: '*CHANGE'
: *Blanks
: '*YES'
: ERRC0100
);
RtvPtrSpc( USR_SPC_Q: pUsrSpc );
DoU CntHdl = *Blanks;
LstUsrObj( USR_SPC_Q
: 'OBJA0100'
: PxUsrPrf
: '*ALL'
: '*OBJOWN'
: CntHdl
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
Else;
ExSr GetUsrObj;
EndIf;
EndDo;
DoU CntHdl = *Blanks;
LstUsrObj( USR_SPC_Q
: 'OBJA0110'
: PxUsrPrf
: '*ALL'
: '*OBJOWN'
: CntHdl
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
Else;
ExSr GetUsrFil;
EndIf;
EndDo;
DltUsrSpc( USR_SPC_Q: 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 )
);
Else;
SndCmpMsg( 'Command completed normally.' );
EndIf;
*InLr = *On;
Return;
BegSr GetUsrObj;
pInpPrm = pUsrSpc + UsrSpc.OfsInp;
pHdrInf = pUsrSpc + UsrSpc.OfsHdr;
pLstEnt = pUsrSpc + UsrSpc.OfsLst;
For Idx = 1 To UsrSpc.NumLstEnt;
If Idx < UsrSpc.NumLstEnt;
pLstEnt += UsrSpc.SizLstEnt;
EndIf;
EndFor;
CntHdl = HdrInf.CntHdl;
EndSr;
BegSr GetUsrFil;
pInpPrm = pUsrSpc + UsrSpc.OfsInp;
pHdrInf = pUsrSpc + UsrSpc.OfsHdr;
pLstEnt = pUsrSpc + UsrSpc.OfsLst;
For Idx = 1 To UsrSpc.NumLstEnt;
pPath = pUsrSpc + OBJA0110.OfsPthNam;
PthNam = %Subst( Path.PthNam: 1: Path.PthNamLen );
If Idx < UsrSpc.NumLstEnt;
pLstEnt += UsrSpc.SizLstEnt + OBJA0110.LenPthNam;
EndIf;
EndFor;
CntHdl = HdrInf.CntHdl;
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 completion message:
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*COMP'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndCmpMsg E
Thanks to Carsten Flensburg
QSYLOBJA - A CLLE version
pgm ( +
&pUsrPrf +
)
dcl &pUsrPrf *char 10
dcl &UsrPrf *char 10
dcl &TempLib *char 10 value( 'QTEMP' )
dcl &qusrspc *char 20
dcl &ErrCod *char 4
dcl &hCont *char 20
dcl &us_hdr *char 150 /* Space header */
dcl &l_hdr *char 34 /* List header */
/* This is a general-purpose field to hold objlck data... */
dcl &us_obje *char 108 /* A single entry */
/* When retrieving *usrspc entries, we need a start position,.. */
dcl &STRPOS *dec 9
/* Loop checking... */
dcl &LoopChk *dec 11 value( 0 )
/* Total objects... */
dcl &tObjOwn *dec 11 value( 0 )
dcl &tObjOwn2 *dec 11 value( 0 )
/* General fields for RUSGENHDR... */
dcl &nbrlste *dec 7
dcl &ists *char 1
dcl &offshdr *char 4
SNDPGMMSG MSG('Begin') TOPGMQ(*EXT) MSGTYPE(*INFO)
chgvar &UsrPrf &pUsrPrf
chgvar &hCont ' '
chgvar &qusrspc ( 'LOBJOWN ' *cat &TempLib )
call QUSCRTUS ( +
&qusrspc +
'TMPLST ' +
x'00001000' +
X'00' +
'*ALL ' +
'Temp list obj owned ' +
'*YES ' +
x'0000000000000000' +
)
QFS_obj:
call QSYLOBJA ( +
&qusrspc +
'OBJA0100' +
&UsrPrf +
'*ALL ' +
'*OBJOWN ' +
&hCont +
x'0000000000000000' +
)
/* Retrieve the initialization data... */
call QUSRTVUS ( +
&qusrspc +
x'00000001' +
x'00000096' +
&us_hdr +
)
chgvar &nbrlste %bin( &us_hdr 133 4 )
chgvar &ists %sst( &us_hdr 104 1 )
chgvar &offshdr %sst( &us_hdr 117 4 )
chgvar %bin( &offshdr ) ( %bin( &offshdr ) + 1 )
call QUSRTVUS ( +
&qusrspc +
&offshdr +
x'00000022' +
&l_hdr +
)
chgvar &hCont %sst( &l_hdr 11 20 )
dmpclpgm
if ( &nbrlste *eq 0 ) do
sndpgmmsg msgid( CPF9898 ) msgf( QCPFMSG ) +
msgdta( 'No objects listed' )
goto Clean_up
enddo
/* Add this count to our total... */
chgvar &tObjOwn ( &tObjOwn + &nbrlste )
chgvar &LoopChk ( &LoopChk + 1 )
if ( &ists *eq 'P' ) do
goto QFS_obj
enddo
SNDPGMMSG MSG('Next') TOPGMQ(*EXT) MSGTYPE(*INFO)
chgvar &hCont ' '
IFS_obj:
call QSYLOBJA ( +
&qusrspc +
'OBJA0110' +
&UsrPrf +
'*ALL ' +
'*OBJOWN ' +
&hCont +
x'0000000000000000' +
)
/* Retrieve the initialization data... */
call QUSRTVUS ( +
&qusrspc +
x'00000001' +
x'00000096' +
&us_hdr +
)
chgvar &nbrlste %bin( &us_hdr 133 4 )
chgvar &ists %sst( &us_hdr 104 1 )
if ( &nbrlste *eq 0 ) do
sndpgmmsg msgid( CPF9898 ) msgf( QCPFMSG ) +
msgdta( 'No IFS objects listed' )
goto Clean_up
enddo
/* Add this count to our total... */
chgvar &tObjOwn2 ( &tObjOwn2 + &nbrlste )
chgvar &LoopChk ( &LoopChk + 1 )
if ( &ists *eq 'P' ) do
goto IFS_obj
enddo
Clean_up:
SNDPGMMSG MSG('End') TOPGMQ(*EXT) MSGTYPE(*INFO)
dmpclpgm
return
endpgm
Thanks to Tom Liotta
|
|
Back
Qp0zGetSysEnv - Get System Level Environment
File : QRPGLESRC
Member : RTVENVVAR
Type : RPGLE
Usage : CRTBNDRPG PGM(RTVENVVAR) TGTRLS(V5R1M0)
H Debug
H OPTION(*NODEBUGIO : *SRCSTMT) DFTACTGRP(*NO) BNDDIR('QC2LE')
**************************************************************************
** This program returns the environment variable's value.
** It is stuffed into the CL variable passed on the 2nd parm.
** CPP for RTVENVVAR CL command.
**************************************************************************
** Template definition used for 2nd parameter
D CL_RTNVAR_T DS based(pNothing_T) QUALIFIED
D nLen 5I 0
D Data 32766A
D RtvEnvVar PR
D envvar 256A
D rtnVar LIKEDS(CL_RTNVAR_T)
D envlvl 4A
D RtvEnvVar PI
D envvar 256A
D rtnVar LIKEDS(CL_RTNVAR_T)
D envlvl 4A
* Get job level env
D Qp0zGetEnv PR * ExtProc('Qp0zGetEnv')
D envvar * VALUE OPTIONS(*STRING)
D nCCSID 10I 0
* Get sys level env
D Qp0zGetSysEnv PR 10I 0 ExtProc('Qp0zGetSysEnv')
D envVarName * VALUE OPTIONS(*STRING)
D rtnBuffer 65535A OPTIONS(*VARSIZE)
D bufLen 10I 0
D nCCSID 10I 0
D reserved * OPTIONS(*OMIT)
D rtnBuffer S 512A
D pRtnBuffer S * Inz
D pEnv S * Inz
D bufLen S 10I 0
D nCCSID S 10I 0 Inz(0)
D nRtn S 10I 0 Inz(0)
C eval *INLR = *ON
C if envlvl = '*JOB'
** Retrieve a pointer to the environment variable's value
C eval pEnv = Qp0zGetEnv(%TRIMR(ENVVAR):nCCSID)
** If nothing came back, then the ENVVAR is bad, so return nothing.
C if pEnv = *NULL
C return
C endif
** Copy the environment variable to the return variable,
** being careful not to overstep the variable's length.
C eval %subst(rtnVar.Data:1:rtnVar.nLen) =
C %str(pEnv)
C else
C eval bufLen = %len(rtnBuffer)
C eval nRtn = Qp0zGetSysEnv(%TRIMR(ENVVAR):
C rtnBuffer :
C bufLen :
C nCCSID :
C *OMIT)
C if nRtn <> 0
C dump
C return
C endif
C eval rtnVar.nLen = bufLen
C eval pRtnBuffer = %addr(rtnBuffer)
C eval %subst(rtnVar.Data:1:bufLen) =
C %str(pRtnBuffer)
C endif
C return
File : QCMDSRC
Member : RTVENVVAR
Type : CMD
Usage : CRTCMD CMD(your-lib/RTVENVVAR) PGM(your-lib/RTVENVVAR) ALLOW(*IPGM *BPGM)
RTVENVVAR: CMD PROMPT('Retrieve Environment Variable')
/* Command processing program is RTVENVVAR */
PARM KWD(ENVVAR) TYPE(*CHAR) LEN(256) MIN(1) +
EXPR(*YES) INLPMTLEN(17) +
PROMPT('Environment variable')
PARM KWD(RTNVAL) TYPE(*CHAR) LEN(1) RTNVAL(*YES) +
VARY(*YES) CHOICE('Environment var return +
value') PROMPT('CL Var. for return value')
PARM KWD(LEVEL) TYPE(*CHAR) LEN(4) RSTD(*YES) +
DFT(*JOB) SPCVAL((*JOB) (*SYS)) +
EXPR(*YES) PMTCTL(*PMTRQS) PROMPT('Level')
File : QCLSRC
Member : RTVENVVARC
Type : CLP
Usage : CRTCLPGM RTVENVVARC
CALL RTVENVVARC
/* Before you run the program run following command to set sample */
/* environment variable for testing: */
/* ADDENVVAR ENVVAR(JOBCLASSPATH) VALUE('.:/java') */
/* ADDENVVAR ENVVAR(SYSCLASSPATH) VALUE('.:/system') LEVEL(*SYS) */
/* After you run the program run following command to reset ENVVAR */
/* RMVENVVAR ENVVAR(JOBCLASSPATH) */
/* RMVENVVAR ENVVAR(SYSCLASSPATH) LEVEL(*SYS) */
/* You can browse spooled file QPPGMDMP under current job for job */
/* and system level value same as we set above */
PGM
DCL &SYSPATH *CHAR 32
DCL &JOBPATH *CHAR 32
RTVENVVAR ENVVAR(JOBCLASSPATH) RTNVAL(&JOBPATH)
RTVENVVAR ENVVAR(SYSCLASSPATH) RTNVAL(&SYSPATH) +
LEVEL(*SYS)
DMPCLPGM
ENDPGM
Thanks to Vengoal Chang
|
|
Back
More API's, when I have the time
