**
** 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
阅读(1741) | 评论(0) | 转发(0) |
