iSeries & System i

#7 API - Table of Contents #9

API Name # Description
QSP.....   Spool File APIs
QWVOLAGP & QWVOLACT   Open list of activation group & - attributes
Qjo.......   Retrieve Journal APIs
QWCR....   Retrieve System Information APIs
QGYOLJBL, QGYGTLE & QGYCLST 4 Open list of joblog messages
QSYCUSRS & QSY.....   Check User Special Authorities
QWCRTVTM   Retrieve System Time Information



QSP.....
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

QWVOLAGP & QWVOLACT
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

QJo.....
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

QWCR.....
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

QSYCUSRS & QSY.....
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

QWCRTVTM
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

Back