|
#7 |
API - Table of Contents |
#9 |
|
|
|
Spool File APIs
****************************************************************
* Description.. Get and Put Spooled File API Example *
* Program Name. SPLFAPI *
* Author....... Bradley V. Stone *
* BVS/Tools - www.bvstools.com *
****************************************************************
D SplfAtt DS
D AtrData 1 3800
*
D APIError DS
D EBytesP 1 4B 0 INZ(40)
D EBytesA 5 8B 0
D EMsgID 9 15
D EReserverd 16 16
D EData 17 56
*
D DS
D Splf#b 1 4B 0
D CSpl# 1 4
*
D SplSpc1 C CONST('SPL001US QTEMP ')
*
D SpcPtr S *
D SpcDes S 50 INZ('User Space Spool APIs')
D SpcName S 20
D SpcAtr S 10
D SpcAut S 10 INZ('*ALL')
D SpcSiz S 9B 0 INZ(32767)
D SpcFormat S 8
D SpcInv S 1
*
D JobName S 26 INZ
D JobID S 26 INZ
D SplFID S 26 INZ
D EndOper S 10 INZ('*WAIT')
D RecLen S 9B 0 INZ(%size(SplfAtt))
D SplfIH S 9B 0
D SplfOH S 9B 0
D #Buff S 9B 0
D Buffer# S 9B 0
D Splf#d S 5 0
*
D File S 10
D Job S 10
D User S 10
D Job# S 6
D Splf#x S 5
****************************************************************
C EXSR $ONE
*
C SETON LR
**************************************************************
* Copy Spooled File To Duplicate Spooled File *
**************************************************************
C $ONE BEGSR
*
C EXSR $RTVSPLFA
C eval SpcName = SplSpc1
C EXSR $CRTSP
C EXSR $CREATESF
C EXSR $OPENSF
C EXSR $GETSF
C EXSR $PUTSF
C EXSR $CLOSESF
C* EXSR $DLTSP
*
C ENDSR
**************************************************************
* Create Spooled File *
**************************************************************
C $CREATESF BEGSR
*
C CALL 'QSPCRTSP'
C PARM SplfOH
C PARM SplfAtt
C PARM APIError
*
C ENDSR
**************************************************************
* Open Spooled File *
**************************************************************
C $OPENSF BEGSR
*
C eval #Buff = -1
*
C CALL 'QSPOPNSP'
C PARM SplfIH
C PARM JobName
C PARM JobID
C PARM SplfID
C PARM File
C PARM Splf#b
C PARM #Buff
C PARM APIError
*
*
C ENDSR
**************************************************************
* Get Spooled File Data *
**************************************************************
C $GETSF BEGSR
*
C eval Buffer# = -1
*
C CALL 'QSPGETSP'
C PARM SplfIH
C PARM SpcName
C PARM 'SPFR0200' SpcFormat
C PARM Buffer#
C PARM EndOper
C PARM APIError
*
C ENDSR
**************************************************************
* Put Spooled File Data *
**************************************************************
C $PUTSF BEGSR
*
C CALL 'QSPPUTSP'
C PARM SplfOH
C PARM SpcName
C PARM APIError
*
C ENDSR
**************************************************************
* Close Spooled File *
**************************************************************
C $CLOSESF BEGSR
*
C CALL 'QSPCLOSP'
C PARM SplfIH
C PARM APIError
*
C CALL 'QSPCLOSP'
C PARM SplfOH
C PARM APIError
*
C ENDSR
**************************************************************
* Call Retrieve Spooled File Attributes API *
**************************************************************
C $RTVSPLFA BEGSR
*
C eval JobName = Job + User + Job#
C MOVE Splf#x Splf#d
C eval Splf#b = Splf#d
*
C CALL 'QUSRSPLA'
C PARM SplfAtt
C PARM RecLen
C PARM 'SPLA0200' SpcFormat
C PARM JobName
C PARM JobID
C PARM SplfID
C PARM File
C PARM Splf#b
*
C ENDSR
**************************************************************
* Create User Space *
**************************************************************
C $CRTSP BEGSR
*
C CALL 'QUSCRTUS'
C PARM SpcName
C PARM SpcAtr
C PARM SpcSiz
C PARM SpcInv
C PARM SpcAut
C PARM SpcDes
*
C ENDSR
**************************************************************
* Retrieve Pointer To User Space *
**************************************************************
C $RTVSP BEGSR
*
C CALL 'QUSPTRUS'
C PARM SpcName
C PARM SpcPtr
*
C ENDSR
**************************************************************
* Delete User Space *
**************************************************************
C $DLTSP BEGSR
*
C CALL 'QUSDLTUS'
C PARM SpcName
C PARM APIError
*
C ENDSR
***************************************************************
* INITIALIZATION SUBROUTINE *
***************************************************************
C *INZSR BEGSR
*
C *ENTRY PLIST
C PARM File
C PARM Job
C PARM User
C PARM Job#
C PARM Splf#x
*
C ENDSR
Thanks to Bradley V. Stone
|
|
Back
Open list of activation group & - attributes
**
** Program . . : CBX130
** Description : Analyze activation groups command
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 10, 2005
**
**
** Program summary
** ---------------
**
** Work managemeny APIs:
** QWVOLAGP Open list of Generates a list of all the
** activation group activation groups that are
** attributes associated with a given job and
** their attributes.
**
** QWVOLACT Open list of Generates a list of all the
** activation activation attributes that are
** attributes associated with an activation
** group in a given job.
**
** Open list APIs:
** QGYCTLE Get list entries To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** QGYCLST Close list This API closes the previously
** opened list identified by the
** request handle parameter.
** Storage allocated is freed.
**
**
** 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.
**
** Programmer's notes:
** Prior to V5R3 all Open List APIs are found in the QGY library.
** To run this program at V5R2 and earlier, library QGY needs to be
** in the job's library list.
**
** Open List APIs are located in option 12 - 'Host Servers' - of the
** operation system, and this option needs to be installed for these
** APIs to be available. Running the command DSPSFWRSC enables you
** to verify the presence of this option.
**
**
** Compile and setup instructions:
** CrtRpgMod Module( CBX130 )
** DbgView( *NONE )
** Aut( *USE )
**
** CrtPgm Pgm( CBX130 )
** Module( CBX130 )
** ActGrp( *NEW )
** Aut( *USE )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt: *NoDebugIo ) DecEdit( *JobRun )
**-- Printer file:
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D JobNam 26a Overlay( PgmSts: 244 )
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
D CurUsr 10a Overlay( PgmSts: 358 )
**-- Printer file information:
D PrtLinInf Ds Qualified
D OvfLin 5i 0 Overlay( PrtLinInf: 188 )
D CurLin 5i 0 Overlay( PrtLinInf: 367 )
D CurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- 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 LstTim s 6s 0
D AutFlg s 1a
**
D JobNam_q Ds Qualified
D JobNam 10a
D UsrPrf 10a
D JobNbr 6a
**-- List fields:
D JobNam s 10a
D UsrPrf s 10a
D JobNbr s 6a
**
D ActGrpNam s 10a
D ActGrpNbr s 10i 0
D NbrActs s 10i 0
D NbrHeaps s 10i 0
D StcStgSiz s 10i 0
D HeapStgSiz s 10i 0
D RootPgmNam s 10a
D RootPgmLib s 10a
D RootPgmTyp s 10a
D ActGrpStt s 8a
D ShrActGrp s 5a
D GrpInUse s 5a
**
D AtrActNbr s 10i 0
D AtrStcStg s 10i 0
D ActPgmNam s 10a
D ActPgmLib s 10a
D ActPgmTyp s 10a
**-- Global constants:
D OFS_MSGDTA c 16
**-- API parameters:
D RtnRcdNbr s 10i 0 Dim( 2 )
**-- Activation group information:
D RAGA0100 Ds Qualified
D ActGrpNam 10a
D 6a
D ActGrpNbr 10i 0
D NbrActs 10i 0
D NbrHeaps 10i 0
D StcStgSiz 10i 0
D HeapStgSiz 10i 0
D RootPgmNam 10a
D RootPgmLib 10a
D RootPgmTyp 1a
D ActGrpStt 1a
D ShrActGrpInd 1a
D InUseInd 1a
D 4a
**-- Activation attribute information:
D RACT0100 Ds Qualified
D ActGrpNam 10a
D 6a
D ActGrpNbr 10i 0
D 10i 0
D ActNbr 10i 0
D StcStgSiz 10i 0
D ActPgmNam 10a
D ActPgmLib 10a
D ActPgmTyp 1a
D 11a
**-- List information:
D LstInf Ds Qualified Dim( 2 )
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 activation group attributes:
D LstActGrpA Pr ExtPgm( 'QWVOLAGP' )
D LaRcvVar 65535a Options( *VarSize )
D LaRcvVarLen 10i 0 Const
D LaLstInf 80a
D LaNbrRcdRtn 10i 0 Const
D LaFmtNam 10a Const
D LaJobNam_q 10a Const
D LaIntJobId 16a Const
D LaError 1024a Options( *VarSize )
**-- Open list of activation attributes:
D LstActAtr Pr ExtPgm( 'QWVOLACT' )
D LaRcvVar 65535a Options( *VarSize )
D LaRcvVarLen 10i 0 Const
D LaLstInf 80a
D LaNbrRcdRtn 10i 0 Const
D LaFmtNam 10a Const
D LaActGrpNbr 10i 0 Const
D LaJobNam_q 10a Const
D LaIntJobId 16a Const
D LaError 1024a Options( *VarSize )
**-- Get list entry:
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list:
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Send 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 32767a Options( *VarSize )
**-- Write activation group detail line:
D WrtActGrpLin Pr
**-- Write activation attribute detail line:
D WrtActAtrLin Pr
**-- Write list header:
D WrtLstHdr Pr
D PxOvrFlwRel 10i 0 Const Options( *NoPass )
**-- Write group header:
D WrtGrpHdr Pr
**-- Write list trailer:
D WrtLstTrl Pr
**-- 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
D CBX130 Pr
D PxJobNam_q LikeDs( JobNam_q )
D PxActGrp 10a
**
D CBX130 Pi
D PxJobNam_q LikeDs( JobNam_q )
D PxActGrp 10a
/Free
If PxJobNam_q = '*';
PxJobNam_q = PgmSts.JobNam;
EndIf;
RtnRcdNbr(1) = 1;
LstActGrpA( RAGA0100
: %Size( RAGA0100 )
: LstInf(1)
: 1
: 'RAGA0100'
: PxJobNam_q
: *Blanks
: 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;
DoW LstInf(1).LstSts <> '2' Or
LstInf(1).RcdNbrTot >= RtnRcdNbr(1);
If PxActGrp = '*ALL' Or PxActGrp = RAGA0100.ActGrpNam;
WrtLstHdr();
WrtGrpHdr();
ExSr GetActAtr;
EndIf;
RtnRcdNbr(1) += 1;
GetLstEnt( RAGA0100
: %Size( RAGA0100 )
: LstInf(1).Handle
: LstInf(1)
: 1
: RtnRcdNbr(1)
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
EndDo;
If PrtLinInf.CurLin = *Zero;
WrtLstHdr();
EndIf;
WrtLstTrl();
CloseLst( LstInf(1).Handle: ERRC0100 );
SndCmpMsg( 'List has been printed.' );
EndIf;
*InLr = *On;
Return;
BegSr GetActAtr;
RtnRcdNbr(2) = 1;
LstActAtr( RACT0100
: %Size( RACT0100 )
: LstInf(2)
: 1
: 'RACT0100'
: RAGA0100.ActGrpNbr
: PxJobNam_q
: *Blanks
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
DoW LstInf(2).LstSts <> '2' Or
LstInf(2).RcdNbrTot >= RtnRcdNbr(2);
WrtActAtrLin();
RtnRcdNbr(2) += 1;
GetLstEnt( RACT0100
: %Size( RACT0100 )
: LstInf(2).Handle
: LstInf(2)
: 1
: RtnRcdNbr(2)
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
EndDo;
CloseLst( LstInf(2).Handle: ERRC0100 );
EndIf;
EndSr;
BegSr *InzSr;
LstTim = %Int( %Char( %Time(): *ISO0));
PrtLinInf.CurLin = *Zero;
PrtLinInf.CurPag = *Zero;
EndSr;
/End-Free
**-- Printer file definition: ------------------------------------------**
OQSYSPRT EF Header 2 2
O UDATE Y 8
O LstTim 18 ' : : '
O 75 'Job activation group attri-
O butes'
O 107 'Program:'
O PgmSts.PgmNam 118
O 126 'Page:'
O PAGE + 1
**
OQSYSPRT EF LstHdr 2
O 16 'Job name . . . :'
O JobNam 28
O 46 'User . . . . . :'
O UsrPrf 58
O 76 'Number . . . . :'
O JobNbr 84
O 114 'Activation group . . . :'
O PxActGrp 126
**
OQSYSPRT EF ActGrpHdr 1
O 10 'Group name'
O 21 'Number'
O 34 'Activations'
O 43 'Heaps'
O 56 'Static stg.'
O 67 'Heap stg.'
O 81 'Root program'
O 95 'Root library'
O 106 'Root type'
O 114 'State'
O 124 'Shared'
O 132 'In use'
**
OQSYSPRT EF ActGrpLin 1
O ActGrpNam 10
O ActGrpNbr 3 21
O NbrActs 3 32
O NbrHeaps 3 43
O StcStgSiz 3 55
O HeapStgSiz 3 66
O RootPgmNam 79
O RootPgmLib 93
O RootPgmTyp 107
O ActGrpStt 117
O ShrActGrp 123
O GrpInUse 132
**
OQSYSPRT EF ActAtrHdr 1 1
O 17 'Activation nbr.'
O 31 'Static stg.'
O 41 'Program'
O 53 'Library'
O 62 'Type'
**
OQSYSPRT EF ActAtrLin 1
O AtrActNbr 3 12
O AtrStcStg 1 29
O ActPgmNam 44
O ActPgmLib 56
O ActPgmTyp 68
**
OQSYSPRT EF DtlBlk 1
**
OQSYSPRT EF LstTrl 1
O 40 '*** E N D O F L I S T -
O ***'
**-- Write list header: ------------------------------------------------**
P WrtLstHdr B
D Pi
D PxOvrFlwRel 10i 0 Const Options( *NoPass )
/Free
JobNam = PxJobNam_q.JobNam;
UsrPrf = PxJobNam_q.UsrPrf;
JobNbr = PxJobNam_q.JobNbr;
If %Parms = *Zero;
Except Header;
Except LstHdr;
Else;
If PrtLinInf.CurLin > PrtLinInf.OvfLin - PxOvrFlwRel;
Except Header;
Except LstHdr;
WrtGrpHdr();
EndIf;
EndIf;
/End-Free
P WrtLstHdr E
**-- Write group header: -----------------------------------------------**
P WrtGrpHdr B
D Pi
/Free
Except ActGrpHdr;
WrtActGrpLin();
Except ActAtrHdr;
/End-Free
P WrtGrpHdr E
**-- Write activation group detail line: -------------------------------**
P WrtActGrpLin B
D Pi
/Free
WrtLstHdr( 3 );
ActGrpNam = RAGA0100.ActGrpNam;
ActGrpNbr = RAGA0100.ActGrpNbr;
NbrActs = RAGA0100.NbrActs;
NbrHeaps = RAGA0100.NbrHeaps;
StcStgSiz = RAGA0100.StcStgSiz;
HeapStgSiz = RAGA0100.HeapStgSiz;
RootPgmNam = RAGA0100.RootPgmNam;
RootPgmLib = RAGA0100.RootPgmLib;
Select;
When RAGA0100.RootPgmTyp = 'N';
RootPgmTyp = '*DLT';
When RAGA0100.RootPgmTyp = '0';
RootPgmTyp = '*PGM';
When RAGA0100.RootPgmTyp = '1';
RootPgmTyp = '*SRVPGM';
When RAGA0100.RootPgmTyp = '2';
RootPgmTyp = '*JAVA';
Other;
RootPgmTyp = *Blanks;
EndSl;
Select;
When RAGA0100.ActGrpStt = '0';
ActGrpStt = '*USER';
When RAGA0100.ActGrpStt = '1';
ActGrpStt = '*SYSTEM';
Other;
ActGrpStt = *Blanks;
EndSl;
Select;
When RAGA0100.ShrActGrpInd = '0';
ShrActGrp = '*YES';
When RAGA0100.ShrActGrpInd = '1';
ShrActGrp = '*NO';
EndSl;
Select;
When RAGA0100.InUseInd = '0';
GrpInUse = '*NO';
When RAGA0100.InUseInd = '1';
GrpInUse = '*YES';
EndSl;
Except ActGrpLin;
/End-Free
P WrtActGrpLin E
**-- Write activation attribute detail line: ---------------------------**
P WrtActAtrLin B
D Pi
/Free
WrtLstHdr( 3 );
AtrActNbr = RACT0100.ActNbr;
AtrStcStg = RACT0100.StcStgSiz;
ActPgmNam = RACT0100.ActPgmNam;
ActPgmLib = RACT0100.ActPgmLib;
Select;
When RACT0100.ActPgmTyp = '0';
ActPgmTyp = '*PGM';
When RACT0100.ActPgmTyp = '1';
ActPgmTyp = '*SRVPGM';
Other;
ActPgmTyp = *Blanks;
EndSl;
Except ActAtrLin;
/End-Free
P WrtActAtrLin E
**-- Write list trailer: -----------------------------------------------**
P WrtLstTrl B
D Pi
/Free
Except LstTrl;
/End-Free
P WrtLstTrl 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
**-- 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
Panel Group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX130H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='ANZACTGRP'.Analyze Activation Groups - Help
:P.
The Analyze Activation Groups (ANZACTGRP) command produces a report
that contains information about one or more activation groups currently
active in the specified job. This includes information about the
activation group itself, as well as information about the programs
currently activated within each activation group.
:P.
The gathered information is written to a spooled file and placed in the
current job's default output queue.
:P.
:HP2.Restriction&COLON.:EHP2. This command requires *JOBCTL special
authority if the job for which activation group information is being
retrieved has a user profile different from that of the job that runs
this command.
:P.
:EHELP.
:HELP NAME='ANZACTGRP/JOB'.Job name (JOB) - Help
:XH3.Job name (JOB)
:P.
Specifies the name of the job whose activation groups should be
analyzed.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*:EPK.
:PD.
The job whose activation groups are analyzed, is the job from which
this command is entered.
:PT.:PV.job-name:EPV.
:PD.
Specify the name of the job to be analyzed.
:EPARML.
:XH3.User
:P.
Specify the name that identifies the user profile under which the job
is run.
:P.
:XH3.Number
:P.
Specify the job number assigned by the system.
:P.
:EHELP.
:HELP NAME='ANZACTGRP/ACTGRP'.Activation group name (ACTGRP) - Help
:XH3.Activation group name (ACTGRP)
:P.
Limits the produced report to include only the activation group(s)
specified.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*ALL:EPK.
:PD.
All activation groups currently active in the specified job are
included in the report.
:PT.:PK.*DFTACTGRP:EPK.
:PD.
Only the default activation groups are included in the report.
:PT.:PV.activation-group-name:EPV.
:PD.
Specify the name of the activation group to include in the report.
:EPARML.
:EHELP.
:EPNLGRP.
Command
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( ANZACTGRP ) */
/* Pgm( CBX130 ) */
/* SrcMbr( CBX130X ) */
/* HlpPnlGrp( CBX130H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Analyze Activation Groups' )
Parm JOB Q0001 +
Dft( * ) +
SngVal(( * )) +
Prompt( 'Job name' )
Parm ACTGRP *Cname 10 +
Dft( *ALL ) +
SpcVal(( *ALL ) +
( *DFTACTGRP )) +
Expr( *YES ) +
Prompt( 'Activation group name' )
Q0001: Qual *Name 10 +
Min( 1 ) +
Expr( *YES )
Qual *Name 10 +
Expr( *YES ) +
Prompt( 'User' )
Qual *Char 6 +
Range( '000000' '999999' ) +
Full( *YES ) +
Expr( *YES ) +
Prompt( 'Number' )
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Retrieve Journal APIs
**
** Program . . : CBX126
** Description : Manage journal receivers command
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : October 28, 2004
**
**
** Program summary
** ---------------
**
** Journal and Commit APIs:
** QjoRetrieveJournalInformation The Retrieve Journal Information
** API provides access to journal-
** related information that helps
** manage a journal environment.
**
** General information is available
** in the return variable's header
** section and if requested, lists
** describing the journal receiver
** directory, journaled objects and
** remote journals can be returned.
**
** QjoRtvJrnReceiverInformation The Retrieve Journal Receiver
** Information API provides access
** to all journal receiver related
** information required to manage a
** journal environment.
**
** The information made available is
** similar the information provided
** by the Display Journal Receiver
** Attributes (DSPJRNRCVA) command.
**
** Program and CL command APIs:
** QCAPCMD Process commands Performs command analyzer
** processing on command strings
** and checks or runs CL commmands.
**
** This API is also capable of
** syntax checking specific source
** definition types.
**
** 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.
**
** QMHMOVPM Move program Moves one or more program
** message messages of the specified
** message type(s) to the
** specified earlier call
** level.
**
** Message sender information
** is not changed by the API,
** but escape messages are
** automatically changed to
** diagnostic messages.
**
** 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.
**
**
** Sequence of events:
** 1. The special value parameters received from the command interface
** are checked and converted to appropriate values for the selection
** process to be performed.
**
** 2. Storage is allocated for the API receiver variable and the API is
** is called. If more data is available than the receiver can hold,
** sufficient storage is reallocated and the API call repeated.
**
** 3. A job termination procedure is registered to ensure that allocated
** storage is properly deallocated in the event that the program is
** terminated unexpectedly - or as a result of sending an escape
** message if case of an error being encountered calling an API or
** issuing the DLTJRNRCV command.
**
** 4. The returned journal receiver directory list is processed, and for
** each receiver the Retrieve Journal Receiver Information API is
** called to make the receiver's attributes available to the receiver
** selection process.
**
** 5. Each listed journal receiver is evaluated against the specified
** selection criteria and if passed, the journal receiver is then
** processed in accordance with the specified option; if deletion
** was requested, it is deleted, and for both options it is counted.
**
** 6. When the whole journal receiver directory has been processed, an
** informational message is sent to the caller, specifying the number
** or journal receivers that matched the selection criteria.
**
** 7. The job termination procedure is unregistered and called directly
** to deallacate the storage previously allocated.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX126 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX126 )
** Module( CBX126 )
**
**
**-- 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 ApiRcvSiz s 10u 0
D RcvSavDts s z
D RcvRtnDat s d
D SltRcv s n
D NbrRcv s 10i 0 Inz( *Zero )
D MsgKey s 4a
D MsgTxt s 512a Varying
D CmdStr s 512a Varying
**-- Global constants:
D OFS_MSGDTA c 16
**-- Journal information:
D RJRN0100 Ds Based( pJrnInf ) Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D OfsKeyInf 10i 0
D JrnNam 10a
D JrnLib 10a
D ASP 10i 0
D MsgQnam 10a
D MsgQlib 10a
D MngRcvOpt 1a
D DltRcvOpt 1a
D RsoRit 1a
D RsoMfl 1a
D RsoMo1 1a
D RsoMo2 1a
D Rsv1 3a
D JrnTyp 1a
D RmtJrnTyp 1a
D JrnStt 1a
D JrnDlvMod 1a
D LocJrnNam 10a
D LocJrnLib 10a
D LocJrnSys 8a
D SrcJrnNam 10a
D SrcJrnLib 10a
D SrcJrnSys 8a
D RdrRcvLib 10a
D JrnTxt 50a
D MinEntDtaAr 1a
D MinEntFiles 1a
D Rsv2 9a
D NbrAtcRcv 10i 0
D AtcRcvNam 10a
D AtcRcvLib 10a
D AtcLocSys 8a
D AtcSrcSys 8a
D AtcRcvNamDu 10a
D AtcRcvLibDu 10a
D Rsv3 192a
D NbrKey 10i 0
**
D JrnKey Ds Based( pJrnKey ) Qualified
D Key 10i 0
D OfsKeyInf 10i 0
D KeyHdrSecLn 10i 0
D NbrEnt 10i 0
D KeyInfEntLn 10i 0
**
D JrnKeyHdr1 Ds Based( pKeyHdr1 ) Qualified
D RcvNbrTot 10i 0
D RcvSizTot 10i 0
D RcvSizMtp 10i 0
D Rsv 8a
**
D JrnKeyEnt1 Ds Based( pKeyEnt1 ) Qualified
D RcvNam 10a
D RcvLib 10a
D RcvNbr 5a
D RcvAtcDts 13a
D RcvSts 1a
D RcvSavDts 13a
D LocJrnSys 8a
D SrcJrnSys 8a
D RcvSiz 10i 0
D Rsv 56a
**-- Journal information specification:
D JrnInfRtv Ds Qualified
D NbrVarRcd 10i 0 Inz( 1 )
D VarRcdLen 10i 0 Inz( 12 )
D Key 10i 0 Inz( 1 )
D DtaLen 10i 0 Inz( 0 )
**-- Receiver information:
D RRCV0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D RcvNam 10a
D RcvLib 10a
D JrnNam 10a
D JrnLib 10a
D Thh 10i 0
D Siz 10i 0
D ASP 10i 0
D NbrJrnEnt 10i 0
D MaxEspDtaLn 10i 0
D MaxNulInd 10i 0
D FstSeqNbr 10i 0
D MinEntDtaAr 1a
D MinEntFiles 1a
D Rsv1 2a
D LstSeqNbr 10i 0
D Rsv2 10i 0
D Status 1a
D MinFxlVal 1a
D RcvMaxOpt 1a
D Rsv3 4a
D AtcDts 13a
D DtcDts 13a
D DtcDat 7a Overlay( DtcDts: 1 )
D DtcTim 6a Overlay( DtcDts: *Next )
D SavDts 13a
D SavDat 7a Overlay( SavDts: 1 )
D SavTim 6a Overlay( SavDts: *Next )
D Txt 50a
D PndTrn 1a
D RmtJrnTyp 1a
D LocJrnNam 10a
D LocJrnLib 10a
D LocJrnSys 8a
D LocRcvLib 10a
D SrcJrnNam 10a
D SrcJrnLib 10a
D SrcJrnSys 8a
D SrcRcvLib 10a
D RdcRcvLib 10a
D DuaRcvNam 10a
D DuaRcvLib 10a
D PrvRcvNam 10a
D PrvRcvLib 10a
D PrvRcvNamDu 10a
D PrvRcvLibDu 10a
D NxtRcvNam 10a
D NxtRcvLib 10a
D NxtRcvNamDu 10a
D NxtRcvLibDu 10a
D NbrJrnEntL 20s 0
D MaxEspDtlL 20s 0
D FstSeqNbrL 20s 0
D LstSeqNbrL 20s 0
D AspDevNam 10a
D LocJrnAspGn 10a
D SrcJrnAspGn 10a
D FldJob 1a
D FldUsr 1a
D FldPgm 1a
D FldPgmLib 1a
D FldSysSeq 1a
D FldRmtAdr 1a
D FldThd 1a
D FldLuw 1a
D FldXid 1a
D Rsv4 21a
**-- Retrieve journal information:
D RtvJrnInf Pr ExtProc( 'QjoRetrieveJournal-
D Information' )
D JiRcvVar 65535a Options( *VarSize )
D JiRcvVarLen 10i 0 Const
D JiJrnNam 20a Const
D JiFmtNam 8a Const
D JiInfRtv 65535a Const Options( *VarSize )
D JiError 32767a Options( *VarSize: *Omit )
**-- Retrieve journal receiver information:
D RtvRcvInf Pr ExtProc( 'QjoRtvJrnReceiver-
D Information' )
D RiRcvVar 65535a Options( *VarSize )
D RiRcvVarLen 10i 0 Const
D RiRcvNam 20a Const
D RiFmtNam 8a Const
D RiError 32767a Options( *VarSize: *Omit )
**-- 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 )
**-- Process commands:
D PrcCmds Pr ExtPgm( 'QCAPCMD' )
D PcSrcCmd 32702a Const Options( *VarSize )
D PcSrcCmdLen 10i 0 Const
D PcOptCtlBlk 20a Const
D PcOptCtlBlkLn 10i 0 Const
D PcOptCtlBlkFm 8a Const
D PcChgCmd 32767a Options( *VarSize )
D PcChgCmdLen 10i 0 Const
D PcChgCmdLenAv 10i 0
D PcError 32767a Options( *VarSize )
**-- 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 32767a Options( *VarSize )
**-- Move program messages:
D MovPgmMsg Pr ExtPgm( 'QMHMOVPM' )
D MpMsgKey 4a Const
D MpMsgTyps 10a Const Options( *VarSize ) Dim( 4 )
D MpNbrMsgTyps 10i 0 Const
D MpToCalStkE 4102a Const Options( *VarSize )
D MpToCalStkCnt 10i 0 Const
D MpError 32767a Options( *VarSize )
D MpToCalStkLen 10i 0 Const Options( *NoPass )
D MpToCalStkEq 20a Const Options( *NoPass )
D MpToCalStkEdt 10a Const Options( *NoPass )
D MpFrCalStkEad * Const Options( *NoPass )
D MpFrCalStkCnt 10i 0 Const Options( *NoPass )
**-- Process command:
D PrcCmd Pr 10i 0
D CmdStr 1024a 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 CBX126 Pr
D PxJrnNam_q 20a
D PxSavOfs LikeDs( SavOfs )
D PxRcvRtnDays 5i 0
D PxRcvRtnNbr 5i 0
D PxRcvSts 3a
D PxRcvOpt 3a
D PxForce 3a
**
D CBX126 Pi
D PxJrnNam_q 20a
D PxSavOfs LikeDs( SavOfs )
D PxRcvRtnDays 5i 0
D PxRcvRtnNbr 5i 0
D PxRcvSts 3a
D PxRcvOpt 3a
D PxForce 3a
/Free
ExSr InzParms;
ApiRcvSiz = 65535;
pJrnInf = %Alloc( ApiRcvSiz );
RJRN0100.BytAvl = *Zero;
DoU RJRN0100.BytAvl <= ApiRcvSiz Or
ERRC0100.BytAvl > *Zero;
If RJRN0100.BytAvl > ApiRcvSiz;
ApiRcvSiz = RJRN0100.BytAvl;
pJrnInf = %ReAlloc( pJrnInf: ApiRcvSiz );
EndIf;
RtvJrnInf( RJRN0100
: ApiRcvSiz
: PxJrnNam_q
: 'RJRN0100'
: JrnInfRtv
: ERRC0100
);
EndDo;
CeeRtx( %Paddr( TrmPgm ): pJrnInf: *Omit );
If ERRC0100.BytAvl > *Zero;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
);
Else;
ExSr PrcKeyEnt;
ExSr SndCmpMsg;
EndIf;
CeeUtx( %Paddr( TrmPgm ): *Omit );
TrmPgm( pJrnInf );
Return;
BegSr PrcKeyEnt;
pJrnKey = pJrnInf + RJRN0100.OfsKeyInf + %Size( RJRN0100.NbrKey );
pKeyHdr1 = pJrnKey + JrnKey.OfsKeyInf;
pKeyEnt1 = pKeyHdr1 + %Size( JrnKeyHdr1 );
For Idx = 1 to JrnKey.NbrEnt;
RtvRcvInf( RRCV0100
: %Size( RRCV0100 )
: JrnKeyEnt1.RcvNam + JrnKeyEnt1.RcvLib
: 'RRCV0100'
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
ExSr PrcLstEnt;
EndIf;
If Idx < JrnKey.NbrEnt;
Eval pKeyEnt1 = pKeyEnt1 + JrnKey.KeyInfEntLn;
EndIf;
EndFor;
EndSr;
BegSr InzParms;
If PxSavOfs.NbrElm = 1;
RcvSavDts = %Timestamp();
Else;
If PxSavOfs.DatFrm = '0010000';
PxSavOfs.DatFrm = %Char( %Date(): *CYMD0 );
EndIf;
If PxSavOfs.TimFrm = '000001';
PxSavOfs.TimFrm = %Char( %Time(): *HMS0 );
EndIf;
RcvSavDts = %Date( PxSavOfs.DatFrm: *CYMD0 ) +
%Time( PxSavOfs.TimFrm: *HMS0 );
EndIf;
If PxRcvRtnDays = -1;
RcvRtnDat = %Date() + %Days(1);
Else;
RcvRtnDat = %Date() - %Days( PxRcvRtnDays );
EndIf;
EndSr;
BegSr PrcLstEnt;
SltRcv = *On;
Select;
When RRCV0100.Status = '1';
SltRcv = *Off;
When PxRcvRtnNbr > -1 And
PxRcvRtnNbr > JrnKey.NbrEnt - Idx;
SltRcv = *Off;
When PxRcvSts = 'SAV' And
RRCV0100.Status <> '3' And
RRCV0100.Status <> '4';
SltRcv = *Off;
When PxRcvSts = 'ONL' And
RRCV0100.Status <> '2';
SltRcv = *Off;
When PxRcvSts = 'PTL' And
RRCV0100.Status <> '5';
SltRcv = *Off;
When RcvRtnDat <= %Date( RRCV0100.DtcDat: *CYMD0 );
SltRcv = *Off;
When RRCV0100.Status = '3' Or
RRCV0100.Status = '4';
If RcvSavDts < %Date( RRCV0100.SavDat: *CYMD0 ) +
%Time( RRCV0100.SavTim: *HMS0 );
SltRcv = *Off;
EndIf;
EndSl;
If SltRcv = *On;
ExSr RunCmdOpt;
EndIf;
EndSr;
BegSr RunCmdOpt;
If PxRcvOpt = 'DLT';
CmdStr = 'DLTJRNRCV JRNRCV(' +
%Trim( RRCV0100.RcvLib ) + '/' +
%Trim( RRCV0100.RcvNam ) + ')';
If PxForce = 'YES';
CmdStr += ' DLTOPT(*IGNINQMSG)';
EndIf;
If PrcCmd( CmdStr) < *Zero;
SndEscMsg( 'CPF0001': 'QCPFMSG': 'DLTJRNRCV' );
EndIf;
EndIf;
If Not %Error;
NbrRcv += 1;
EndIf;
EndSr;
BegSr SndCmpMsg;
Select;
When PxRcvOpt = 'DLT';
MsgTxt = %Char( NbrRcv ) + ' journal receivers met the ' +
'selection criteria and were deleted.';
When PxRcvOpt = 'VFY';
MsgTxt = %Char( NbrRcv ) + ' journal receivers met the ' +
'selection criteria.';
EndSl;
SndMsgTyp( MsgTxt: '*COMP' );
EndSr;
/End-Free
**-- Process command: --------------------------------------------------**
P PrcCmd B Export
D Pi 10i 0
D PxCmdStr 1024a Const Varying
**
D CPOP0100 Ds Qualified
D TypPrc 10i 0 Inz( 2 )
D DBCS 1a Inz( '0' )
D PmtAct 1a Inz( '2' )
D CmdStx 1a Inz( '0' )
D MsgRtvKey 4a Inz( *Allx'00' )
D Rsv 9a Inz( *Allx'00' )
**
D ChgCmd s 2048a
D ChgCmdAvl s 10i 0
**-- Api error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( *Zero )
**
/Free
CallP(e) PrcCmds( PxCmdStr
: %Len( PxCmdStr )
: CPOP0100
: %Size( CPOP0100 )
: 'CPOP0100'
: ChgCmd
: %Size( ChgCmd )
: ChgCmdAvl
: ERRC0100
);
If %Error;
Return -1;
Else;
MovPgmMsg( *Blanks
: '*COMP'
: 1
: '*PGMBDY'
: 1
: ERRC0100
);
Return 0;
EndIf;
/End-Free
P PrcCmd 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
Panel Group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX126H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:IMPORT NAME=DLTJRNRCV PNLGRP=QHJOCMD.
:HELP NAME='MNGJRNRCV'.Manage Journal Receivers - Help
:P.
The Manage Journal Receivers (MNGJRNRCV) command is used to count or
delete the journal receivers matching the specified selection criteria.
:P.
:NT.
Currently attached receivers are not included in the processing
performed by this command.
:ENT.
:P.
:HP2.Restrictions&COLON.:EHP2. *OBJOPR and some data authority other
than *EXECUTE is required to the specified journal and it's journal
receivers to retrieve the information. Proper object authority is
required to delete a journal receiver.
:EHELP.
:HELP NAME='MNGJRNRCV/JRN'.Journal (JRN) - Help
:XH3.Journal (JRN)
:P.
Specifies the journal whose journal receivers are to be either counted
or deleted.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
The name of the journal can be qualified by one of the following
possible library values:
:P.
:PARML.
:PT.:PK DEF.*LIBL:EPK.
:PD.
All libraries in the job's library list are searched until the first
match is found.
:PT.:PK.*CURLIB:EPK.
:PD.
The current library for the job is searched. If no library is
specified as the current library for the job, QGPL is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the name of the library to be searched.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/SAVDATE'.Journal receiver saved before (SAVDATE) - Help
:XH3.Journal receiver saved before (SAVDATE)
:P.
Specifies the earliest save date and time at which, or before which,
the journal receiver must have been saved in order to be selected.
Journal receivers saved after the specified date and time are not
included. The date and time value are evaluated in conjunction,
meaning that journal receivers saved on the date specified will be
included, if the specified time criteria is met.
:P.
:NT.
The save date and time is only checked against journal receivers that
have a status of SAVED. Journal receivers that were not previously
saved will therefore possibly still be included by the selection
process if all other selection criteria are met. Specify
STATUS(*SAVED) if you want to ensure that only saved journal receivers
are selected.
:ENT.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NOCHK:EPK.
:PD.
The journal receiver save date and time is not considered when the
specified selection criteria are evaluated.
:EPARML.
:XH3.Save date
:P.
The possible values are:
:P.
:PARML.
:PT.:PK.*CURRENT:EPK.
:PD.
The current date is used to evaluate the journal receiver save date.
:PT.:PV.save-date:EPV.
:PD.
Specify a date to use for journal receiver save date evaluation.
:EPARML.
:XH3.Save time
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*CURRENT:EPK.
:PD.
The current time is used to select the journal receivers.
:PT.:PK.*BEGIN:EPK.
:PD.
The beginning of the day is used to select the journal receivers.
Journal receivers saved on the date specified in the save date
parameter will not be selected.
:PT.:PV.save-time:EPV.
:PD.
Specify a time to use for journal receiver selection.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/DAYS'.Journal receiver retain days (DAYS) - Help
:XH3.Journal receiver retain days (DAYS)
:P.
Specifies the number of days to keep journal receivers online, after
they have been detached. This criteria is evaluated independently of
the journal receiver save status.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
The journal receiver detach date is not evaluated during the selection
process.
:PT.:PV.journal-receiver-retain-days:EPV.
:PD.
Specify the minimum number of days to keep journal receivers online,
after they have been detached.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/RETAIN'.Journal receivers to retain (RETAIN) - Help
:XH3.Journal receivers to retain (RETAIN)
:P.
Specifies the minimum number of journal receivers to keep online. The
journal receivers are counted from the currently attached receiver and
backwards.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
The relative number of the journal receiver is not considered during
the selection process.
:PT.:PV.journal-receivers-to-retain:EPV.
:PD.
Specify the minimum number of journal receivers to keep online,
deleting the oldest receivers first.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/STATUS'.Journal receiver status (STATUS) - Help
:XH3.Journal receiver status (STATUS)
:P.
Specifies the current journal receiver status that qualifies a journal
receiver to be selected.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAVED:EPK.
:PD.
Only journal receivers having a status of SAVED are selected.
:PT.:PK.*ONLINE:EPK.
:PD.
Only journal receivers having a status of ONLINE are selected.
:PT.:PK.*PARTIAL:EPK.
:PD.
Only journal receivers having a status of PARTIAL are selected.
:PT.:PK.*NONATTACH:EPK.
:PD.
Journal receivers having any status other than ATTACHED are selected.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/OPTION'.Journal receiver option (OPTION) - Help
:XH3.Journal receiver option (OPTION)
:P.
Specifies what type of processing the selected journal receivers will
be subject to.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*VERIFY:EPK.
:PD.
The total number of journal receivers selected will be returned in the
completion message. No further processing will occur.
:PT.:PK.*DELETE:EPK.
:PD.
The selected journal receivers will be deleted using the Delete Journal
Receiver (DLTJRNRCV) command. All restrictions applying to the
:LINK PERFORM='DSPHELP DLTJRNRCV'.
DLTJRNRCV
:ELINK.
command are enforced during this process. If the journal receiver
processing completes successfully, the total number of deleted journal
receivers will be returned in the completion message.
:EPARML.
:EHELP.
:HELP NAME='MNGJRNRCV/FORCE'.Force receiver deletion (FORCE) - Help
:XH3.Force receiver deletion (FORCE)
:P.
Specifies whether additional checking should not be done before a
journal receiver is deleted.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Additional checking is done prior to the deletion of a journal receiver,
and inquiry messages will, if necessary, be presented to the user.
:PT.:PK.*YES:EPK.
:PD.
Do not send inquiry messages. Inquiry message CPA7025 is not presented
to the user, even if this receiver has not been fully saved (for
example, a save after the receiver was detached).
:P.
Also, inquiry message CPA705E is not presented to the user even
if the receiver is attached to a remote journal. The delete
operation continues.
:EPARML.
:EHELP.
:EPNLGRP.
Command
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( MNGJRNRCV ) */
/* Pgm( CBX126 ) */
/* SrcMbr( CBX126X ) */
/* VldCkr( CBX126V ) */
/* HlpPnlGrp( CBX126H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Manage Journal Receivers' )
Parm JRN Q0001 +
Min( 1 ) +
Prompt( 'Journal' )
Parm SAVDATE E0001 +
Dft( *NOCHK ) +
SngVal(( *NOCHK 000000 )) +
Prompt( 'Journal receiver saved before' )
Parm DAYS *Int2 +
Range( 1 999 ) +
Dft( *NONE ) +
SpcVal(( *NONE -1 )) +
Prompt( 'Journal receiver retain days' )
Parm RETAIN *Int2 +
Range( 1 999 ) +
Dft( *NONE ) +
SpcVal(( *NONE -1 )) +
Prompt( 'Journal receivers to retain' )
Parm STATUS *Char 3 +
Rstd( *YES ) +
Dft( *SAVED ) +
SpcVal(( *SAVED SAV ) +
( *ONLINE ONL ) +
( *PARTIAL PTL ) +
( *NONATTACH NAT )) +
Prompt( 'Journal receiver status' )
Parm OPTION *Char 3 +
Rstd( *YES ) +
Dft( *VERIFY ) +
SpcVal(( *VERIFY VFY ) +
( *DELETE DLT )) +
Prompt( 'Journal receiver option' )
Parm FORCE *Char 3 +
Rstd( *YES ) +
Dft( *NO ) +
SpcVal(( *NO NO ) +
( *YES YES )) +
PmtCtl( PMTDLTRCV ) +
Prompt( 'Force receiver deletion' )
Q0001: Qual *Name +
Expr( *YES )
Qual *Name +
Dft( *LIBL ) +
SpcVal(( *LIBL ) ( *CURLIB )) +
Expr( *YES ) +
Prompt( 'Library' )
E0001: Elem *Date +
SpcVal(( *CURRENT 000001 )) +
Expr( *YES ) +
Prompt( 'Save date' )
Elem *Time +
SpcVal(( *BEGIN 000000 ) +
( *CURRENT 000001 )) +
Dft( *CURRENT ) +
Expr( *YES ) +
Prompt( 'Save time' )
PmtDltRcv: PmtCtl Ctl( OPTION ) +
Cond(( *EQ DLT ))
Dep Ctl( &OPTION *EQ 'VFY' ) +
Parm(( FORCE )) +
NbrTrue( *EQ 0 )
CLP
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CBX126V */
/* Description : Manage journal receiver command - VCP */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : October 28, 2004 */
/* */
/* Program function: Check existence of parameter JRN - Journal */
/* */
/* */
/* Programmer's notes: */
/* The CPD0006 diagnostic message followed by a CPF0002 escape */
/* message is mandatory for a command validity checking program. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX126V ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm ( &PxJrnQ +
&PxSavOfs +
&PxDays +
&PxRetain +
&PxRcvSts +
&PxOption +
&PxForce +
)
/*-- Parameters: ---------------------------------------------------*/
Dcl &PxJrnQ *Char 20
Dcl &PxSavOfs *Char 15
Dcl &PxDays *Char 2
Dcl &PxRetain *Char 2
Dcl &PxRcvSts *Char 3
Dcl &PxOption *Char 3
Dcl &PxForce *Char 3
/*-- Global variables: ---------------------------------------------*/
Dcl &JrnNam *Char 10
Dcl &JrnLib *Char 10
Dcl &Msg *Char 80
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
/*-- Mainline -------------------------------------------------------*/
ChgVar &JrnNam %Sst( &PxJrnQ 1 10 )
ChgVar &JrnLib %Sst( &PxJrnQ 11 10 )
RtvObjD Obj( &JrnLib/&JrnNam ) +
ObjType( *JRN ) +
RtnLib( &JrnLib )
/*-- End of program -------------------------------------------------*/
Return:
Return
/*-- Error processor ------------------------------------------------*/
Error:
RcvMsg MsgType( *EXCP ) +
Msg( &Msg )
ChgVar &Msg ( '0000' *Cat &Msg )
SndPgmMsg MsgId( CPD0006 ) +
MsgF( QCPFMSG ) +
MsgDta( &Msg ) +
MsgType( *DIAG )
SndPgmMsg MsgId( CPF0002 ) +
MsgF( QCPFMSG ) +
MsgType( *ESCAPE )
EndPgm:
EndPgm
A Demo Program
**
** Program . . : CBX126T
** Description : Demonstrate the use of the QjoRetrieveJournalInformation API
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : October 28, 2004
**
**
** To run this sample program compile it as described below, start a
** debug session, call it, and then step throug the program in the
** debugger:
**
** StrDbg Pgm( CBX126T ) - Press F10
**
** Call Pgm( CBX126T ) - Press F10 repeatedly
**
**
** Compile options:
**
** CrtRpgMod Module( CBX126T )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX126T )
** Module( CBX126T )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Global declarations:
D Idx s 10u 0
D ApiRcvSiz s 10u 0
**-- 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
**-- Journal information:
D RJRN0100 Ds Based( pJrnInf ) Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D OfsKeyInf 10i 0
D JrnNam 10a
D JrnLib 10a
D ASP 10i 0
D MsgQnam 10a
D MsgQlib 10a
D MngRcvOpt 1a
D DltRcvOpt 1a
D RsoRit 1a
D RsoMfl 1a
D RsoMo1 1a
D RsoMo2 1a
D Rsv1 3a
D JrnTyp 1a
D RmtJrnTyp 1a
D JrnStt 1a
D JrnDlvMod 1a
D LocJrnNam 10a
D LocJrnLib 10a
D LocJrnSys 8a
D SrcJrnNam 10a
D SrcJrnLib 10a
D SrcJrnSys 8a
D RdrRcvLib 10a
D JrnTxt 50a
D MinEntDtaAr 1a
D MinEntFiles 1a
D Rsv2 9a
D NbrAtcRcv 10i 0
D AtcRcvNam 10a
D AtcRcvLib 10a
D AtcLocSys 8a
D AtcSrcSys 8a
D AtcRcvNamDu 10a
D AtcRcvLibDu 10a
D MngRcvDly 10i 0
D DltRcvDly 10i 0
D AspDevNam 10a
D LclJrnAspGrp 10a
D SrcJrnAspGrp 10a
D FixDtaJob 1a
D FixDtaUsr 1a
D FixDtaPgm 1a
D FixDtaPgmLib 1a
D FixDtaSysSeq 1a
D FixDtaRmtAdr 1a
D FixDtaThd 1a
D FixDtaLuw 1a
D FixDtaXid 1a
D Rsv3 145a
D NbrKey 10i 0
**
D JrnKey Ds Based( pJrnKey ) Qualified
D Key 10i 0
D OfsKeyInf 10i 0
D KeyHdrSecLn 10i 0
D NbrEnt 10i 0
D KeyInfEntLn 10i 0
**
D JrnKeyHdr1 Ds Based( pKeyHdr1 ) Qualified
D RcvNbrTot 10i 0
D RcvSizTot 10i 0
D RcvSizMtp 10i 0
D Rsv 8a
**
D JrnKeyEnt1 Ds Based( pKeyEnt1 ) Qualified
D RcvNam 10a
D RcvLib 10a
D RcvNbr 5a
D RcvAtcDts 13a
D RcvSts 1a
D RcvSavDts 13a
D LocJrnSys 8a
D SrcJrnSys 8a
D RcvSiz 10i 0
D Rsv 56a
**
D JrnKeyHdr2 Ds Based( pKeyHdr2 )
D JrnFilNbrTot 10i 0
D JrnMbrNbrTot 10i 0
D JrnDtaNbrTot 10i 0
D JrnDtqNbrTot 10i 0
D JrnIfsNbrTot 10i 0
D Rsv 16a
**
D JrnKeyEnt2 Ds Based( pKeyEnt2 ) Qualified
D ObjTyp 10a
D ObjNam 10a
D ObjLib 10a
D ObjFilId 16a
D Rsv 2a
**
D JrnKeyHdr3 Ds Based( pKeyHdr3 ) Qualified
D RmtJrnNbrTot 10i 0
D Rsv 16a
**
D JrnKeyEnt3 Ds Based( pKeyEnt3 ) Qualified
D RdbDirE 18a
D RmtJrnNam 10a
D RmtJrnLib 10a
D RmtJrnRcvLb 10a
D CijJrnRcv 10a
D CijJrnRcvLb 10a
D CijSeqNbr 10i 0
D Rsv1 10i 0
D RmtJrnTyp 1a
D RmtJrnStt 1a
D RmtJrnDlvMd 1a
D Rsv2 1a
D SndTskPty 10i 0
D CijSeqNbrLg 20a
D Rsv3 60a
D RdbDirDtl 512a
D Rsv 348a
**-- Journal information specification:
D JrnInfRtv1 Ds Qualified
D NbrVarRcd 10i 0 Inz( 1 )
D VarRcdLen 10i 0 Inz( 12 )
D Key 10i 0 Inz( 1 )
D DtaLen 10i 0 Inz( 0 )
**
D JrnInfRtv2 Ds Qualified
D NbrVarRcd 10i 0 Inz( 1 )
D VarRcdLen 10i 0 Inz( 22 )
D Key 10i 0 Inz( 2 )
D DtaLen 10i 0 Inz( %Size( JrnInfRtv2.Dta ))
D Dta
D JrnObjInf 10a Overlay( Dta ) Inz( '*ALL' )
**
D JrnInfRtv3 Ds Qualified
D NbrVarRcd 10i 0 Inz( 1 )
D VarRcdLen 10i 0 Inz( 60 )
D Key 10i 0 Inz( 3 )
D DtaLen 10i 0 Inz( %Size( JrnInfRtv3.Dta ))
D Dta
D RdbDirEinf 18a Overlay( Dta ) Inz( '*ALL' )
D RmtJrnNam 20a Overlay( Dta: *Next ) Inz( '*ALL' )
**-- Receiver information:
D RRCV0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D RcvNam 10a
D RcvLib 10a
D JrnNam 10a
D JrnLib 10a
D Thh 10i 0
D Siz 10i 0
D ASP 10i 0
D NbrJrnEnt 10i 0
D MaxEspDtaLn 10i 0
D MaxNulInd 10i 0
D FstSeqNbr 10i 0
D MinEntDtaAr 1a
D MinEntFiles 1a
D Rsv1 2a
D LstSeqNbr 10i 0
D Rsv2 10i 0
D Sts 1a
D MinFxlVal 1a
D RcvMaxOpt 1a
D Rsv3 4a
D AtcDts 13a
D DtcDts 13a
D SavDts 13a
D Txt 50a
D PndTrn 1a
D RmtJrnTyp 1a
D LocJrnNam 10a
D LocJrnLib 10a
D LocJrnSys 8a
D LocRcvLib 10a
D SrcJrnNam 10a
D SrcJrnLib 10a
D SrcJrnSys 8a
D SrcRcvLib 10a
D RdcRcvLib 10a
D DuaRcvNam 10a
D DuaRcvLib 10a
D PrvRcvNam 10a
D PrvRcvLib 10a
D PrvRcvNamDu 10a
D PrvRcvLibDu 10a
D NxtRcvNam 10a
D NxtRcvLib 10a
D NxtRcvNamDu 10a
D NxtRcvLibDu 10a
D NbrJrnEntL 20s 0
D MaxEspDtlL 20s 0
D FstSeqNbrL 20s 0
D LstSeqNbrL 20s 0
D AspDevNam 10a
D LocJrnAspGn 10a
D SrcJrnAspGn 10a
D FldJob 1a
D FldUsr 1a
D FldPgm 1a
D FldPgmLib 1a
D FldSysSeq 1a
D FldRmtAdr 1a
D FldThd 1a
D FldLuw 1a
D FldXid 1a
D Rsv4 21a
**-- Retrieve journal information:
D RtvJrnInf Pr ExtProc( 'QjoRetrieveJournal-
D Information' )
D JiRcvVar 65535a Options( *VarSize )
D JiRcvVarLen 10i 0 Const
D JiJrnNam 20a Const
D JiFmtNam 8a Const
D JiInfRtv 65535a Const Options( *VarSize )
D JiError 32767a Options( *VarSize: *Omit )
**-- Retrieve journal receiver information:
D RtvRcvInf Pr ExtProc( 'QjoRtvJrnReceiver-
D Information' )
D RiRcvVar 65535a Options( *VarSize )
D RiRcvVarLen 10i 0 Const
D RiRcvNam 20a Const
D RiFmtNam 8a Const
D RiError 32767a Options( *VarSize: *Omit )
**
/Free
ApiRcvSiz = 10240;
pJrnInf = %Alloc( ApiRcvSiz );
RJRN0100.BytAvl = *Zero;
DoU RJRN0100.BytAvl <= ApiRcvSiz Or
ERRC0100.BytAvl > *Zero;
If RJRN0100.BytAvl > ApiRcvSiz;
ApiRcvSiz = RJRN0100.BytAvl;
pJrnInf = %ReAlloc( pJrnInf: ApiRcvSiz );
EndIf;
RtvJrnInf( RJRN0100
: ApiRcvSiz
: 'NOVAJRN NOVAJRNLIB'
: 'RJRN0100'
: JrnInfRtv1
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
ExSr PrcKeyEnt1;
EndIf;
DoU RJRN0100.BytAvl <= ApiRcvSiz Or
ERRC0100.BytAvl > *Zero;
If RJRN0100.BytAvl > ApiRcvSiz;
ApiRcvSiz = RJRN0100.BytAvl;
pJrnInf = %ReAlloc( pJrnInf: ApiRcvSiz );
EndIf;
RtvJrnInf( RJRN0100
: ApiRcvSiz
: 'NOVAJRN NOVAJRNLIB'
: 'RJRN0100'
: JrnInfRtv2
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
ExSr PrcKeyEnt2;
EndIf;
DoU RJRN0100.BytAvl <= ApiRcvSiz Or
ERRC0100.BytAvl > *Zero;
If RJRN0100.BytAvl > ApiRcvSiz;
ApiRcvSiz = RJRN0100.BytAvl;
pJrnInf = %ReAlloc( pJrnInf: ApiRcvSiz );
EndIf;
RtvJrnInf( RJRN0100
: ApiRcvSiz
: 'NOVAJRN NOVAJRNLIB'
: 'RJRN0100'
: JrnInfRtv3
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
ExSr PrcKeyEnt3;
EndIf;
DeAlloc pJrnInf;
Return;
// Process key entries:
BegSr PrcKeyEnt1;
pJrnKey = pJrnInf + RJRN0100.OfsKeyInf + %Size( RJRN0100.NbrKey );
pKeyHdr1 = pJrnKey + JrnKey.OfsKeyInf;
pKeyEnt1 = pKeyHdr1 + %Size( JrnKeyHdr1 );
For Idx = 1 to JrnKey.NbrEnt;
RtvRcvInf( RRCV0100
: %Size( RRCV0100 )
: JrnKeyEnt1.RcvNam + JrnKeyEnt1.RcvLib
: 'RRCV0100'
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
// Do whatever...
EndIf;
If Idx < JrnKey.NbrEnt;
Eval pKeyEnt1 = pKeyEnt1 + JrnKey.KeyInfEntLn;
EndIf;
EndFor;
EndSr;
BegSr PrcKeyEnt2;
pJrnKey = pJrnInf + RJRN0100.OfsKeyInf + %Size( RJRN0100.NbrKey );
pKeyHdr2 = pJrnKey + JrnKey.OfsKeyInf;
pKeyEnt2 = pKeyHdr1 + %Size( JrnKeyHdr2 );
For Idx = 1 to JrnKey.NbrEnt;
// Do whatever...
If Idx < JrnKey.NbrEnt;
Eval pKeyEnt2 = pKeyEnt2 + JrnKey.KeyInfEntLn;
EndIf;
EndFor;
EndSr;
BegSr PrcKeyEnt3;
pJrnKey = pJrnInf + RJRN0100.OfsKeyInf + %Size( RJRN0100.NbrKey );
pKeyHdr3 = pJrnKey + JrnKey.OfsKeyInf;
pKeyEnt3 = pKeyHdr1 + %Size( JrnKeyHdr3 );
For Idx = 1 to JrnKey.NbrEnt;
// Do whatever...
If Idx < JrnKey.NbrEnt;
Eval pKeyEnt3 = pKeyEnt3 + JrnKey.KeyInfEntLn;
EndIf;
EndFor;
EndSr;
/End-Free
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Retrieve System Information APIs
**
** Program . . : CBX131
** Description : Retrieve system information using APIs
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 24, 2005
**
**
** Program summary
** ---------------
**
** Work management APIs:
** QWCRSVAL Retrieve system Retrieves one or more system
** value values into the data structure
** supplied as the receiver variable
** parameter.
**
** QWCRNETA Retrieve net Retrieves the specified net
** attribute attribute(s) into the data
** structure supplied as the
** receiver variable parameter.
**
** QWCRSSTS Retrieve system Retrieves a group of statistics
** status that represents the current
** current status of the system.
**
** Different groups of statistics
** are available, including system,
** subsystem and pool information.
**
** QUSRJOBI Retrieve job Retrieves specific information
** information about a specific job, covering
** all attributes and other state
** and runtime related information.
**
** Software product APIs:
** QSZRTVPR Retrieve product Retrieves information about a
** information specific product load for a
** software product.
**
** The Display Software Resources
** (DSPSFWRSC) command and the
** Select Product (QSZSLTPR) API
** will obtain a list of installed
** products about which you can
** retrieve information.
**
** QpzListPTF List program Returns a list of PTFs for the
** temporary fixes specified product, option, load,
** and release. The product must be
** supported or installed before the
** list of PTFs is returned.
**
** Miscellaneous APIs:
** QWCCVTDT Convert date and Converts date and time values
** time format from one format to another,
** including a system timestamp of
** type *DTS to character format.
**
** 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.
**
** Edit function API:
** QECCVTEC Convert edit code Converts an edit code into an
** mask edit mask, which is a set of
** instructions used by the edit
** function to format a numeric
** value into a character string.
**
** MI builtins:
** _LBEDIT Late bound edit Transforms a numeric value from
** its internal format to character
** form, using the provided edit
** mask. Late bound here refers to
** the source value location not
** having to be provided until
** runtime.
**
** _MATMATR1 Materialize machine Retrieves a broad range of system
** attributes software and hardware related
** attributes.
**
** C library function:
** tstbts Test bits Tests the bit value of the bit
** located with the bit offset
** parameter, bit 0 being the
** leftmost and 64k the maximum.
**
** Compile options required:
**
** BndSrvPgm( QPZLSTFX ) - on V5R2 the compiler is not able to locate
** the 'QpzListPTF' API itself.
**
** CrtRpgMod Module( CBX131 )
** DbgView( *LIST )
**
** CrtSrvPgm SrvPgm( CBX131 )
** Module( CBX131 )
** Export( *ALL )
** BndSrvPgm( QPZLSTFX )
** ActGrp( QSRVPGM )
**
**
**-- Header Specifications: --------------------------------------------**
H NoMain Option( *SrcStmt ) BndDir( 'QC2LE' ) DecEdit( *JobRun )
**-- API Error Data Structure:
D ERRC0100 Ds Qualified Inz
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 256a
**-- Global constants:
D NULL c ''
**-- Product information:
D PRDR0100 Ds Qualified
D BytPrv 10i 0
D BytRtn 10i 0
D 10i 0
D PrdId 7a
D Release 6a
D PrdOpt 4a
D LodId 4a
D LodTyp 10a
D SymLodStt 10a
D LodErrInd 10a
D LodStt 2a
D SupFlg 1a
D RegTyp 2a
D RegVal 14a
D 2a
D OfsAddInf 10i 0
D PriLodId 4a
D MinTrgRel 6a
D MinVrmBas 6a
D RqmBasOpt 1a
D Level 3a
**-- System status information:
D SSTS0200 Ds Qualified
D BytAvl 10i 0
D BytRtn 10i 0
D RstStt 1a Overlay( SSTS0200: 31 )
**-- Edit template:
D DPA_Template_T Ds Qualified
D SclTyp 1a
D SclLen 5i 0
D DecPos 3i 0 Overlay( SclLen: 1 )
D DecLen 3i 0 Overlay( SclLen: 2 )
D Rsv 10i 0 Inz
**-- Inz status record:
D MatInzSts Ds Qualified
D BytPrv 10i 0 Inz( %Size( MatInzSts ))
D BytAvl 10i 0
D StrIpl 8a Overlay( MatInzSts: 441 )
**-- Convert edit code to mask:
D CvtCdeMsk Pr ExtPgm( 'QECCVTEC' )
D CcEdtMsk 256a
D CcEdtMskLen 10i 0
D CcRcvVarLen 10i 0
D CcZroFilChr 1a
D CcEdtCde 1a Const
D CcCcyInd 1a Const
D CcSrcVarPrc 10i 0 Const
D CcSrcVarDec 10i 0 Const
D CcError 32767a Options( *VarSize )
**-- Retrieve system status:
D RtvSysSts Pr ExtPgm( 'QWCRSSTS' )
D RsRcvVar 32767a Options( *VarSize )
D RsRcvVarLen 10i 0 Const
D RsFmtNam 10a Const
D RsRstStc 10a Const
D RsError 32767a Options( *VarSize )
**
D RsPoolSltInf 24a Const Options( *VarSize: *NoPass )
D RsPoolSltSiz 10i 0 Const Options( *NoPass )
**-- Retrieve system value:
D RtvSysVal Pr ExtPgm( 'QWCRSVAL' )
D GsRcvVar 32767a Options( *VarSize )
D GsRcvVarLen 10i 0 Const
D GsNbrSysVal 10i 0 Const
D GsSysVal 10a Const Dim( 256 )
D Options( *VarSize )
D GsError 32767a Options( *VarSize )
**-- Retrieve net attribute:
D RtvNetAtr Pr ExtPgm( 'QWCRNETA' )
D RnRcvVar 32767a Options( *VarSize )
D RnRcvVarLen 10i 0 Const
D RnNbrNetAtr 10i 0 Const
D RnNetAtr 10a Const Dim( 256 )
D Options( *VarSize )
D RnError 32767a Options( *VarSize )
**-- Retrieve product information:
D RtvPrdInf Pr ExtPgm( 'QSZRTVPR' )
D PiDta Like( PRDR0100 )
D PiDtaLen 10i 0 Const
D PiFmtNam 8a Const
D PiPrdInf 27a Const
D PiError 1024a Options( *VarSize )
**-- Retrieve job information:
D RtvJobInf Pr ExtPgm( 'QUSRJOBI' )
D RiRcvVar 32767a Options( *VarSize )
D RiRcvVarLen 10i 0 Const
D RiFmtNam 8a Const
D RiJobNamQ 26a Const
D RiJobIntId 16a Const
D RiError 32767a Options( *NoPass: *VarSize )
D RiRstStc 1a Options( *NoPass )
**-- Convert date & time:
D CvtDtf Pr ExtPgm( 'QWCCVTDT' )
D CdInpFmt 10a Const
D CdInpVar 17a Const Options( *VarSize )
D CdOutFmt 10a Const Options( *VarSize )
D CdOutVar 17a Const Options( *VarSize )
D CdError 32767a Options( *VarSize )
**-- 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 )
**-- Delete user space:
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Retrieve pointer to user space:
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- List PTFs:
D LstPtfs Pr ExtProc( 'QpzListPTF' )
D LpSpcNamQ 20a Const
D LpPrdId 50a Const
D LpFmtNam 8a Const
D LpError 32767a Options( *VarSize )
**-- Edit function:
D Edit Pr ExtProc( '_LBEDIT' )
D RcvVar * Value
D RcvVarLen 10u 0 Const
D SrcVar * Value
D SrcVarAtr Const Like( DPA_Template_T )
D EdtMsk 256a Const
D EdtMskLen 10u 0 Const
**-- Materialize machine attributes:
D MatMatr Pr ExtProc('_MATMATR1')
D Atr 32767a Options( *VarSize )
D Opt 2a Const
**-- Test bit in string:
D tstbts Pr 10i 0 ExtProc( 'tstbts' )
D string * Value
D bitofs 10u 0 Value
**-- Get system state:
D GetSysStt Pr 1a Varying
**-- Get system value:
D GetSysVal Pr 4096a Varying
D PxSysVal 10a Const
**-- Get network attribute
D GetNetAtr Pr 4096a Varying
D PxNetAtr 10a Const
**-- Get system release level:
D GetRlsLvl Pr 6a
**-- Get IPL timestamp:
D GetIplDts Pr z
**-- Get cumulative PTF package level:
D GetCumLvl Pr 5s 0
**-- Get processor group:
D GetPrcGrp Pr 4a
**-- Get processor type:
D GetPrcTyp Pr 4a
**-- Get key position:
D GetKeyPos Pr 6a
**-- Get IPL type:
D GetIplTyp Pr 1a
**-- Edit code:
D EditC Pr 256a Varying
D PxDecVar * Value
D PxDecTyp 1a Const
D PxDecDig 5u 0 Const
D PxDecPos 5u 0 Const
D PxEdtCde 1a Const
**-- Apply decimal format:
D ApyDecFmt Pr 64a Varying
D PxInpStr 64a Value Varying
D PxDecPos 5u 0 Const
**-- Get system state:
P GetSysStt B Export
D Pi 1a Varying
/Free
RtvSysSts( SSTS0200
: %Size( SSTS0200 )
: 'SSTS0200'
: '*NO'
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return NULL;
Else;
Return SSTS0200.RstStt;
EndIf;
/End-Free
P GetSysStt E
**-- Get system value:
P GetSysVal B Export
D Pi 4096a Varying
D PxSysVal 10a Const
**
**-- Local variables:
D Idx s 10i 0
D SysVal s 4096a Varying
**
D RsRtnVarLen s 10i 0
D RsSysValNbr s 10i 0 Inz( %Elem( RsSysVal ))
D RsSysVal s 10a Dim( 1 )
***
D RsRtnVar Ds
D RsRtnVarNbr 10i 0
D RsRtnVarOfs 10i 0 Dim( %Elem( RsSysVal ))
D RsRtnVarDta 4096a
**
D RsSysValInf Ds Based( pSysVal )
D RsSysValKwd 10a
D RsDtaTyp 1a
D RsInfSts 1a
D RsDtaLen 10i 0
D RsDta 4096a
/Free
RsRtnVarLen = %Elem( RsSysVal ) * 24 + %Size( SysVal ) + 4;
RsSysVal(1) = PxSysVal;
RtvSysVal( RsRtnVar
: RsRtnVarLen
: RsSysValNbr
: RsSysVal
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
SysVal = NULL;
Else;
For Idx = 1 to RsRtnVarNbr;
pSysVal = %Addr( RsRtnVar ) + RsRtnVarOfs(Idx);
If RsSysValKwd = PxSysVal;
Select;
When RsDtaTyp = 'C';
SysVal = %Subst( RsDta: 1: RsDtaLen );
When RsDtaTyp = 'B';
SysVal = EditC( %Addr( RsDta ): RsDtaTyp: 10: 0: 'P' );
Other;
SysVal = NULL;
EndSl;
EndIf;
EndFor;
EndIf;
Return SysVal;
/End-Free
P GetSysVal E
**-- Get network attribute: --------------------------------------------**
P GetNetAtr B Export
D Pi 4096a Varying
D PxNetAtr 10a Const
**
**-- Local variables:
D Idx s 10i 0
D NetAtr s 4096a Varying
**
D RnRtnAtrLen s 10i 0
D RnNetAtrNbr s 10i 0 Inz( %Elem( RnNetAtr ))
D RnNetAtr s 10a Dim( 1 )
**
D RnRtnVar Ds
D RnRtnVarNbr 10i 0
D RnRtnVarOfs 10i 0 Dim( %Elem( RnNetAtr ))
D RnRtnVarDta 4096a
**
D RnRtnAtr Ds Based( RtnValPtr )
D RnAtrNam 10a
D RnDtaTyp 1a
D RnInfSts 1a
D RnDtaLen 10i 0
D RnDta 4096a
/Free
RnRtnAtrLen = %Elem( RnNetAtr ) * 24 + ( %Size( NetAtr )) + 4;
RnNetAtr(1) = PxNetAtr;
RtvNetAtr( RnRtnVar
: RnRtnAtrLen
: RnNetAtrNbr
: RnNetAtr
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
NetAtr = NULL;
Else;
For Idx = 1 to RnRtnVarNbr;
RtnValPtr = %Addr( RnRtnVar ) + RnRtnVarOfs(Idx);
If RnAtrNam = PxNetAtr;
Select;
When RnDtaTyp = 'C';
NetAtr = %SubSt( RnDta: 1: RnDtaLen );
When RnDtaTyp = 'B';
NetAtr = EditC( %Addr( RnDta ): RnDtaTyp: 10: 0: 'P' );
Other;
NetAtr = NULL;
EndSl;
EndIf;
EndFor;
EndIf;
Return NetAtr;
/End-Free
P GetNetAtr E
**-- Get system release level: -----------------------------------------**
P GetRlsLvl B Export
D Pi 6a
/Free
RtvPrdInf( PRDR0100
: %Size( PRDR0100 )
: 'PRDR0100'
: '*OPSYS *CUR 0000*CODE '
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
PRDR0100.Release = *Blanks;
EndIf;
Return PRDR0100.Release;
/End-Free
P GetRlsLvl E
**-- Edit code: --------------------------------------------------------**
P EditC B
D Pi 256a Varying
D PxDecVar * Value
D PxDecTyp 1a Const
D PxDecDig 5u 0 Const
D PxDecPos 5u 0 Const
D PxEdtCde 1a Const
**-- Local variables & constants:
D EdtMsk s 256a
D EdtMskLen s 10i 0
D RcvVar s 256a
D RcvVarLen s 10i 0
D ZroFilChr s 1a
D DecDig s 10u 0
**
D T_SIGNED c x'00'
D T_FLOAT c x'01'
D T_ZONED c x'02'
D T_PACKED c x'03'
D T_UNSIGNED c x'0A'
**
/Free
Select;
When PxDecTyp = 'P' Or PxDecTyp = 'Z';
If PxDecTyp = 'P';
DPA_Template_T.SclTyp = T_PACKED;
Else;
DPA_Template_T.SclTyp = T_ZONED;
EndIf;
DecDig = PxDecDig;
DPA_Template_T.DecPos = PxDecPos;
DPA_Template_T.DecLen = PxDecDig;
When PxDecTyp = 'I' Or PxDecTyp = 'U';
If PxDecTyp = 'I';
DPA_Template_T.SclTyp = T_SIGNED;
Else;
DPA_Template_T.SclTyp = T_UNSIGNED;
EndIf;
DecDig = PxDecDig;
DPA_Template_T.DecPos = *Zero;
If DecDig > 5;
DPA_Template_T.DecLen = 4;
Else;
DPA_Template_T.DecLen = 2;
EndIf;
When PxDecTyp = 'B';
DPA_Template_T.SclTyp = T_SIGNED;
DPA_Template_T.DecPos = *Zero;
DecDig = PxDecDig;
If DecDig > 5;
DecDig = 10;
DPA_Template_T.DecLen = 4;
Else;
DecDig = 5;
DPA_Template_T.DecLen = 2;
EndIf;
EndSl;
CvtCdeMsk( EdtMsk
: EdtMskLen
: RcvVarLen
: ZroFilChr
: PxEdtCde
: ' '
: DecDig
: DPA_Template_T.DecPos
: ERRC0100
);
CallP(e) Edit( %Addr( RcvVar )
: RcvVarLen
: PxDecVar
: DPA_Template_T
: EdtMsk
: EdtMskLen
);
If %Error;
Return NULL;
ElseIf PxDecTyp = 'B' And PxDecPos > *Zero;
Return %Trim( ApyDecFmt( %SubSt( RcvVar: 1: RcvVarLen ): PxDecPos ));
Else;
Return %Trim( %SubSt( RcvVar: 1: RcvVarLen ));
EndIf;
/End-Free
P EditC E
**-- Apply decimal format: ---------------------------------------------**
P ApyDecFmt B
D Pi 64a Varying
D PxInpStr 64a Value Varying
D PxDecPos 5u 0 Const
**-- Local variables:
D ZroOfs s 5u 0
D DecOfs s 5u 0
**-- Job info format JOBI0400:
D JOBI0400 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D JobNam 10a
D UsrNam 10a
D JobNbr 6a
D DecFmt 1a Overlay( JOBI0400: 457 )
/Free
RtvJobInf( JOBI0400
: %Size( JOBI0400 )
: 'JOBI0400'
: '*'
: *Blank
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return PxInpStr;
Else;
If JOBI0400.DecFmt = 'J';
ZroOfs = %Len( PxInpStr ) - PxDecPos;
DecOfs = ZroOfs + 1;
Else;
ZroOfs = %Len( PxInpStr ) - PxDecPos + 1;
DecOfs = ZroOfs;
EndIf;
PxInpStr = %Xlate( ' ': '0': PxInpStr: ZroOfs );
If JOBI0400.DecFmt = ' ';
Return %Replace( '.': PxInpStr: DecOfs: 0 );
Else;
Return %Replace( ',': PxInpStr: DecOfs: 0 );
EndIf;
EndIf;
/End-Free
P ApyDecFmt E
**-- Get Cumulative PTF package level: ---------------------------------**
P GetCumLvl B Export
D Pi 5s 0
**-- Local variables:
D Idx s 10u 0
D CumLvl s 5s 0 Inz
**-- Local constants:
D USRSPC_NAM c 'LSTPTFS QTEMP'
**-- User space generic header:
D UsrSpc Ds Qualified Based( pUsrSpc )
D OfsHdr 10i 0 Overlay( UsrSpc: 117 )
D OfsLst 10i 0 Overlay( UsrSpc: 125 )
D NumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D SizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- User space pointers:
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- Product information - QpzListPTF:
D PtfPrdInf Ds Qualified
D PrdId 7a
D Release 6a
D PrdOpt 4a
D LodId 10a
D IncSpsPtf 1a Inz( '0' )
D 22a Inz( *Allx'00' )
**-- PTF list entry:
D PTFL0100 Ds Qualified Based( pLstEnt )
D PtfId 7a
D PtfPfx 2a Overlay( PtfId: 1 )
D PtfCum 1a Overlay( PtfId: 2 )
D PtfNbr 5s 0 Overlay( PtfId: 3 )
D RelLvlPtf 6a
D RelV 1a Overlay( RelLvlPtf: 2 )
D RelR 1a Overlay( RelLvlPtf: 4 )
D RelM 1a Overlay( RelLvlPtf: 6 )
D PrdOptPtf 4a
D PrdLodPtf 4a
D LodSts 1a
D SvfSts 1a
D CvrSts 1a
D OrdSts 1a
D IplAct 1a
D ActPnd 1a
D ActReq 1a
D IplReq 1a
D PtfRls 1a
D MinLvl 2a
D MaxLvl 2a
D StsDts 13a
D StsDat 7a Overlay( StsDts: 1 )
D StsTim 6a Overlay( StsDts: 8 )
D SpsPtfId 7a
/Free
RtvPrdInf( PRDR0100
: %Size( PRDR0100 )
: 'PRDR0100'
: '*OPSYS *CUR 0000*CODE '
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
CrtUsrSpc( USRSPC_NAM
: *Blanks
: 65535
: x'00'
: '*CHANGE'
: *Blanks
: '*YES'
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
PtfPrdinf.PrdId = PRDR0100.PrdId;
PtfPrdinf.Release = PRDR0100.Release;
PtfPrdinf.PrdOpt = PRDR0100.PrdOpt;
PtfPrdinf.LodId = PRDR0100.LodId;
LstPtfs( USRSPC_NAM: PtfPrdInf: 'PTFL0100': ERRC0100 );
If ERRC0100.BytAvl = *Zero;
RtvPtrSpc( USRSPC_NAM: pUsrSpc );
pHdrInf = pUsrSpc + UsrSpc.OfsHdr;
pLstEnt = pUsrSpc + UsrSpc.OfsLst;
For Idx = 1 to UsrSpc.NumLstEnt;
If PTFL0100.PtfPfx = 'TC';
If PTFL0100.PtfNbr > CumLvl;
CumLvl = PTFL0100.PtfNbr;
EndIf;
EndIf;
If Idx < UsrSpc.NumLstEnt;
pLstEnt += UsrSpc.SizLstEnt;
EndIf;
EndFor;
EndIf;
EndIf;
DltUsrSpc( USRSPC_NAM: ERRC0100 );
EndIf;
Return CumLvl;
/End-Free
P GetCumLvl E
**-- Get IPL timestamp: ------------------------------------------------**
P GetIplDts B Export
D Pi z
**
D IplDts Ds 17 Qualified
D Date 8a
D Time 6a
/Free
MatMatr( MatInzSts: x'0108' );
CvtDtf( '*DTS': MatInzSts.StrIpl: '*YYMD': IplDts: ERRC0100 );
Return %Date( IplDts.Date: *ISO0 ) + %Time( IplDts.Time: *HMS0 );
/End-Free
P GetIplDts E
**-- Get processor group: ----------------------------------------------**
P GetPrcGrp B Export
D Pi 4a
**
D matmatr Pr ExtProc( 'matmatr' )
D mchatr * Value
D mchatrlen 5i 0 Value
**
D MMTR_012C_T Ds 2616 Qualified
D BytPrv 10i 0 Inz( %Size( MMTR_012C_T ))
D BytAvl 10i 0
D reserved 8a
D Mem_Offset 10i 0
D Proc_Offset 10i 0
D Col_Offset 10i 0
D CEC_Offset 10i 0
D Panel_Offset 10i 0
**
D CEC_VPD_T Ds Qualified Based( pCEC_VPD_T )
D CEC_read 4a
D Manufacturing 4a
D reserved1 4a
D Type 4a
D Model 4a
D Pseudo_Model 4a
D Group_Id 4a
D reserved2 4a
D Sys_Type_Ext 1a
D Feature_Code 4a
D Serial_No 10a
D reserved3 1a
**
D MMTR_VPD c x'012c'
/Free
matmatr( %Addr( MMTR_012C_T ): MMTR_VPD );
pCEC_VPD_T = %Addr( MMTR_012C_T ) + MMTR_012C_T.CEC_Offset;
Return %Trim( CEC_VPD_T.Group_Id );
/End-Free
P GetPrcGrp E
**-- Get processor type: -----------------------------------------------**
P GetPrcTyp B Export
D Pi 4a
**
D matmatr Pr ExtProc( 'matmatr' )
D mchatr * Value
D mchatrlen 5i 0 Value
**
D MMTR_012C_T Ds 2616 Qualified
D BytPrv 10i 0 Inz( %Size( MMTR_012C_T ))
D BytAvl 10i 0
D reserved 8a
D Mem_Offset 10i 0
D Proc_Offset 10i 0
D Col_Offset 10i 0
D CEC_Offset 10i 0
D Panel_Offset 10i 0
**
D CEC_VPD_T Ds Qualified Based( pCEC_VPD_T )
D CEC_read 4a
D Manufacturing 4a
D reserved1 4a
D Type 4a
D Model 4a
D Pseudo_Model 4a
D Group_Id 4a
D reserved2 4a
D Sys_Type_Ext 1a
D Feature_Code 4a
D Serial_No 10a
D reserved3 1a
**
D MMTR_VPD c x'012c'
/Free
matmatr( %Addr( MMTR_012C_T ): MMTR_VPD );
pCEC_VPD_T = %Addr( MMTR_012C_T ) + MMTR_012C_T.CEC_Offset;
Return CEC_VPD_T.Type;
/End-Free
P GetPrcTyp E
**-- Get key position: -------------------------------------------------**
P GetKeyPos B Export
D Pi 6a
**
D MMTR_0168_T Ds Qualified
D BytPrv 10i 0 Inz( %Size( MMTR_0168_T ))
D BytAvl 10i 0
D CurIplTyp 1a
D BitMap 1a
D 6a
D PrvIplTyp 1a
**
D MMTR_PANEL_STATUS...
D c x'0168'
/Free
MatMatr( MMTR_0168_T: MMTR_PANEL_STATUS );
Select;
When tstbts( %Addr( MMTR_0168_T.BitMap ): 4 ) = 1;
Return 'Auto';
When tstbts( %Addr( MMTR_0168_T.BitMap ): 5 ) = 1;
Return 'Normal';
When tstbts( %Addr( MMTR_0168_T.BitMap ): 6 ) = 1;
Return 'Manual';
When tstbts( %Addr( MMTR_0168_T.BitMap ): 7 ) = 1;
Return 'Secure';
Other;
Return *Blanks;
EndSl;
/End-Free
P GetKeyPos E
**-- Get IPL type: -----------------------------------------------------**
P GetIplTyp B Export
D Pi 1a
**
D MMTR_0168_T Ds Qualified
D BytPrv 10i 0 Inz( %Size( MMTR_0168_T ))
D BytAvl 10i 0
D CurIplTyp 1a
D BitMap 1a
D 6a
D PrvIplTyp 1a
**
D MMTR_PANEL_STATUS...
D c x'0168'
/Free
MatMatr( MMTR_0168_T: MMTR_PANEL_STATUS );
Return MMTR_0168_T.CurIplTyp;
/End-Free
P GetIplTyp E
A Test Program
**
** Program . . : CBX131T
** Description : Retrieve system information - test
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 24, 2005
**
** Program summary
** ---------------
**
** User interface manager APIs:
** QUILNGTX Display long text Displays the text string passed
** to the API in a pop-up window.
** Optionally a panel title can be
** retrieved from a message file.
**
** Maximum string length is 15360k.
**
** 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.
**
** QMHRCVPM Receive program Returns information describing
** message the selected message in a call
** message queue or, as in this
** case, an external message queue.
**
**
** Programmer's notes:
** To run this API Example program issue the following command from
** a command line:
**
** Call Pgm( CBX131T )
**
**
** Compile options required:
** CrtRpgMod Module( CBX131T )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX131T )
** Module( CBX131T )
** BndSrvPgm( CBX131 )
** ActGrp( QILE )
**
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- 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 SysCcsId s 10i 0
D NetVrtAutDev s 10i 0
D SysVal s 128a Varying
**-- Global constants:
D NULL c ''
**-- Get system release level:
D GetRlsLvl Pr 6a
**-- Get system state:
D GetSysStt Pr 1a Varying
**-- Get system value:
D GetSysVal Pr 4096a Varying
D PxSysVal 10a Const
**-- Get network attribute:
D GetNetAtr Pr 4096a Varying
D PxNetAtr 10a Const
**-- Get IPL timestamp:
D GetIplDts Pr z
**-- Get cumulative PTF package level:
D GetCumLvl Pr 5s 0
**-- Get processor group:
D GetPrcGrp Pr 4a
**-- Get processor type:
D GetPrcTyp Pr 4a
**-- Get key position:
D GetKeyPos Pr 6a
**-- Get IPL type:
D GetIplTyp Pr 1a
**-- Display long text:
D DspLngTxt Pr ExtPgm( 'QUILNGTX' )
D DtLngTxt 32767a Const Options( *VarSize )
D DtLngTxtLen 10i 0 Const
D DtMsgId 7a Const
D DtMsgF 20a Const
D DtError 32767a Const Options( *VarSize )
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 512a Const Options( *VarSize )
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 512a Options( *VarSize )
**
D SpCalStkElen 10i 0 Const Options( *NoPass )
D SpCalStkEq 20a Const Options( *NoPass )
D SpDspWait 10i 0 Const Options( *NoPass )
**
D SpCalStkEtyp 20a Const Options( *NoPass )
D SpCcsId 10i 0 Const Options( *NoPass )
**-- Receive program message:
D RcvPgmMsg Pr ExtPgm( 'QMHRCVPM' )
D RpRcvVar 32767a Options( *VarSize )
D RpRcvVarLen 10i 0 Const
D RpFmtNam 10a Const
D RpCalStkE 256a Const Options( *VarSize )
D RpCalStkCtr 10i 0 Const
D RpMsgTyp 10a Const
D RpMsgKey 4a Const
D RpWait 10i 0 Const
D RpMsgAct 10a Const
D RpError 32767a Options( *VarSize )
**
D RpCalStkElen 10i 0 Const Options( *NoPass ) call stack counter
D RpCalStkEq 20a Const Options( *NoPass ) call stack counter
**
D RpCalStkEtyp 20a Const Options( *NoPass ) call stack counter
D RpCcsId 10i 0 Const Options( *NoPass ) call stack counter
**-- Prototype atoi:
D Int Pr 10i 0 ExtProc( 'atoi' )
D Num * Value Options( *String )
**-- Prototype atoll:
D Long Pr 20i 0 ExtProc( 'atoll' )
D Num * Value Options( *String )
**-- Display message window:
D DspMsgWdw Pr
D PxMsgStr 512a Const Varying
**-- Get inquiry message reply:
D GetInqRpy Pr 10a Varying
D PxMsgDta 512a Const Varying
/Free
DspMsgWdw ( 'Last system IPL date and time: ' + %Char( GetIplDts()));
DspMsgWdw ( 'Current system CUM level: ' + %Char( GetCumLvl()));
DspMsgWdw ( 'Current system state: ''' + GetSysStt() +
''' 0=Non-restricted, 1=Restricted' );
DspMsgWdw ( 'Current system release level: ' + GetRlsLvl());
DspMsgWdw ( 'System processor group: ' + GetPrcGrp());
DspMsgWdw ( 'System processor type: ' + GetPrcTyp());
DspMsgWdw ( 'System panel key lock position: ' + GetKeyPos());
DspMsgWdw ( 'System panel current IPL type: ''' + GetIplTyp() + '''' );
DspMsgWdw ( 'System value ''QUSRLIBL'': ' +
GetSysVal( 'QUSRLIBL' ));
DspMsgWdw ( 'System value ''QCCSID'': ' +
GetSysVal( 'QCCSID' ));
SysCcsId = Int( GetSysVal( 'QCCSID' ));
DspMsgWdw ( 'System value ''QSRLNBR'': ' +
GetSysVal( 'QSRLNBR' ));
DspMsgWdw ( 'Net attribute ''DDMACC'': ' +
GetNetAtr( 'DDMACC' ));
DspMsgWdw ( 'Net attribute ''VRTAUTODEV'': ' +
GetNetAtr( 'VRTAUTODEV' ));
NetVrtAutDev = Int( GetNetAtr( 'VRTAUTODEV' ));
DspMsgWdw ( 'Net attribute ''SYSNAME'': ' +
GetNetAtr( 'SYSNAME' ));
SysVal = GetInqRpy( 'Please enter a system value to retrieve:' );
DspMsgWdw ( 'System value ''' + SysVal + ''': ' +
GetSysVal( SysVal ));
Return;
/End-Free
**-- Display message window: -------------------------------------------**
P DspMsgWdw B
D Pi
D PxMsgStr 512a Const Varying
/Free
DspLngTxt( PxMsgStr: %Len( PxMsgStr ): *Blanks: *Blanks: ERRC0100 );
/End-Free
P DspMsgWdw E
**-- Get inquiry message reply: ----------------------------------------**
P GetInqRpy B
D Pi 10a Varying
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
**-- Message information structure:
D RCVM0100 Ds Qualified
D BytPrv 10i 0
D BytAvl 10i 0
D MsgSev 10i 0
D MsgId 7a
D MsgTyp 2a
D MsgKey 4a
D 7a
D CcsIdCnvSts 10i 0
D CcsIdDta 10i 0
D MsgLenRtn 10i 0
D MsgLenAvl 10i 0
D MsgRpy 32a
/Free
SndPgmMsg( *Blanks
: *Blanks
: PxMsgDta
: %Len( PxMsgDta )
: '*INQ'
: '*EXT'
: *Zero
: MsgKey
: ERRC0100
);
RcvPgmMsg( RCVM0100
: %Size( RCVM0100 )
: 'RCVM0100'
: '*'
: *Zero
: '*RPY'
: MsgKey
: -1
: '*OLD'
: ERRC0100
);
If RCVM0100.MsgLenRtn > 10;
RCVM0100.MsgLenRtn = 10;
EndIf;
Return %Subst( RCVM0100.MsgRpy: 1: RCVM0100.MsgLenRtn );
/End-Free
P GetInqRpy E
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
|
QGYOLJBL, QGYGTLE & QGYCLST
| |
Open list of joblog messages
**
** Program summary
** ---------------
**
** Message handling API:
** QGYOLJBL Open list of joblog Lists messages from the specified
** messages job's joblog in sending data and
** time order. Replies to inquiry-
** messages are listed immediately
** after the message it is associated
** with.
**
** The QGYOLJBL API is found in the
** QGY library as are all other open
** list APIs - prior to V5R3.
**
** 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.
** Storage allocated is freed.
**
** Sequence of events:
** 1. The API input parameters are initialized
**
** 2. The open list of joblog messages API is called
**
** 3. If an error occurred calling the API or
** no entry is found blanks are returned to
** the caller
**
** 4. The most recent joblog message CPIAD02 message
** data is retrieved and returned to the caller.
**
**
** Parameters:
** PxJobId INPUT Qualified job name of the job whose joblog
** messages are to be listed. The following
** format applies:
**
** 1-10 Char 10 Job name
** 11-20 Char 10 Job user
** 21-26 Char 6 Job number
**
** The special value '*' is allowed. This value
** identifies the current job.
**
** PxMsgDta OUTPUT The IP address portion of the most recent
** found message CPIAD02 is returned. If no
** CPIAD02 is found blanks are returned.
**
**
** Programmer's note:
** As mentioned above library QGY must be in the job library list
** to succesfully run this program on releases prior to V5R3.
**
** To list another user's joblog *JOBCTL special authority is
** required.
**
** To list the joblog of a user having user class *SECOFR, special
** authority *ALLOBJ is required.
**
**
** Compile options:
**
** CrtRpgMod Module( CXM101 )
**
** CrtPgm Srvpgm( CXM101 )
** Module( CXM101 )
** ActGrp( QILE )
**
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt )
**-- 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
**-- API parameters: ---------------------------------------------------**
D RtnRcdNbr s 10i 0
**
D SltInf Ds Qualified
D RtvDrc 10a
D JobId 26a Inz( '*' )
D IntJobId 16a
D StrKey 4a
D MsgLenMax 10i 0 Inz( -1 )
D HlpLenMax 10i 0 Inz( 0 )
D FldIdsOfs 10i 0 Inz( 84 )
D FldIdsNbr 10i 0 Inz( %Elem( SltInf.FldIds ))
D CalMsqOfs 10i 0 Inz( 88 )
D CalMsqLen 10i 0 Inz( 1 )
D 4a
D FldIds 10i 0 Dim( 1 ) Inz( 201 )
D CalMsq 10a Inz( '*' )
**
D LstInf Ds Qualified
D RcdNbrTot 10i 0
D RcdNbrRtn 10i 0
D Handle 4a
D RcdLen 10i 0
D InfSts 1a
D TimStp 13a
D LstSts 1a
D 1a
D InfLen 10i 0
D Rcd1 10i 0
D 40a
**
D OLJL0100 Ds 32767 Qualified
D NxtMsgOfs 10i 0
D FldDtaOfs 10i 0
D FldNbrOfs 10i 0
D MsgSev 10i 0
D MsgId 7a
D MsgTyp 2a
D MsgKey 4a
D MsgF 10a
D MsgFlib 10a
D DatSnt 7a
D TimSnt 6a
D MicSec 6a
**
D FldDta Ds Qualified Based( pFldDta )
D NxtFldOfs 10i 0
D FldDtaLen 10i 0
D FldId 10i 0
D DtaTyp 1a
D DtaSts 1a
D 14a
D DtaLen 10i 0
D Dta 1024a
**-- Open list of job log messages:
D LstLogMsg Pr ExtPgm( 'QGYOLJBL' )
D LlRcvVar 65535a Options( *VarSize )
D LlRcvVarLen 10i 0 Const
D LlLstInf 80a
D LlNbrRcdRtn 10i 0 Const
D LlLogSltInf 1024a Const Options( *VarSize )
D LlLogSltLen 10i 0 Const
D LlError 1024a Options( *VarSize )
**-- Get list entry:
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list:
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
D CXM101 Pr
D PxJobId 26a
D PxMsgDta 15a
**
D CXM101 Pi
D PxJobId 26a
D PxMsgDta 15a
/Free
PxMsgDta = *Blanks;
SltInf.JobId = PxJobId;
SltInf.RtvDrc = '*PRV';
SltInf.StrKey = x'FFFFFFFF';
LstLogMsg( OLJL0100
: %Size( OLJL0100 )
: LstInf
: 1
: SltInf
: %Size( SltInf )
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
DoW LstInf.LstSts <> '2' Or LstInf.RcdNbrTot >= RtnRcdNbr;
pFldDta = %Addr( OLJL0100 ) + OLJL0100.FldDtaOfs;
If OLJL0100.MsgId = 'CPIAD02';
PxMsgDta = %Subst( FldDta.Dta: 11: FldDta.DtaLen - 10 );
Leave;
EndIf;
RtnRcdNbr += 1;
GetLstEnt( OLJL0100
: %Size( OLJL0100 )
: LstInf.Handle
: LstInf
: 1
: RtnRcdNbr
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
EndDo;
CloseLst( LstInf.Handle: ERRC0100 );
EndIf;
*InLr = *On;
Return;
/End-Free
Thanks to Carsten Flensburg
|
|
Back
Check User Special Authorities
Here is Carsten's comments to all the following programs:
The OVRGRPPRF command includes the following sources:
CBX128 -- Command processing program that performs the group
profile override.
CBX128V -- Validity checking program that performs integrity and
access control.
CBX128H -- Command help text panel group.
CBX128X -- Command definition source member.
CBX128M -- Creates and configures all command objects.
The ADDPRFAUT command includes the following sources:
CBX1291 -- Command processing program stores the profile
authorization code in a validation list.
CBX1291V -- Validity checking program that performs integrity and
access control.
CBX1291H -- Command help text panel group.
CBX1291X -- Command definition source member.
CBX1291M -- Creates and configures all command objects.
The MNGPRFAUT command includes the following sources:
CBX1292 -- Command processing program that performs the group
profile override.
CBX1292V -- Validity checking program that performs integrity and
access control.
CBX1292H -- Command help text panel group.
CBX1292X -- Command definition source member.
CBX1292M -- Creates and configures all command objects.
The PRFAUT menu includes the following source:
CBX129 -- The UIM menu source member.
Once all the above-specified source members have been copied to their
default source files and the program CBX128M has been compiled,
calling CBX128M will create all necessary command objects. Specify the
source file library as the only parameter. All the command objects
will be created in that library as well.
Call Pgm( CBX128M ) Parm( 'your source library' )
The commands' objects will be created in the library where the source
files are located. Please note that to successfully run the above
program, the user profile performing the call must have *ALLOBJ
special authority.
Please also note that the primary objective of the above commands is
to demonstrate practical use of the IFS security APIs. Before creating
and installing the objects on a production system, you should
carefully and thoroughly test the utility, to ensure that it meets
your security requirements and guidelines.
This article demonstrates the following APIs:
Get Effective Group ID (getegid) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/getegid.htm
Get Group Information using Group Name (getgrnam) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/getgrnam.htm
Set Effective Group ID (qsysetegid) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsyseteg.htm
Get Supplemental Group IDs (qsygetgroups) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsygetgroups.htm
Set Supplemental Group IDs (qsysetgroups) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsysetgroups.htm
Retrieve Job Information (QUSRJOBI) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qusrjobi.htm
Retrieve Object Information (QUSROBJD) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qusrobjd.htm
Retrieve User Information (QSYRUSRI) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsyrusri.htm
Create User Space (QUSCRTUS) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/quscrtus.htm
Delete User Space (QUSDLTUS) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qusdltus.htm
Retrieve Pointer to User Space (QUSPTRUS) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qusptrus.htm
Send Program Message (QMHSNDPM) API:
http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/QMHSNDPM.htm
Check User Special Authorities (QSYCUSRS) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QSYCUSRS.HTM
Send Journal Entry (QJOSJRNE) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QJOSJRNE.htm
The Find Validation List Entry (QsyFindValidationLstEntry) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QSYFIVLE.htm
The Find Validation List Entry Attributes
(QsyFindValidationLstEntryAttrs) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QSYFIVLA.htm
The Verify Validation List Entry (QsyVerifyValidationLstEntry) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QSYVFVLE.htm
The Add Validation List Entry (QsyAddValidationLstEntry) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsyavle.htm
The Remove Validation List Entry (QsyRemoveValidationLstEntry) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/QSYRVLE.htm
The Generate Profile Token (QsyGenPrfTkn) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsygenpt.htm
The Check Profile Token User (QsyChkPrfTknUser) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsychktu.htm
The Get Profile Token Time Out (QsyGetPrfTknTimeOut) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsygetpt.htm
The Remove Profile Token (QsyRemovePrfTkn) API:
http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qsyrptkn.htm
The following MI built-in function is demonstrated in this article:
_MODINVAU -- Modify Invocation Authority Attributes
http://publib.boulder.ibm.com/iseries/v5r1/ic2924/tstudio/tech_ref/mi/MODINVAU.htm
The following function from the ILE C runtime library is demonstrated
in this article:
strerror -- Set Pointer to Run-Time Error Message
http://publib.boulder.ibm.com/iseries/v5r2/ic2924/books/c415607107.htm#HDRSTRERRO
If you dont have all the CBX128? programs, they are here: API Page 6
The program CBX128M will be included here, as the version on page 6 is a little different.
**
** Program . . : CBX1291
** Description : Add profile authorization code - CPP
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : January 20, 2005
**
**
** Program description:
**
**
** Compile options:
** CrtRpgMod Module( CBX1291 )
** DbgView( *NONE )
** Aut( *USE )
**
** CrtPgm Pgm( CBX1291 )
** Module( CBX1291 )
** ActGrp( *NEW )
** UsrPrf( *OWNER )
** Aut( *USE )
**
** ChgObjOwn Obj( CBX1291 )
** ObjType( *PGM )
** NewOwn( QSECOFR )
**
** ChgPgm Pgm( CBX1291 )
** RmvObs( *ALL )
**
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
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 512a
**-- Global constants:
D VLD_LST c 'CBX128L'
D QSY_IN_VLDL c 0
D QSY_SYSTEM_ATTR...
D c 0
D ADP_PRV_INVLVL c 1
**-- Validation list API structures:
D Qsy_Vfy_Only s 1a Inz( '0' )
**-- Validation list attribute data:
D Qsy_Attr_Info_T...
D Ds Qualified
D Number_Attrs 10i 0 Inz( 1 )
D Res_align 12a
D Attr_Descr LikeDs( Qsy_Attr_Descr_T )
D Inz( *LikeDs )
**
D Qsy_Attr_Descr_T...
D Ds Qualified
D Attr_Location 10i 0 Inz( QSY_IN_VLDL )
D Attr_Type 10i 0 Inz( QSY_SYSTEM_ATTR )
D Attr_Res 8a Inz( *Allx'00' )
D Attr_ID_p *
D Attr_Other_Descr...
D 32a Inz( *Allx'00' )
D Attr_Data_Info...
D 96a
D Attr_VLDL LikeDs( Qsy_In_VLDL_T )
D Overlay( Attr_Data_Info: 1 )
D Inz( *LikeDs )
D Attr_In_Other...
D 96a Overlay( Attr_Data_Info: 1 )
D 64a Overlay( Attr_In_Other: 33 )
D Inz( *Allx'00' )
D Attr_Other_Data...
D 32a Inz( *Allx'00' )
**
D Qsy_In_VLDL_T Ds Qualified
D Attr_CCSID 10i 0 Inz( -1 )
D Attr_Len 10i 0 Inz( 1 )
D Attr_Res_1 8a Inz( *Allx'00' )
D Attr_Value_p *
**
D Qsy_Rtn_VLDL_Attr_T...
D Ds Qualified
D Bytes_Returned...
D 10i 0
D Bytes_Available...
D 10i 0
D Attr_Len 10i 0
D Attr_CCSID 10u 0
D Attr_Data LikeDs( Qsy_Rtn_Entry_Usage_Attr_T )
**
D Qsy_Rtn_Entry_Usage_Attr_T...
D Ds Qualified
D Create_Date 8a
D Last_Used_Date...
D 8a
D Encr_Data_Chg_Date...
D 8a
D Not_Valid_Verify_Count...
D 10i 0
**-- Validation list return data:
D Qsy_Rtn_Vld_Lst_Ent_T...
D Ds Qualified
D Entry_ID_Info LikeDs( Qsy_Entry_ID_Info_T )
D Encr_Data_Info...
D LikeDs( Qsy_Entry_Encr_Data_Info_T )
D Entry_Data_Info...
D LikeDs( Qsy_Entry_Data_Info_T )
D 4a
D AtrPtr *
**
D Qsy_Entry_ID_Info_T...
D Ds Qualified
D Entry_ID_Len 10i 0
D Entry_ID_CCSID...
D 10i 0 Inz( 65535 )
D Entry_ID 100a
**
D Qsy_Entry_Encr_Data_Info_T...
D Ds Qualified
D Encr_Data_Len 10i 0
D Encr_Data_CCSID...
D 10i 0 Inz( 65535 )
D Encr_Data 600a
**
D Qsy_Entry_Data_Info_T...
D Ds Qualified
D Entry_Data_Len...
D 10i 0
D Entry_Data_CCSID...
D 10i 0
D Entry_Data 1000a
**-- Global variables:
D AutFlg s 1a
D RtnCod s 1a
**-- Journal entry:
D JrnEntInf Ds Qualified
D InfEntRcds 10i 0 Inz( 1 )
D InfKey 10i 0 Inz( 1 )
D InfLen 10i 0 Inz( %Size( JrnEntInf.InfDta ))
D InfDta 2a
**
D JrnEntA1 Ds Qualified
D UsrPrf 10a
D GrpPrf 10a
D AutCod 10a
D RtnCod 1a
**-- Check special authority
D ChkSpcAut Pr ExtPgm( 'QSYCUSRS' )
D CsAutInf 1a
D CsUsrPrf 10a Const
D CsSpcAut 10a Const Dim( 8 ) Options( *VarSize )
D CsNbrAut 10i 0 Const
D CsCalLvl 10i 0 Const
D CsError 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Send journal entry:
D SndJrnE Pr ExtPgm( 'QJOSJRNE' )
D SjJrnNamQ 20a Const
D SjJrnEntInf 4096a Const Options( *VarSize )
D SjEntDta 32766a Const Options( *VarSize )
D SjEntDtaLen 10i 0 Const
D SjError 32767a Options( *VarSize )
**-- Add validation list entry:
D AddVldLstE Pr 10i 0 ExtProc( 'QsyAddValidation+
D LstEntry' )
D AvLstNam 20a Const
D AvEntId * Value
D AvEncDta * Value
D AvEntDta * Value
D AvAtrDta * Value
**-- Remove validation list entry:
D RmvVldLstE Pr 10i 0 ExtProc( 'QsyRemoveValidation+
D LstEntry' )
D RvLstNam 20a Const
D RvEntId * Value
**-- Add user password:
D AddUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUrsId 20a Const
D PxAutCod 10a Const
D PxUsrDsc 50a Const
**-- Remove user password:
D RmvUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
**-- Send diagnostic message:
D SndDiagMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send completion message:
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Entry parameters:
D CBX1291 Pr
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxAutCod 10a
D PxReason 256a Varying
D PxVldTim 5i 0
D PxRplCod 1a
**
D CBX1291 Pi
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxAutCod 10a
D PxReason 256a Varying
D PxVldTim 5i 0
D PxRplCod 1a
/Free
RtnCod = '0';
If PxUsrPrf = PgmSts.UsrPrf;
RtnCod = '1';
SndDiagMsg( 'Self authorization is not allowed.' );
Else;
ChkSpcAut( AutFlg
: PgmSts.UsrPrf
: '*SECADM'
: 1
: ADP_PRV_INVLVL
: ERRC0100
);
If ERRC0100.BytAvl > *Zero Or AutFlg = 'N';
RtnCod = '2';
SndDiagMsg( 'Special authority *SECADM required.' );
Else;
If PxRplCod = 'Y';
RmvUsrPwd( VLD_LST: '*LIBL': PxUsrPrf + PxGrpPrf );
EndIf;
If AddUsrPwd( VLD_LST
: '*LIBL'
: PxUsrPrf + PxGrpPrf
: PxAutCod
: %Char( %Timestamp() + %Minutes( PxVldTim ))
) = *Zero;
SndCmpMsg( 'Authorization code added.' );
Else;
RtnCod = '3';
SndDiagMsg( 'Unexpected error occurred.' );
EndIf;
EndIf;
EndIf;
JrnEntInf.InfDta = 'A1';
JrnEntA1.UsrPrf = PxUsrPrf;
JrnEntA1.GrpPrf = PxGrpPrf;
JrnEntA1.AutCod = PxAutCod;
JrnEntA1.RtnCod = RtnCod;
SndJrnE( 'QAUDJRN *LIBL '
: JrnEntInf
: JrnEntA1
: %Size( JrnEntA1 )
: ERRC0100
);
If RtnCod > '0';
SndEscMsg( 'ADDPRFAUT command ended in error' );
EndIf;
*InLr = *On;
Return;
/End-Free
**-- Send diagnostic message: ------------------------------------------**
P SndDiagMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*DIAG'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndDiagMsg E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9898'
: 'QCPFMSG *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
**-- Add user password: ------------------------------------------------**
P AddUsrPwd B Export
D Pi 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
D PxUsrPwd 10a Const
D PxUsrDsc 50a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Reset Qsy_Entry_Encr_Data_Info_T;
Reset Qsy_Entry_Data_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Qsy_Entry_Encr_Data_Info_T.Encr_Data = PxUsrPwd;
Qsy_Entry_Encr_Data_Info_T.Encr_Data_Len = %Len( %TrimR( PxUsrPwd ));
Qsy_Entry_Data_Info_T.Entry_Data = PxUsrDsc;
Qsy_Entry_Data_Info_T.Entry_Data_Len = %Len( %TrimR( PxUsrDsc ));
Qsy_Attr_Info_T.Attr_Descr.Attr_ID_p = %Alloc( 15 );
%Str( Qsy_Attr_Info_T.Attr_Descr.Attr_ID_p: 15 ) = 'QsyEncryptData';
Qsy_Attr_Info_T.Attr_Descr.Attr_VLDL.Attr_Len = %Size( Qsy_Vfy_Only );
Qsy_Attr_Info_T.Attr_Descr.Attr_VLDL.Attr_Value_p =
%Addr( Qsy_Vfy_Only );
Return AddVldLstE( PxVldLst + PxVldLstLib
: %Addr( Qsy_Entry_ID_Info_T )
: %Addr( Qsy_Entry_Encr_Data_Info_T )
: %Addr( Qsy_Entry_Data_Info_T )
: %Addr( Qsy_Attr_Info_T )
);
/End-Free
P AddUsrPwd E
**-- Remove user password: ---------------------------------------------**
P RmvUsrPwd B Export
D Pi 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Return RmvVldLstE( PxVldLst + PxVldLstLib
: %Addr( Qsy_Entry_ID_Info_T )
);
/End-Free
P RmvUsrPwd E
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtMnu Menu( PRFAUT )
.* Type( *UIM )
.* SrcFile( QMNUSRC )
.* SrcMbr( CBX129 )
.* Aut( *USE )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
.*
:IMPORT PNLGRP='CBX128H' NAME='OVRGRPPRF'.
:IMPORT PNLGRP='CBX1291H' NAME='ADDPRFAUT'.
:IMPORT PNLGRP='CBX1292H' NAME='MNGPRFAUT'.
:IMPORT PNLGRP='QHWCCMD' NAME='SIGNOFF'.
.*
:VAR NAME=ZMENU.
:COND NAME=OvrOk EXPR='CHKOBJ("OVRGRPPRF", "*CMD", "*USE")'.
:COND NAME=AddOk EXPR='CHKOBJ("ADDPRFAUT", "*CMD", "*USE")'.
:COND NAME=MngOk EXPR='CHKOBJ("MNGPRFAUT", "*CMD", "*USE")'.
.*
:KEYL NAME=SMALL HELP=FKHLP.
:KEYI KEY=F1 HELP=F1HLP ACTION='HELP'.
:KEYI KEY=F3 HELP=F3HLP ACTION='EXIT SET' VARUPD=NO .F3=Exit
:KEYI KEY=F4 HELP=F4HLP ACTION='PROMPT' .F4=Prompt
:KEYI KEY=F9 HELP=F9HLP ACTION='RETRIEVE' .F9=Retrieve
:KEYI KEY=F12 HELP=F12HLP ACTION='CANCEL SET' VARUPD=NO .F12=Cancel
:KEYI KEY=Enter HELP=ENHLP ACTION='ENTER'.
:KEYI KEY=Help HELP=HPHLP ACTION='HELP'.
:KEYI KEY=Pageup HELP=PUHLP ACTION='PAGEUP'.
:KEYI KEY=Pagedown HELP=PDHLP ACTION='PAGEDOWN'.
:KEYI KEY=Print HELP=PRHLP ACTION='PRINT'.
:EKEYL.
.*
:PANEL NAME=MAIN
HELP=MAINHLP
KEYL=SMALL
PANELID=ZMENU
TOPSEP=SYSNAM
ENTER='MSG CPD9817 QCPFMSG'
.Profile Authorization Menu
:MENU DEPTH='*'
SCROLL=YES.
:TOPINST .Select one of the following:
.*
:MENUGRP .Override commands
:MENUI OPTION=1
HELP=OP1HLP
ACTION='CMD ?OVRGRPPRF'
COND=OvrOk
.Override group profile OVRGRPPRF
:EMENUGRP.
.*
:MENUGRP .Management commands
:MENUI OPTION=11
HELP=OP11HLP
ACTION='CMD ?ADDPRFAUT'
COND=AddOk
.Add profile authorization ADDPRFAUT
:MENUI OPTION=12
HELP=OP12HLP
ACTION='CMD ?MNGPRFAUT'
COND=MngOk
.Manage profile authorization MNGPRFAUT
:EMENUGRP.
.*
:MENUGRP .Service options
:MENUI OPTION=90
HELP=OP90HLP
ACTION='CMD SIGNOFF'
.Sign off SIGNOFF
:EMENUGRP.
:EMENU.
.*
:CMDLINE SIZE=SHORT .Selection or command
:EPANEL.
.*
:HELP NAME=MAINHLP .Main help
:P.
The Profile Authorization (PRFAUT) menu allows you to work with the
profile authorization commands. Only commands to which you have *USE
authority to are displayed. Contact your security officer to obtain
any missing authorization to the Profile Authorization commands.
:EHELP.
.*
:HELP NAME=FKHLP .Function keys
:EHELP.
.*
:HELP NAME=F1HLP.
:PARML.
:PT.F1=Help
:PD.Shows additional information about the display or option you
selected.
:EPARML.
:EHELP.
.*
:HELP NAME=F3HLP.
:PARML.
:PT.F3=Exit
:PD.Ends the current task and returns you to the display from which the
task was started.
:EPARML.
:EHELP.
.*
:HELP NAME=F4HLP.
:PARML.
:PT.F4=Prompt
:PD.Provides assistance in entering or selecting a command.
:EPARML.
:EHELP.
.*
:HELP NAME=F9HLP.
:PARML.
:PT.F9=Retrieve
:PD.Displays the last command you ran from the command line, and any
parameters you selected. By pressing this key once, you will see the
last command you ran. By pressing this key twice, you will see the
next-to-last command that you ran, and so on.
:EPARML.
:EHELP.
.*
:HELP NAME=F12HLP.
:PARML.
:PT.F12=Cancel
:PD.Returns to the previous menu or display.
:EPARML.
:EHELP.
.*
:HELP NAME=ENHLP.
:PARML.
:PT.Enter
:PD.Submits information on the display for processing.
:EPARML.
:EHELP.
.*
:HELP NAME=HPHLP.
:PARML.
:PT.Help
:PD.Shows additional information about the display or option you
selected.
:EPARML.
:EHELP.
.*
:HELP NAME=PDHLP.
:PARML.
:PT.Page Down (Roll Up)
:PD.Moves forward to show additional messages for this display.
:EPARML.
:EHELP.
.*
:HELP NAME=PUHLP.
:PARML.
:PT.Page Up (Roll Down)
:PD.Moves backward to show additional messages for this display.
:EPARML.
:EHELP.
.*
:HELP NAME=PRHLP.
:PARML.
:PT.Print
:PD.Prints information currently shown on the display
:EPARML.
:EHELP.
.*
:HELP NAME=OP1HLP .Override group profile
:XH3.Option 1 -- Override group profile
:IMHELP NAME='OVRGRPPRF'.
:EHELP.
.*
:HELP NAME=OP11HLP .Add profile authorization
:XH3.Option 11 -- Add profile authorization
:IMHELP NAME='ADDPRFAUT'.
:EHELP.
.*
:HELP NAME=OP12HLP .Manage profile authorization
:XH3.Option 12 -- Manage profile authorization
:IMHELP NAME='MNGPRFAUT'.
:EHELP.
.*
:HELP NAME=OP90HLP .Sign off
:XH3.Option 90 -- Sign off
:IMHELP NAME='SIGNOFF'.
:EHELP.
.*
:EPNLGRP.
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX1291H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='ADDPRFAUT'.Add Profile Authorization Code - Help
:P.
The Add Profile Authorization Code (ADDPRFAUT) command registers the
authorization code that is required by the Override Group Profile
(OVRGRPPRF) command to perform a group profile override.
:P.
The authorization code is registered to a specific user profile and
group profile combination, and can only be used by that user profile to
temporarily replace a job's current primary group profile with the
specified group profile.
:P.
At release V5R1 and earlier, any special or object authority coming
from the replaced group profile is suspended during this replacement.
Likewise any object or special authority provided by the new group
profile is activated while the override is in effect.
:P.
:HP2.Restriction&COLON.:EHP2. This command requires *SECADM special
authority to run.
:P.
:HP2.Restriction&COLON.:EHP2. This command can only be run in an
interactive environment.
:P.
:EHELP.
:HELP NAME='ADDPRFAUT/USRPRF'.User profile (USRPRF) - Help
:XH3.User profile (USRPRF)
:P.
The name of the user profile for which the authorization code should be
valid.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='ADDPRFAUT/GRPPRF'.Group profile (GRPPRF) - Help
:XH3.Group profile (GRPPRF)
:P.
The name of the group profile to which the specified user profile
should be authorized to perform an override to.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='ADDPRFAUT/AUTCOD'.Authorization code (AUTCOD) - Help
:XH3.Authorization code (AUTCOD)
:P.
Specify the authorization code that must be applied by the OVRGRPPRF
command to approve the override to the specified group profile.
:P.
This is a required parameter.
:P.
:NT.
All letters are by default capitalized by this command.
:ENT.
:P.
:EHELP.
:HELP NAME='ADDPRFAUT/REASON'.Reason (REASON) - Help
:XH3.Reason (REASON)
:P.
Specify the reason for the requested override of current group profile.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='ADDPRFAUT/VLDTIM'.Valid time (VLDTIM) - Help
:XH3.Valid time (VLDTIM)
:P.
Specify the number of minutes that the authorization code should be
valid. Once the authorization code has expired it cannot be used again
until it is renewed by this command, specifying RPLAUT(*YES).
:P.
The number of minutes are calculated based on the time the
authorization code was created, as opposed to when it was first used.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.60:EPK.
:PD.
The authorization code expires 60 minutes after creation.
:PT.:PV.valid-time:EPV.
:PD.
Specify the number of minutes that the authorization code should be
available for use.
:EPARML.
:EHELP.
:HELP NAME='ADDPRFAUT/RPLAUT'.Replace authorization code (RPLAUT) - Help
:XH3.Replace authorization code (RPLAUT)
:P.
Specifies whether the authorization code should replace an already
existing authorization code for the specified user profile and group
profile.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
The authorization code does not replace an already existing
authorization code, and an error message is returned, if an
authorization code already exists.
:PT.:PK.*YES:EPK.
:PD.
If an authorization code already exists for the specified user profile
and group profile, it is replaced by this command.
:EPARML.
:EHELP.
:EPNLGRP.
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CBX1291M */
/* Description : Add profile authorization code - setup */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : January 20, 2005 */
/* */
/* */
/* Program function: Compiles, creates and configures all the */
/* ADDPRFAUT command objects. */
/* */
/* This program expects a single parameter */
/* specifying the library to contain the */
/* command objects. */
/* */
/* Object sources must exist in the respective */
/* source type default source files in the */
/* command object library. */
/* */
/* Requirements: This program must be run by a user profile */
/* having *ALLOBJ special authority. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX1291M ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm &UtlLib
Dcl &UtlLib *Char 10
MonMsg CPF0000 *N GoTo Error
CrtRpgMod &UtlLib/CBX1291 +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX1291 +
Module( &UtlLib/CBX1291 ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX1291 ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX1291 ) +
RmvObs( *ALL )
CrtRpgMod &UtlLib/CBX1291V +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX1291V +
Module( &UtlLib/CBX1291V ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX1291V ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX1291V ) +
RmvObs( *ALL )
CrtPnlGrp &UtlLib/CBX1291H +
SrcFile( &UtlLib/QPNLSRC ) +
SrcMbr( *PNLGRP )
CrtCmd Cmd( &UtlLib/ADDPRFAUT ) +
Pgm( CBX1291 ) +
SrcFile( &UtlLib/QCMDSRC ) +
SrcMbr( CBX1291X ) +
VldCkr( CBX1291V ) +
Allow( *INTERACT ) +
HlpPnlGrp( CBX1291H ) +
HlpId( *CMD ) +
Aut( *EXCLUDE )
RmvMsg Clear( *ALL )
SndPgmMsg Msg( 'Command ADDPRFAUT has been' *Bcat +
'successfully created in library' *Bcat +
&UtlLib *Tcat +
'.' ) +
MsgType( *COMP )
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
**
** Program . . : CBX1291V
** Description : Add profile authorization code - VCP
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : January 20, 2005
**
**
** Program description:
** This program checks the existence of the specified user profile
** and group profile, verifies the QSECOFR ownership of the utility
** validation list, the existence of the system audit journal QAUDJRN
** as well as the validity of the specified replace option for the
** authorization code.
**
**
** Compile options:
** CrtRpgMod Module( CBX1291V )
** DbgView( *NONE )
** Aut( *USE )
**
** CrtPgm Pgm( CBX1291V )
** Module( CBX1291V )
** ActGrp( *NEW )
** UsrPrf( *OWNER )
** Aut( *USE )
**
** ChgObjOwn Obj( CBX1291V )
** ObjType( *PGM )
** NewOwn( QSECOFR )
**
** ChgPgm Pgm( CBX1291V )
** RmvObs( *ALL )
**
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
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 512a
**-- Global constants:
D SPC_NAM_Q c 'CBX128U QTEMP'
D VLD_LST c 'CBX128L'
D QSY_IN_VLDL c 0
D QSY_SYSTEM_ATTR...
D c 0
**-- Global variables:
D AtrDta Ds Qualified
D CrtDat 8a
D LstVfyDat 8a
D PwdChgDat 8a
D InvPwdCnt 10i 0
**
D UsrDta s 128a
D PrfTkn s 32a
**
D UsrSpc Ds Qualified Based( pUsrSpc )
D DtaId 10a
D DtaLen 10i 0
D Dta Like( PrfTkn )
**-- Validation list attribute data:
D Qsy_Attr_Info_T...
D Ds Qualified
D Number_Attrs 10i 0 Inz( 1 )
D Res_align 12a
D Attr_Descr LikeDs( Qsy_Attr_Descr_T )
D Inz( *LikeDs )
**
D Qsy_Attr_Descr_T...
D Ds Qualified
D Attr_Location 10i 0 Inz( QSY_IN_VLDL )
D Attr_Type 10i 0 Inz( QSY_SYSTEM_ATTR )
D Attr_Res 8a Inz( *Allx'00' )
D Attr_ID_p *
D Attr_Other_Descr...
D 32a Inz( *Allx'00' )
D Attr_Data_Info...
D 96a
D Attr_VLDL LikeDs( Qsy_In_VLDL_T )
D Overlay( Attr_Data_Info: 1 )
D Inz( *LikeDs )
D Attr_In_Other...
D 96a Overlay( Attr_Data_Info: 1 )
D 64a Overlay( Attr_In_Other: 33 )
D Inz( *Allx'00' )
D Attr_Other_Data...
D 32a Inz( *Allx'00' )
**
D Qsy_In_VLDL_T Ds Qualified
D Attr_CCSID 10i 0 Inz( -1 )
D Attr_Len 10i 0 Inz( 1 )
D Attr_Res_1 8a Inz( *Allx'00' )
D Attr_Value_p *
**
D Qsy_Rtn_VLDL_Attr_T...
D Ds Qualified
D Bytes_Returned...
D 10i 0
D Bytes_Available...
D 10i 0
D Attr_Len 10i 0
D Attr_CCSID 10u 0
D Attr_Data LikeDs( Qsy_Rtn_Entry_Usage_Attr_T )
**
D Qsy_Rtn_Entry_Usage_Attr_T...
D Ds Qualified
D Create_Date 8a
D Last_Used_Date...
D 8a
D Encr_Data_Chg_Date...
D 8a
D Not_Valid_Verify_Count...
D 10i 0
**-- Validation list return data:
D Qsy_Rtn_Vld_Lst_Ent_T...
D Ds Qualified
D Entry_ID_Info LikeDs( Qsy_Entry_ID_Info_T )
D Encr_Data_Info...
D LikeDs( Qsy_Entry_Encr_Data_Info_T )
D Entry_Data_Info...
D LikeDs( Qsy_Entry_Data_Info_T )
D 4a
D AtrPtr *
**
D Qsy_Entry_ID_Info_T...
D Ds Qualified
D Entry_ID_Len 10i 0
D Entry_ID_CCSID...
D 10i 0 Inz( 65535 )
D Entry_ID 100a
**
D Qsy_Entry_Encr_Data_Info_T...
D Ds Qualified
D Encr_Data_Len 10i 0
D Encr_Data_CCSID...
D 10i 0 Inz( 65535 )
D Encr_Data 600a
**
D Qsy_Entry_Data_Info_T...
D Ds Qualified
D Entry_Data_Len...
D 10i 0
D Entry_Data_CCSID...
D 10i 0
D Entry_Data 1000a
**-- Journal entry:
D JrnEntInf Ds Qualified
D InfEntRcds 10i 0 Inz( 1 )
D InfKey 10i 0 Inz( 1 )
D InfLen 10i 0 Inz( %Size( JrnEntInf.InfDta ))
D InfDta 2a
**
D JrnEntA0 Ds Qualified
D UsrPrf 10a
D GrpPrf 10a
D AutCod 10a
D RplCod 1a
D VldTim 5s 0
D Reason 256a
**-- Retrieve user information:
D RtvUsrInf Pr ExtPgm( 'QSYRUSRI' )
D RuRcvVar 32767a Options( *VarSize )
D RuRcvVarLen 10i 0 Const
D RuFmtNam 10a Const
D RuUsrPrf 10a Const
D RuError 32767a Options( *VarSize )
**-- Retrieve object description:
D RtvObjD Pr ExtPgm( 'QUSROBJD' )
D RoRcvVar 32767a Options( *VarSize )
D RoRcvVarLen 10i 0 Const
D RoFmtNam 8a Const
D RoObjNamQ 20a Const
D RoObjTyp 10a Const
D RoError 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Send journal entry:
D SndJrnE Pr ExtPgm( 'QJOSJRNE' )
D SjJrnNamQ 20a Const
D SjJrnEntInf 4096a Const Options( *VarSize )
D SjEntDta 32766a Const Options( *VarSize )
D SjEntDtaLen 10i 0 Const
D SjError 32767a Options( *VarSize )
**-- Find validation list entry:
D FndVldLst Pr 10i 0 ExtProc( 'QsyFindValidation+
D LstEntry' )
D FvLstNam 20a Const
D FvEntId * Value
D FvRtnDta * Value
**-- Find validation list entry attributes:
D FndVldLstAtr Pr 10i 0 ExtProc( 'QsyFindValidation+
D LstEntryAttrs' )
D FvLstNam 20a Const
D FvEntId * Value
D FvRtnDta * Value
D FvAtrInf * Value
**-- Verify validation list entry:
D VfyVldLst Pr 10i 0 ExtProc( 'QsyVerifyValidation+
D LstEntry' )
D VvLstNam 20a Const
D VvEntId * Value
D VvEncDta * Value
**-- Get profile owner attribute:
D GetPrfOwnA Pr 10a
D PxUsrPrf 10a Value
**-- Check object existence:
D ChkObj Pr 10a
D RaObjNam 10a Const
D RaObjLib 10a Const
D RaObjTyp 10a Const
**-- Get object owner:
D GetObjOwn Pr 10a
D PxObjNam 10a Const
D RaObjLib 10a Const
D PxObjTyp 10a Const
**-- Verify validation list entry:
D VfyVldLstEnt Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
**-- Send diagnostic message:
D SndDiagMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Entry parameters:
D CBX1291V Pr
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxAutCod 10a
D PxReason 256a Varying
D PxVldTim 5i 0
D PxRplCod 1a
**
D CBX1291V Pi
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxAutCod 10a
D PxReason 256a Varying
D PxVldTim 5i 0
D PxRplCod 1a
/Free
JrnEntInf.InfDta = 'A0';
JrnEntA0.UsrPrf = PxUsrPrf;
JrnEntA0.GrpPrf = PxGrpPrf;
JrnEntA0.AutCod = PxAutCod;
JrnEntA0.RplCod = PxRplCod;
JrnEntA0.VldTim = PxVldTim;
JrnEntA0.Reason = PxReason;
SndJrnE( 'QAUDJRN *LIBL '
: JrnEntInf
: JrnEntA0
: %Size( JrnEntA0 )
: ERRC0100
);
Select;
/If Defined( *V5R2M0 )
/Else
When GetPrfOwnA( PxUsrPrf ) = '*GRPPRF';
SndDiagMsg( 'CPD0006': '0000Group profile cannot be object owner.' );
SndEscMsg( 'CPF0002': '' );
/EndIf
When ChkObj( PxUsrPrf: '*LIBL': '*USRPRF' ) = *Off;
SndDiagMsg( 'CPD0006': '0000User profile does not exist.' );
SndEscMsg( 'CPF0002': '' );
When ChkObj( PxGrpPrf: '*LIBL': '*USRPRF' ) = *Off;
SndDiagMsg( 'CPD0006': '0000Group profile does not exist.' );
SndEscMsg( 'CPF0002': '' );
When ChkObj( 'QAUDJRN': '*LIBL': '*JRN' ) = *Off;
SndDiagMsg( 'CPD0006': '0000Invalid configuration. Error code 01.' );
SndEscMsg( 'CPF0002': '' );
When GetObjOwn( VLD_LST: '*LIBL': '*VLDL' ) <> 'QSECOFR';
SndDiagMsg( 'CPD0006': '0000Invalid configuration. Error code 02.' );
SndEscMsg( 'CPF0002': '' );
Other;
ExSr ChkVldLst;
EndSl;
*InLr = *On;
Return;
BegSr ChkVldLst;
If PxRplCod = 'N';
If VfyVldLstEnt( VLD_LST: '*LIBL': PxUsrPrf + PxGrpPrf ) = *Zero;
SndDiagMsg( 'CPD0006': '0000Authorization code already exists.' );
SndEscMsg( 'CPF0002': '' );
EndIf;
EndIf;
EndSr;
/End-Free
**-- Get profile owner attribute: --------------------------------------**
P GetPrfOwnA B Export
D Pi 10a
D PxUsrPrf 10a Value
**
D USRI0200 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D UsrPrf 10a
D PrfOwnA 10a Overlay( USRI0200: 54 )
/Free
RtvUsrInf( USRI0200
: %Size( USRI0200 )
: 'USRI0200'
: PxUsrPrf
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blanks;
Else;
Return USRI0200.PrfOwnA;
EndIf;
/End-Free
P GetPrfOwnA E
**-- Check object existence: -------------------------------------------**
P ChkObj B Export
D Pi 10a
D RaObjNam 10a Const
D RaObjLib 10a Const
D RaObjTyp 10a Const
**
D OBJD0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
/Free
RtvObjD( OBJD0100
: %Size( OBJD0100 )
: 'OBJD0100'
: RaObjNam + RaObjLib
: RaObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Off;
Else;
Return *On;
EndIf;
/End-Free
P ChkObj E
**-- Get object owner: -------------------------------------------------**
P GetObjOwn B Export
D Pi 10a
D RaObjNam 10a Const
D RaObjLib 10a Const
D PxObjTyp 10a Const
**
D OBJD0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
D ObjLibRt 10a
D ObjASP 10i 0
D ObjOwn 10a
D ObjDmn 2a
/Free
RtvObjD( OBJD0100
: %Size( OBJD0100 )
: 'OBJD0100'
: RaObjNam + RaObjLib
: PxObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blanks;
Else;
Return OBJD0100.ObjOwn;
EndIf;
/End-Free
P GetObjOwn E
**-- Send diagnostic message: ------------------------------------------**
P SndDiagMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*DIAG'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndDiagMsg E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Verify validation list entry: -------------------------------------**
P VfyVldLstEnt B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 20a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Return FndVldLst( PxVldL + PxVldLlib
: %Addr( Qsy_Entry_ID_Info_T )
: %Addr( Qsy_Rtn_Vld_Lst_Ent_T )
);
/End-Free
P VfyVldLstEnt E
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( OVRGRPPRF ) */
/* Pgm( CBX128 ) */
/* SrcMbr( CBX128X ) */
/* VldCkr( CBX128V ) */
/* Allow( *INTERACT ) */
/* HlpPnlGrp( CBX128H ) */
/* HlpId( *CMD ) */
/* Aut( *EXCLUDE ) */
/* */
/* */
/* Authorize user profiles to command: */
/* */
/* GrtObjAut Obj( OVRGRPPRF ) */
/* ObjType( *CMD ) */
/* User( user profile ) */
/* Aut( *USE ) */
/* */
/* - Or use the EDTOBJAUT command: */
/* */
/* EdtObjAut Obj( OVRGRPPRF ) */
/* ObjType( *CMD ) */
/* */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Override Group Profile' )
PARM GRPPRF *Sname 10 +
Min( 1 ) +
Vary( *YES *INT2 ) +
Expr( *YES ) +
Prompt( 'Group profile' )
PARM AUTCOD *Char 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'Authorization code' )
PARM REASON *Char 256 +
Min( 1 ) +
Vary( *YES *INT2 ) +
Expr( *YES ) +
Case( *MIXED ) +
Prompt( 'Reason' )
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( ADDPRFAUT ) */
/* Pgm( CBX1291 ) */
/* SrcMbr( CBX1291X ) */
/* VldCkr( CBX1291V ) */
/* Allow( *INTERACT ) */
/* HlpPnlGrp( CBX1291H ) */
/* HlpId( *CMD ) */
/* Aut( *EXCLUDE ) */
/* */
/* */
/* Authorize user profiles to command: */
/* */
/* GrtObjAut Obj( ADDPRFAUT ) */
/* ObjType( *CMD ) */
/* User( ) */
/* Aut( *USE ) */
/* */
/* - Or use the EDTOBJAUT command: */
/* */
/* EdtObjAut Obj( ADDPRFAUT ) */
/* ObjType( *CMD ) */
/* */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Add profile authorization code' )
Parm USRPRF *Sname 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'User profile' )
Parm GRPPRF *Sname 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'Group profile' )
Parm AUTCOD *Char 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'Authorization code' )
Parm REASON *Char 256 +
Min( 1 ) +
Vary( *YES *INT2 ) +
Expr( *YES ) +
Case( *MIXED ) +
Prompt( 'Reason' )
Parm VLDTIM *Int2 +
Dft( 60 ) +
Range( 1 1440 ) +
Expr( *YES ) +
Choice( 'Minutes' ) +
Prompt( 'Valid time' )
Parm RPLAUT *Char 1 +
Rstd( *YES ) +
Dft( *NO ) +
SpcVal(( *NO N ) +
( *YES Y )) +
Expr( *YES ) +
Prompt( 'Replace authorization code' )
**
** Program . . : CBX1292
** Description : Manage profile authorization - CPP
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : January 20, 2005
**
**
** Program description:
**
**
** Compile options:
** CrtRpgMod Module( CBX1292 )
** DbgView( *NONE )
** Aut( *USE )
**
** CrtPgm Pgm( CBX1292 )
** Module( CBX1292 )
** ActGrp( *NEW )
** UsrPrf( *OWNER )
** Aut( *USE )
**
** ChgObjOwn Obj( CBX1292 )
** ObjType( *PGM )
** NewOwn( QSECOFR )
**
** ChgPgm Pgm( CBX1292 )
** RmvObs( *ALL )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
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 512a
**-- Global constants:
D VLD_LST c 'CBX128L'
D QSY_IN_VLDL c 0
D QSY_SYSTEM_ATTR...
D c 0
D ADP_PRV_INVLVL c 1
**-- Validation list API structures:
D Qsy_Vfy_Only s 1a Inz( '0' )
**-- Global variables:
D AtrDta Ds Qualified
D CrtDat 8a
D LstVfyDat 8a
D PwdChgDat 8a
D InvPwdCnt 10i 0
**
D UsrDta s 128a
**-- Validation list attribute data:
D Qsy_Attr_Info_T...
D Ds Qualified
D Number_Attrs 10i 0 Inz( 1 )
D Res_align 12a
D Attr_Descr LikeDs( Qsy_Attr_Descr_T )
D Inz( *LikeDs )
**
D Qsy_Attr_Descr_T...
D Ds Qualified
D Attr_Location 10i 0 Inz( QSY_IN_VLDL )
D Attr_Type 10i 0 Inz( QSY_SYSTEM_ATTR )
D Attr_Res 8a Inz( *Allx'00' )
D Attr_ID_p *
D Attr_Other_Descr...
D 32a Inz( *Allx'00' )
D Attr_Data_Info...
D 96a
D Attr_VLDL LikeDs( Qsy_In_VLDL_T )
D Overlay( Attr_Data_Info: 1 )
D Inz( *LikeDs )
D Attr_In_Other...
D 96a Overlay( Attr_Data_Info: 1 )
D 64a Overlay( Attr_In_Other: 33 )
D Inz( *Allx'00' )
D Attr_Other_Data...
D 32a Inz( *Allx'00' )
**
D Qsy_In_VLDL_T Ds Qualified
D Attr_CCSID 10i 0 Inz( -1 )
D Attr_Len 10i 0 Inz( 1 )
D Attr_Res_1 8a Inz( *Allx'00' )
D Attr_Value_p *
**
D Qsy_Rtn_VLDL_Attr_T...
D Ds Qualified
D Bytes_Returned...
D 10i 0
D Bytes_Available...
D 10i 0
D Attr_Len 10i 0
D Attr_CCSID 10u 0
D Attr_Data LikeDs( Qsy_Rtn_Entry_Usage_Attr_T )
**
D Qsy_Rtn_Entry_Usage_Attr_T...
D Ds Qualified
D Create_Date 8a
D Last_Used_Date...
D 8a
D Encr_Data_Chg_Date...
D 8a
D Not_Valid_Verify_Count...
D 10i 0
**-- Validation list return data:
D Qsy_Rtn_Vld_Lst_Ent_T...
D Ds Qualified
D Entry_ID_Info LikeDs( Qsy_Entry_ID_Info_T )
D Encr_Data_Info...
D LikeDs( Qsy_Entry_Encr_Data_Info_T )
D Entry_Data_Info...
D LikeDs( Qsy_Entry_Data_Info_T )
D 4a
D AtrPtr *
**
D Qsy_Entry_ID_Info_T...
D Ds Qualified
D Entry_ID_Len 10i 0
D Entry_ID_CCSID...
D 10i 0 Inz( 65535 )
D Entry_ID 100a
**
D Qsy_Entry_Encr_Data_Info_T...
D Ds Qualified
D Encr_Data_Len 10i 0
D Encr_Data_CCSID...
D 10i 0 Inz( 65535 )
D Encr_Data 600a
**
D Qsy_Entry_Data_Info_T...
D Ds Qualified
D Entry_Data_Len...
D 10i 0
D Entry_Data_CCSID...
D 10i 0
D Entry_Data 1000a
**-- Global variables:
D AutFlg s 1a
D RtnCod s 1a
**-- Check special authority
D ChkSpcAut Pr ExtPgm( 'QSYCUSRS' )
D CsAutInf 1a
D CsUsrPrf 10a Const
D CsSpcAut 10a Const Dim( 8 ) Options( *VarSize )
D CsNbrAut 10i 0 Const
D CsCalLvl 10i 0 Const
D CsError 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Find validation list entry attributes:
D FndVldLstAtr Pr 10i 0 ExtProc( 'QsyFindValidation+
D LstEntryAttrs' )
D FvLstNam 20a Const
D FvEntId * Value
D FvRtnDta * Value
D FvAtrInf * Value
**-- Remove validation list entry:
D RmvVldLstE Pr 10i 0 ExtProc( 'QsyRemoveValidation+
D LstEntry' )
D RvLstNam 20a Const
D RvEntId * Value
**-- Get usage information:
D GetUsgInf Pr 28a
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
**-- Remove user password:
D RmvUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send completion message:
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send message by type:
D SndMsgTyp Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**-- Entry parameters:
D CBX1292 Pr
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxOption 3a
**
D CBX1292 Pi
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxOption 3a
/Free
ChkSpcAut( AutFlg
: PgmSts.UsrPrf
: '*SECADM'
: 1
: ADP_PRV_INVLVL
: ERRC0100
);
If ERRC0100.BytAvl > *Zero Or AutFlg = 'N';
SndEscMsg( 'Special authority *SECADM required.' );
Else;
Select;
When PxOption = 'RMV';
If RmvUsrPwd( VLD_LST: '*LIBL': PxUsrPrf + PxGrpPrf ) = -1;
SndEscMsg( 'Unexpected error occurred.' );
Else;
SndCmpMsg( 'Authorization code removed.' );
EndIf;
When PxOption = 'VFY';
AtrDta = GetUsgInf( VLD_LST
: '*LIBL'
: PxUsrPrf + PxGrpPrf
);
If AtrDta = *Blanks;
SndEscMsg( 'Unexpected error occurred.' );
Else;
SndMsgTyp( 'CBX0001'
: 'CBX1292M'
: PxUsrPrf + PxGrpPrf + AtrDta
: '*COMP'
);
EndIf;
EndSl;
EndIf;
*InLr = *On;
Return;
/End-Free
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9898'
: 'QCPFMSG *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
**-- Send message by type: ---------------------------------------------**
P SndMsgTyp B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: PxMsgF + '*LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: PxMsgTyp
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndMsgTyp E
**-- Remove user password: ---------------------------------------------**
P RmvUsrPwd B Export
D Pi 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Return RmvVldLstE( PxVldLst + PxVldLstLib
: %Addr( Qsy_Entry_ID_Info_T )
);
/End-Free
P RmvUsrPwd E
**-- Get usage information: --------------------------------------------**
P GetUsgInf B Export
D Pi 28a
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Reset Qsy_Entry_Encr_Data_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Qsy_Attr_Info_T.Attr_Descr.Attr_ID_p = %Alloc( 14 );
%Str( Qsy_Attr_Info_T.Attr_Descr.Attr_ID_p: 14 ) = 'QsyEntryUsage';
Qsy_Attr_Info_T.Attr_Descr.Attr_VLDL.Attr_Len =
%Size( Qsy_Rtn_VLDL_Attr_T );
Qsy_Attr_Info_T.Attr_Descr.Attr_VLDL.Attr_Value_p =
%Addr( Qsy_Rtn_VLDL_Attr_T );
If FndVldLstAtr( PxVldLst + PxVldLstLib
: %Addr( Qsy_Entry_ID_Info_T )
: %Addr( Qsy_Rtn_Vld_Lst_Ent_T )
: %Addr( Qsy_Attr_Info_T )
) = -1;
Return *Blanks;
Else;
Return %SubSt( Qsy_Rtn_VLDL_Attr_T.Attr_Data
: 1
: Qsy_Rtn_VLDL_Attr_T.Attr_Len
);
EndIf;
/End-Free
P GetUsgInf E
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX1292H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='MNGPRFAUT'.Manage profile authorization - Help
:P.
The Manage Profile Authorization (MNGPRFAUT) command is used to verify
or remove authorization codes.
:P.
:NT.
The authorization codes are stored in a validation list object, that is
located by means of the library list. In the event that more copies of
the validation list is available in different libraries, the outcome of
running the profile authorization code related commands, will be
dependent on the setting of the job's library list.
:ENT.
:EHELP.
:HELP NAME='MNGPRFAUT/USRPRF'.User profile (USRPRF) - Help
:XH3.User profile (USRPRF)
:P.
The name of the user profile for which to manage the authorization
code.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='MNGPRFAUT/GRPPRF'.Group profile (GRPPRF) - Help
:XH3.Group profile (GRPPRF)
:P.
The name of the group profile for which the authorization code was
issued.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='MNGPRFAUT/OPTION'.Authorization option (OPTION) - Help
:XH3.Authorization option (OPTION)
:P.
Specifies what type of processing the requested authorization code will
be subject to.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*VERIFY:EPK.
:PD.
Verifies that the authorization code for the specified user profile and
group profile combination exists and returns the following
authorization code attributes in the second level message text of the
completion message:
:P.
:UL COMPACT.
:LI.Creation date
:LI.Last verification date
:LI.Invalid password count
:EUL.
:PT.:PK.*REMOVE:EPK.
:PD.
Removes the authorization code for the specified user profile and group
profile combination. The authorization code is removed from the system
and no information about it will remain available.
:EPARML.
:EHELP.
:EPNLGRP.
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CBX1292M */
/* Description : Manage profile authorization - setup */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : January 20, 2005 */
/* */
/* */
/* Program function: Compiles, creates and configures all the */
/* MNGPRFAUT command objects. */
/* */
/* This program expects a single parameter */
/* specifying the library to contain the */
/* command objects. */
/* */
/* Object sources must exist in the respective */
/* source type default source files in the */
/* command object library. */
/* */
/* Requirements: This program must be run by a user profile */
/* having *ALLOBJ special authority. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX1292M ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm &UtlLib
Dcl &UtlLib *Char 10
MonMsg CPF0000 *N GoTo Error
CrtRpgMod &UtlLib/CBX1292 +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX1292 +
Module( &UtlLib/CBX1292 ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX1292 ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX1292 ) +
RmvObs( *ALL )
CrtRpgMod &UtlLib/CBX1292V +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX1292V +
Module( &UtlLib/CBX1292V ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX1292V ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX1292V ) +
RmvObs( *ALL )
CrtPnlGrp &UtlLib/CBX1292H +
SrcFile( &UtlLib/QPNLSRC ) +
SrcMbr( *PNLGRP )
CrtCmd Cmd( &UtlLib/MNGPRFAUT ) +
Pgm( CBX1292 ) +
SrcFile( &UtlLib/QCMDSRC ) +
SrcMbr( CBX1292X ) +
VldCkr( CBX1292V ) +
Allow( *INTERACT ) +
HlpPnlGrp( CBX1292H ) +
HlpId( *CMD ) +
Aut( *EXCLUDE )
CrtMsgF MsgF( &UtlLib/CBX1292M )
AddMsgD MsgId( CBX0001 ) +
MsgF( &UtlLib/CBX1292M ) +
Msg( 'User profile &1 authorization code to +
group profile &2 verified.' ) +
SecLvl( 'The following authorization code +
attributes were returned: &N &B +
Creation date . . . . . . : &3 &B +
Last verification date . . : &4 &B +
Invalid password count . . : &6' ) +
Fmt(( *CHAR 10 ) ( *CHAR 10 ) +
( *DTS ) ( *DTS ) ( *DTS ) +
( *BIN 4 ))
CrtMnu Menu( &UtlLib/PRFAUT ) +
Type( *UIM ) +
SrcFile( &UtlLib/QMNUSRC ) +
SrcMbr( CBX129 ) +
Aut( *USE )
RmvMsg Clear( *ALL )
SndPgmMsg Msg( 'Command MNGPRFAUT has been' *Bcat +
'successfully created in library' *Bcat +
&UtlLib *Tcat +
'.' ) +
MsgType( *COMP )
SndPgmMsg Msg( 'Menu PRFAUT has been' *Bcat +
'successfully created in library' *Bcat +
&UtlLib *Tcat +
'.' ) +
MsgType( *COMP )
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
**
** Program . . : CBX1292V
** Description : Manage profile authorization - VCP
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : January 20, 2005
**
**
** Program description:
** This program checks the existence of the specified user profile
** and group profile.
**
**
** Compile options:
** CrtRpgMod Module( CBX1292V )
** DbgView( *NONE )
** Aut( *USE )
**
** CrtPgm Pgm( CBX1292V )
** Module( CBX1292V )
** ActGrp( *NEW )
** UsrPrf( *OWNER )
** Aut( *USE )
**
** ChgObjOwn Obj( CBX1292V )
** ObjType( *PGM )
** NewOwn( QSECOFR )
**
** ChgPgm Pgm( CBX1292V )
** RmvObs( *ALL )
**
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
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 512a
**-- Global constants:
D VLD_LST c 'CBX128L'
**-- Validation list entry ID:
D Qsy_Entry_ID_Info_T...
D Ds Qualified
D Entry_ID_Len 10i 0
D Entry_ID_CCSID...
D 10i 0 Inz( 65535 )
D Entry_ID 100a
**-- Validation list return data:
D Qsy_Rtn_Vld_Lst_Ent_T...
D Ds Qualified
D Entry_ID_Info LikeDs( Qsy_Entry_ID_Info_T )
D Encr_Data_Info...
D LikeDs( Qsy_Entry_Encr_Data_Info_T )
D Entry_Data_Info...
D LikeDs( Qsy_Entry_Data_Info_T )
D 4a
D AtrPtr *
**
D Qsy_Entry_Encr_Data_Info_T...
D Ds Qualified
D Encr_Data_Len 10i 0
D Encr_Data_CCSID...
D 10i 0 Inz( 65535 )
D Encr_Data 600a
**
D Qsy_Entry_Data_Info_T...
D Ds Qualified
D Entry_Data_Len...
D 10i 0
D Entry_Data_CCSID...
D 10i 0
D Entry_Data 1000a
**-- Retrieve object description:
D RtvObjD Pr ExtPgm( 'QUSROBJD' )
D RoRcvVar 32767a Options( *VarSize )
D RoRcvVarLen 10i 0 Const
D RoFmtNam 8a Const
D RoObjNamQ 20a Const
D RoObjTyp 10a Const
D RoError 32767a Options( *VarSize )
**-- 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 1024a Options( *VarSize )
**-- Find validation list entry:
D FndVldLst Pr 10i 0 ExtProc( 'QsyFindValidation+
D LstEntry' )
D FvLstNam 20a Const
D FvEntId * Value
D FvRtnDta * Value
**-- Check object existence:
D ChkObj Pr 10a
D RaObjNam 10a Const
D RaObjLib 10a Const
D RaObjTyp 10a Const
**-- Verify validation list entry:
D VfyVldLstEnt Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 20a Const
**-- Send diagnostic message:
D SndDiagMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Entry parameters:
D CBX1292V Pr
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxOption 3a
**
D CBX1292V Pi
D PxUsrPrf 10a
D PxGrpPrf 10a
D PxOption 3a
/Free
Select;
When ChkObj( PxUsrPrf: '*LIBL': '*USRPRF' ) = *Off;
SndDiagMsg( 'CPD0006': '0000User profile does not exist.' );
SndEscMsg( 'CPF0002': '' );
When ChkObj( PxGrpPrf: '*LIBL': '*USRPRF' ) = *Off;
SndDiagMsg( 'CPD0006': '0000Group profile does not exist.' );
SndEscMsg( 'CPF0002': '' );
When VfyVldLstEnt( VLD_LST: '*LIBL': PxUsrPrf + PxGrpPrf ) = -1;
SndDiagMsg( 'CPD0006': '0000Authorization code does not exist.' );
SndEscMsg( 'CPF0002': '' );
EndSl;
*InLr = *On;
Return;
/End-Free
**-- Check object existence: -------------------------------------------**
P ChkObj B Export
D Pi 10a
D RaObjNam 10a Const
D RaObjLib 10a Const
D RaObjTyp 10a Const
**
D OBJD0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
/Free
RtvObjD( OBJD0100
: %Size( OBJD0100 )
: 'OBJD0100'
: RaObjNam + RaObjLib
: RaObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Off;
Else;
Return *On;
EndIf;
/End-Free
P ChkObj E
**-- Send diagnostic message: ------------------------------------------**
P SndDiagMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*DIAG'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndDiagMsg E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Verify validation list entry: -------------------------------------**
P VfyVldLstEnt B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 20a Const
/Free
Reset Qsy_Entry_ID_Info_T;
Qsy_Entry_ID_Info_T.Entry_ID = PxUsrId;
Qsy_Entry_ID_Info_T.Entry_ID_Len = %Size( PxUsrId );
Return FndVldLst( PxVldL + PxVldLlib
: %Addr( Qsy_Entry_ID_Info_T )
: %Addr( Qsy_Rtn_Vld_Lst_Ent_T )
);
/End-Free
P VfyVldLstEnt E
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( MNGPRFAUT ) */
/* Pgm( CBX1292 ) */
/* SrcMbr( CBX1292X ) */
/* VldCkr( CBX1292V ) */
/* Allow( *INTERACT ) */
/* HlpPnlGrp( CBX1292H ) */
/* HlpId( *CMD ) */
/* Aut( *EXCLUDE ) */
/* */
/* */
/* Authorize user profiles to command: */
/* */
/* GrtObjAut Obj( MNGPRFAUT ) */
/* ObjType( *CMD ) */
/* User( ) */
/* Aut( *USE ) */
/* */
/* - Or use the EDTOBJAUT command: */
/* */
/* EdtObjAut Obj( MGNPRFAUT ) */
/* ObjType( *CMD ) */
/* */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Manage profile authorization' )
Parm USRPRF *Sname 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'User profile' )
Parm GRPPRF *Sname 10 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'Group profile' )
Parm OPTION *Char 3 +
Rstd( *YES ) +
Dft( *VERIFY ) +
SpcVal(( *VERIFY VFY ) +
( *REMOVE RMV )) +
Prompt( 'Authorization option' )
/*-------------------------------------------------------------------*/
/* */
/* Program . . : CBX128M */
/* Description : Override group profile - setup */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : December 16, 2004 */
/* */
/* */
/* Program function: Compiles, creates and configures all the */
/* OVRGRPPRF command objects. */
/* */
/* This program expects a single parameter */
/* specifying the library to contain the */
/* command objects. */
/* */
/* Object sources must exist in the respective */
/* source type default source files in the */
/* command object library. */
/* */
/* Requirements: This program must be run by a user profile */
/* having *ALLOBJ special authority. */
/* */
/* The system audit journal QAUDJRN must exist */
/* for this utility to run successfully. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX128M ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm &UtlLib
Dcl &UtlLib *Char 10
MonMsg CPF0000 *N GoTo Error
ChkObj QAUDJRN *JRN
CrtRpgMod &UtlLib/CBX128 +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX128 +
Module( &UtlLib/CBX128 ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX128 ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX128 ) +
RmvObs( *ALL )
CrtRpgMod &UtlLib/CBX128V +
SrcFile( &UtlLib/QRPGLESRC ) +
SrcMbr( *Module ) +
DbgView( *NONE ) +
Aut( *USE )
CrtPgm &UtlLib/CBX128V +
Module( &UtlLib/CBX128V ) +
ActGrp( *NEW ) +
UsrPrf( *OWNER ) +
Aut( *USE )
ChgObjOwn Obj( &UtlLib/CBX128V ) +
ObjType( *PGM ) +
NewOwn( QSECOFR )
ChgPgm Pgm( &UtlLib/CBX128V ) +
RmvObs( *ALL )
CrtPnlGrp &UtlLib/CBX128H +
SrcFile( &UtlLib/QPNLSRC ) +
SrcMbr( *PNLGRP )
CrtCmd Cmd( &UtlLib/OVRGRPPRF ) +
Pgm( CBX128 ) +
SrcFile( &UtlLib/QCMDSRC ) +
SrcMbr( CBX128X ) +
VldCkr( CBX128V ) +
Allow( *INTERACT ) +
HlpPnlGrp( CBX128H ) +
HlpId( *CMD ) +
Aut( *EXCLUDE )
CrtVldL VldL( &UtlLib/CBX128L )
ChgObjOwn Obj( &UtlLib/CBX128L ) +
ObjType( *VLDL ) +
NewOwn( QSECOFR )
SndPgmMsg Msg( 'Command OVRGRPPRF has been' *Bcat +
'successfully created in library' *Bcat +
&UtlLib *Tcat +
'.' ) +
MsgType( *COMP )
CrtClPgm Pgm( &UtlLib/CBX1291M ) +
SrcFile( &UtlLib/QCLSRC ) +
SrcMbr( CBX1291M ) +
Aut( *USE )
CrtClPgm Pgm( &UtlLib/CBX1292M ) +
SrcFile( &UtlLib/QCLSRC ) +
SrcMbr( CBX1292M ) +
Aut( *USE )
RmvMsg Clear( *ALL )
Call Pgm( &UtlLib/CBX1291M ) +
Parm( &UtlLib )
Call Pgm( &UtlLib/CBX1292M ) +
Parm( &UtlLib )
Call QMHMOVPM ( ' ' +
'*COMP' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Retrieve System Time Information
**-- 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 UTC s z
**-- List API parameters:
D LstApi Ds Qualified Inz
D NbrKeyRtn 10i 0 Inz( %Elem( LstApi.KeyFld ))
D KeyFld 10i 0 Dim( 1 )
**-- Time information:
D RTTM0100 Ds 4096 Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D OfsKeyFld 10i 0
D NbrKeyFld 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
**
D KeyDta Ds Qualified Inz
D TimDts 8a
**-- Retrieve system time information:
D RtvSysTim Pr ExtPgm( 'QWCRTVTM' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D NbrKeyFld 10i 0 Const
D KeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D Error 32767a Options( *VarSize )
**-- Convert date & time:
D CvtDtf Pr ExtPgm( 'QWCCVTDT' )
D InpFmt 10a Const
D InpVar 17a Const Options( *VarSize )
D OutFmt 10a Const Options( *VarSize )
D OutVar 17a Const Options( *VarSize )
D Error 32767a Options( *VarSize )
**-- Get IPL timestamp:
D CvtSysDts Pr z
D PxSysDts 8a
/Free
LstApi.KeyFld(1) = 101;
RtvSysTim( RTTM0100
: %Size( RTTM0100 )
: 'RTTM0100'
: LstApi.NbrKeyRtn
: LstApi.KeyFld
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
ExSr GetKeyDta;
EndIf;
*InLr = *On;
Return;
BegSr GetKeyDta;
pKeyInf = %Addr( RTTM0100 ) + RTTM0100.OfsKeyFld;
For Idx = 1 To RTTM0100.NbrKeyFld;
Select;
When KeyInf.KeyFld = 101;
KeyDta.TimDts = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
UTC = CvtSysDts( KeyDta.TimDts );
EndSl;
If Idx < RTTM0100.NbrKeyFld;
pKeyInf = pKeyInf + KeyInf.FldInfLen;
EndIf;
EndFor;
EndSr;
/End-Free
**-- Convert system DTS: -----------------------------------------------**
P CvtSysDts B Export
D Pi z
D PxSysDts 8a
**
D SysDts Ds 17 Qualified
D Date 8a
D Time 6a
D MS 3s 0
/Free
CvtDtf( '*DTS': PxSysDts: '*YYMD': SysDts: ERRC0100 );
Return %Date( SysDts.Date: *ISO0 ) +
%Time( SysDts.Time: *HMS0 ) +
%Mseconds( SysDts.MS * 1000 );
/End-Free
P CvtSysDts E
Thanks to Carsten Flensburg
|
|
Back
Page #7
Page #9
