iSeries & System i

#8 API - Table of Contents      

API Name # Description
QWCRLCKI & QWCRLRQI   Retrieve Lock Information/Request
QGYOLAUS   Open list of authorized users
QSYRAUTU   Retrieve authorized users
QSYLATLO   List authorization list IFS objects
QWCRDTAA   Retrieve Data Area
QgldExportLdif   Export LDIF File (LDAP)
QUSLRCD   List Record Formats (and other DBF API's)
QWCRTVCA   Retrieve Current Attributes
QWCCCJOB   Change Current Job
QGYOLSPL   Open List of Spooled Files
QSYLOBJA   List Objects User Is Authorized to, Owns, or Is Primary Group of
Qp0zGetSysEnv   Get System Level Environment



QWCRLCKI & QWCRLRQI
QWCRLCKI: Retrieve Lock Information
QWCRLRQI: Retrieve Lock Request Information

     **
     **  Program . . : CBX144
     **  Description : Retrieve lock information APIs - sample program
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : September 29, 2005
     **
     **
     **  Program summary
     **  ---------------
     **
     **
     **  Work management APIs:
     **    QWCRLCKI     Retrieve lock          Generates a list of information
     **                 information            about lock holders of the object
     **                                        specified.
     **
     **    QWCRLRQI     Retrieve lock request  Takes as input a lock request
     **                 information            handle that was returned in other
     **                                        APIs and returns information
     **                                        about the program that requested
     **                                        the lock.
     **
     **                                        This API must be called from the
     **                                        same thread that called the API
     **                                        that returned the lock request
     **                                        handle.
     **
     **  Message handling API:
     **    QMHSNDPM     Send program message   Sends a message to a program stack
     **                                        entry (current, previous, etc.) or
     **                                        an external message queue.
     **
     **                                        Both messages defined in a message
     **                                        file and immediate messages can be
     **                                        used. For specific message types
     **                                        only one or the other is allowed.
     **
     **  ILE CEE APIs:
     **    CEERTX       Register call stack    Registers a procedure that runs
     **                 entry termination      when the call stack entry, for
     **                 user exit procedure    which it is registered, is ended
     **                                        by anything other than a return
     **                                        to the caller.
     **
     **    CEEUTX       Unregister call stack  Unregisters a procedure that was
     **                 entry termination      previously registered by the
     **                 user exit procedure    CEERTX API.
     **
     **                                        The CEEUTX API operates on the
     **                                        call stack entry termination user
     **                                        exits that are registered for the
     **                                        call stack entry from which the
     **                                        CEEUTX API is called.
     **
     **  MI builtins:
     **    _MEMMOVE      Copy memory           Copies a string from one pointer
     **                                        specified location to another.
     **
     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX144 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX144 )
     **              Module( CBX146 )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )

     **-- Api error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPro                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0 Inz
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a
     **-- Global variables:
     D Idx             s             10u 0
     D IdxKey          s             10u 0
     D ApiRcvSiz       s             10u 0
     D MsgTxt          s            512a   Varying
     **-- List API parameters:
     D LstApi          Ds                  Qualified  Inz
     D  NbrKeyRtn                    10i 0 Inz( %Elem( LstApi.KeyFld ))
     D  KeyFld                       10i 0 Dim( 3 )
     **-- Global constants:
     D OFS_MSGDTA      c                   16
     D NO_RTN_KEY      c                   0
     D TYP_JOBTHR      c                   0
     D TYP_LCKSPC      c                   1
     D ALL_RCD         c                   0
     D OBJ_LVL         c                   0
     D RCD_LVL         c                   1

     **-- Object identification:
     D LOBJ0100        Ds                  Qualified
     D  ObjIdSiz                     10i 0 Inz( %Size( LOBJ0100 ))
     D  ObjNam                       10a
     D  ObjLib                       10a
     D  ObjLibAps                    10a
     D  ObjTyp                       10a
     D  MbrNam                       10a
     D                                2a   Inz( x'0000' )
     D  RcdLckI                      10i 0
     D  RelRcdNbr                    10u 0
     **
     D LOBJ0200        Ds                  Qualified
     D  ObjHdlSiz                    10i 0 Inz( %Size( LOBJ0200 ))
     D  ObjLckHdl                    64a
     **-- Lock filter:
     D LKFL0100        Ds                  Qualified
     D  FltSiz                       10i 0 Inz( %Size( LKFL0100 ))
     D  FltLckStt                    10i 0 Inz( *Zero )
     D  FltLckScp                    10i 0 Inz( *Zero )
     D  FltLckSts                    10i 0 Inz( *Zero )
     D  FltLckHlrTyp                  1a   Inz( '0' )
     D  FltMbrLckTyp                  1a   Inz( '0' )
     **-- Lock information:
     D LCKI0100        Ds                  Qualified  Based( pLckInf )
     D  BytRtn                       10i 0
     D  BytAvl                       10i 0
     D  TypEnt                       10i 0
     D  ObjNamExt                    30a
     D  ObjLib                       10a
     D  ObjAsp                       10a
     D  ObjLibAsp                    10a
     D  ObjAspNbr                    10i 0
     D  ObjLibAspNbr                 10i 0
     D  ObjTyp                       10a
     D  ExtObjAtr                    10a
     D  NbrLckInfEntA                10i 0
     D  OfsLckInfEnt                 10i 0
     D  NbrLckInfEntR                10i 0
     D  LenLckInfEnt                 10i 0
     **
     D LckInfEnt       Ds                  Based( pLckInfEnt )  Qualified
     D  LckStt                       10a
     D                                2a
     D  LckSts                       10i 0
     D  LckScp                        1a
     D                                3a
     D  LckSpcId                     20a
     D  LckRqsHdl                    64a
     D  LckCnt                       10i 0
     D  MbrNam                       10a
     D  MbrLckTyp                     1a
     D                                1a
     D  RelRcdNbr                    10i 0
     D  DisHlrInf                    10i 0
     D  DisKeyInf                    10i 0
     D  NbrKeyRtn                    10i 0
     D  HlrTyp                       10i 0
     **-- Key information:
     D KeyInf          Ds                  Based( pKeyInf )  Qualified
     D  FldInfLen                    10i 0
     D  KeyFld                       10i 0
     D  DtaTyp                        1a
     D                                3a
     D  DtaLen                       10i 0
     D  Data                         64a
     **-- Lock holder - job/thread format:
     D HlrJobThr       Ds                  Based( pJobThrFmt )  Qualified
     D  HlrInfSiz                    10i 0
     D  JobNam                       10a
     D  UsrNam                       10a
     D  JobNbr                        6a
     D  ThdId                         8a
     D                                2a
     D  ThdHdl                       10u 0
     **-- Lock holder - lock space format:
     D HlrLckSpc       Ds                  Based( pLckSpcFmt )  Qualified
     D  HlrInfSiz                    10i 0
     D  HldLckSpcId                  20a
     D  UsrNam                       10a
     D  JobNbr                        6a
     D  ThdId                         8a
     D                                2a
     D  ThdHdl                       10u 0
     **-- Lock request identification:
     D LRQI0100        Ds          4096    Qualified
     D  BytRtn                       10i 0
     D  BytAvl                       10i 0
     D  OfsStmIds                    10i 0
     D  NbrStmIds                    10i 0
     D  OfsPrcNam                    10i 0
     D  LenPrcNam                    10i 0
     D  PgmNam                       10a
     D  PgmLib                       10a
     D  PgmAsp                       10a
     D  PgmLibAsp                    10a
     D  PgmAspNbr                    10i 0
     D  PgmLibAspNbr                 10i 0
     D  MiInstNbr                    10i 0
     D  ModNam                       10a
     D  ModLib                       10a
     **-- API return information:
     D PrcNam          s           1024a   Inz  Varying
     D StmIds          s             10a   Inz  Dim( 64 )
     D pJobThrFmt      s               *   Inz( *Null )
     D pLckSpcFmt      s               *   Inz( *Null )
     **
     D KeyDta          Ds                  Qualified  Inz
     D  ActJobSts                     4a
     D  FcnNam                       10a
     D  MsgRpy                        1a

     **-- Retrieve lock information:
     D RtvLckInf       Pr                  ExtPgm( 'QWCRLCKI' )
     D  RcvVar                    65535a          Options( *VarSize )
     D  RcvVarLen                    10i 0 Const
     D  FmtNam                        8a   Const
     D  ObjId                        68a   Const  Options( *VarSize )
     D  ObjIdFmt                      8a   Const
     D  NbrKeyFld                    10i 0 Const
     D  KeyFldRtn                    10i 0 Const  Options( *VarSize )  Dim( 32 )
     D  Filter                       18a   Const  Options( *VarSize )
     D  FltFmt                        8a   Const
     D  Error                     32767a          Options( *VarSize )
     **-- Retrieve lock request information:
     D RtvLckRqsInf    Pr                  ExtPgm( 'QWCRLRQI' )
     D  RcvVar                    65535a          Options( *VarSize )
     D  RcvVarLen                    10i 0 Const
     D  FmtNam                        8a   Const
     D  RqsHdl                       64a   Const
     D  Error                     32767a          Options( *VarSize )
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  MsgId                         7a   Const
     D  MsgFq                        20a   Const
     D  MsgDta                      128a   Const
     D  MsgDtaLen                    10i 0 Const
     D  MsgTyp                       10a   Const
     D  CalStkE                      10a   Const  Options( *VarSize )
     D  CalStkCtr                    10i 0 Const
     D  MsgKey                        4a
     D  Error                     32767a          Options( *VarSize )
     **-- Register termination exit:
     D CeeRtx          Pr                    ExtProc( 'CEERTX' )
     D  procedure                      *     ProcPtr   Const
     D  token                          *     Options( *Omit )
     D  fb                           12a     Options( *Omit )
     **-- Unregister termination exit:
     D CeeUtx          Pr                    ExtProc( 'CEEUTX' )
     D  procedure                      *     ProcPtr   Const
     D  fb                           12a     Options( *Omit )
     **-- Copy memory:
     D memcpy          Pr              *   ExtProc( '_MEMMOVE' )
     D pOutMem                         *   Value
     D pInpMem                         *   Value
     D iMemSiz                       10u 0 Value

     **-- Send completion message:
     D SndCmpMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **-- Send message by type:
     D SndMsgTyp       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     D  PxMsgTyp                     10a   Const
     **-- Terminate program:
     D TrmPgm          Pr
     D  pPtr                           *

     **-- Entry parameters:
     D SavOfs          Ds                  Based( pNull )
     D  NbrElm                        5i 0
     D  DatFrm                        7a
     D  TimFrm                        6a
     **
     D CBX144          Pr
     D  PxObjNam_q                   20a
     D  PxObjTyp                     10a
     D  PxMbrNam                     10a
     D  PxRelRcdNbr                  10p 0
     **
     D CBX144          Pi
     D  PxObjNam_q                   20a
     D  PxObjTyp                     10a
     D  PxMbrNam                     10a
     D  PxRelRcdNbr                  10p 0

      /Free

        //-- Step 1:

        ExSr  InzParms;

        //-- Step 2a:

        ApiRcvSiz = 65535;
        pLckInf   = %Alloc( ApiRcvSiz );

        LCKI0100.BytAvl = *Zero;

        DoU  LCKI0100.BytAvl <= ApiRcvSiz  Or  ERRC0100.BytAvl > *Zero;

          //-- Step 2b:

          If  LCKI0100.BytAvl > ApiRcvSiz;
            ApiRcvSiz  = LCKI0100.BytAvl;
            pLckInf    = %ReAlloc( pLckInf: ApiRcvSiz );
          EndIf;

          RtvLckInf( LCKI0100
                   : ApiRcvSiz
                   : 'LCKI0100'
                   : LOBJ0100
                   : 'LOBJ0100'
                   : LstApi.NbrKeyRtn
                   : LstApi.KeyFld
                   : LKFL0100
                   : 'LKFL0100'
                   : ERRC0100
                   );
        EndDo;

        //-- Step 3:

        CeeRtx( %Paddr( TrmPgm ): pLckInf: *Omit );

        If  ERRC0100.BytAvl > *Zero;

          SndEscMsg( ERRC0100.MsgId
                   : 'QCPFMSG'
                   : %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
                   );
        Else;

          //-- Step 4:

          ExSr  PrcLstEnt;

          SndCmpMsg( 'Lock API example completed normally.' );
        EndIf;

        //-- Step 5:

        CeeUtx( %Paddr( TrmPgm ): *Omit );

        TrmPgm( pLckInf );

        *InLr = *On;
        Return;

        BegSr  InzParms;

          LOBJ0100.ObjNam    = %Subst( PxObjNam_q:  1: 10 );
          LOBJ0100.ObjLib    = %Subst( PxObjNam_q: 11: 10 );
          LOBJ0100.ObjLibAps = '*';
          LOBJ0100.ObjTyp    = PxObjTyp;
          LOBJ0100.MbrNam    = PxMbrNam;

          Select;
          When  PxRelRcdNbr = -1;
            LOBJ0100.RcdLckI   = RCD_LVL;
            LOBJ0100.RelRcdNbr = ALL_RCD;

          When  PxRelRcdNbr >  0;
            LOBJ0100.RcdLckI   = RCD_LVL;
            LOBJ0100.RelRcdNbr = PxRelRcdNbr;

          Other;
            LOBJ0100.RcdLckI   = OBJ_LVL;
            LOBJ0100.RelRcdNbr = 0;
          EndSl;

          LstApi.KeyFld(1) = 101;
          LstApi.KeyFld(2) = 601;
          LstApi.KeyFld(3) = 1307;

        EndSr;

        BegSr  PrcLstEnt;

          pLckInfEnt = pLckInf + LCKI0100.OfsLckInfEnt;

          For  Idx = 1  to LCKI0100.NbrLckInfEntR;

            If  LckInfEnt.LckStt <> '*NONE';

              If  LckInfEnt.HlrTyp = TYP_JOBTHR;
                pJobThrFmt = pLckInfEnt + LckInfEnt.DisHlrInf;
              Else;
                pLckSpcFmt = pLckInfEnt + LckInfEnt.DisHlrInf;
              EndIf;

              ExSr  GetKeyDta;

              RtvLckRqsInf( LRQI0100
                          : %Size( LRQI0100 )
                          : 'LRQI0100'
                          : LckInfEnt.LckRqsHdl
                          : ERRC0100
                          );

              If  ERRC0100.BytAvl = *Zero;
                ExSr  PrcRqsEnt;
              EndIf;

              // All retrieved data available at this point:

              If  pJobThrFmt <> *Null;
                // Job or thread information retrieved
              Else;
                // Lock space information retrieved
              EndIf;

              If  Idx < LCKI0100.NbrLckInfEntR;
                Reset  KeyDta;
                Reset  StmIds;
                Reset  PrcNam;
                Reset  pJobThrFmt;
                Reset  pLckSpcFmt;

                pLckInfEnt += LCKI0100.LenLckInfEnt;
              EndIf;
            EndIf;
          EndFor;

        EndSr;

        BegSr  PrcRqsEnt;

          If  LRQI0100.OfsPrcNam > *Zero;
            PrcNam = %Subst( LRQI0100: LRQI0100.OfsPrcNam: LRQI0100.LenPrcNam );
          EndIf;

          If  LRQI0100.OfsStmIds > *Zero;
            memcpy( %Addr( StmIds )
                  : %Addr( LRQI0100 ) + LRQI0100.OfsStmIds
                  : LRQI0100.NbrStmIds * %Size( StmIds )
                  );
          EndIf;

        EndSr;

        BegSr  GetKeyDta;

          pKeyInf = pLckInfEnt + LckInfEnt.DisKeyInf;

          For  IdxKey = 1  To LckInfEnt.NbrKeyRtn;

            Select;
            When  KeyInf.KeyFld = 101;

              KeyDta.ActJobSts = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );

            When  KeyInf.KeyFld = 601;

              KeyDta.FcnNam = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );

            When  KeyInf.KeyFld = 1307;

              KeyDta.MsgRpy = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
            EndSl;

            If  IdxKey < LckInfEnt.NbrKeyRtn;
              pKeyInf = pKeyInf + KeyInf.FldInfLen;
            EndIf;
          EndFor;

        EndSr;

      /End-Free

     **-- Send completion message:  ------------------------------------------**
     P SndCmpMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*COMP'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return  0;

        EndIf;

      /End-Free

     **
     P SndCmpMsg       E
     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : PxMsgF + '*LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndEscMsg       E
     **-- Send message by type:  ---------------------------------------------**
     P SndMsgTyp       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     D  PxMsgTyp                     10a   Const
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : PxMsgTyp
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndMsgTyp       E
     **-- Terminate program:  ------------------------------------------------**
     P TrmPgm          B
     D                 Pi
     D  pPtr                           *

      /Free

        DeAlloc  pPtr;

        *InLr = *On;

        Return;

      /End-Free

     P TrmPgm          E

/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Program . . : CBX144T                                            */
/*  Description : Retrieve lock information APIs - test              */
/*  Author  . . : Carsten Flensburg                                  */
/*  Published . : Club Tech iSeries Programming Tips Newsletter      */
/*  Date  . . . : September 29, 2005                                 */
/*                                                                   */
/*                                                                   */
/*  Compile options:                                                 */
/*    CrtClPgm    Pgm( CBX144T )                                     */
/*                SrcFile( QCLSRC )                                  */
/*                SrcMbr( *PGM )                                     */
/*                                                                   */
/*-------------------------------------------------------------------*/
     Pgm

     Dcl   &ObjNam_q   *Char      20
     Dcl   &ObjTyp     *Char      10
     Dcl   &MbrNam     *Char      10
     Dcl   &RelRcdNbr  *Dec       10

     Dcl   &ALL_RCD    *Dec       10      -1
     Dcl   &IGN_RCD    *Dec       10       0

     /*-- Retrieve object locks:  --*/
     ChgVar     &ObjNam_q    '(obj-name)(library )'
     ChgVar     &ObjTyp      '(obj-type)'
     ChgVar     &MbrNam      '*NONE     '
     ChgVar     &RelRcdNbr   &IGN_RCD

     Call       CBX144     Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )

     /*-- Retrieve file member locks:  --*/
     ChgVar     &ObjNam_q    '(filename)(library )'
     ChgVar     &ObjTyp      '*FILE     '
     ChgVar     &MbrNam      '(mbr-name)'
     ChgVar     &RelRcdNbr   &IGN_RCD

     Call       CBX144     Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )

     /*-- Retrieve file record lock - specific record:  --*/
     ChgVar     &ObjNam_q    '(filename)(library )'
     ChgVar     &ObjTyp      '*FILE     '
     ChgVar     &MbrNam      '(mbr.name)'
     ChgVar     &RelRcdNbr   27

     Call       CBX144     Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )

     /*-- Retrieve file record locks - all records:  --*/
     ChgVar     &ObjNam_q    '(filename)(library )'
     ChgVar     &ObjTyp      '*FILE     '
     ChgVar     &MbrNam      '(mbr-name)'
     ChgVar     &RelRcdNbr   &ALL_RCD

     Call       CBX144     Parm( &ObjNam_q &Objtyp &MbrNam &RelRcdNbr )
EndPgm:
     EndPgm

Important note: While testing the code included with this article, I ran into
some situations where a system module would get stuck in a loop. The situation
seems to arise when more than 800–1000 locks are held against a specified object,
but it never seems to arise when fewer locks are held.

I have informed IBM of this problem and am waiting for a response. Until this
issue is resolved, please be cautious about running the sample program, to avoid
interfering with the workload in a production system. If you do get stuck in a
loop, you can exit it by pressing System Request and taking Option 2.

Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
Back

QGYOLAUS
Open list of authorized users

     **
     **  Program . . : EXA511
     **  Description : Open list of authorized users (QGYOLAUS) API example
     **  Author  . . : Carsten Flensburg
     **
     **
     **  Compile and setup instructions:
     **    CrtRpgMod   Module( EXA511 )
     **                DbgView( *LIST )
     **
     **    CrtPgm      Pgm( EXA511 )
     **                Module( EXA511 )
     **                ActGrp( *NEW )
     **
     **
     **-- Control specification:  --------------------------------------------**
     H Option( *SrcStmt )
     **-- System information:
     D PgmSts         SDs                  Qualified
     D  PgmNam           *Proc
     **-- API error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a
     **-- List API parameters:
     D LstApi          Ds                  Qualified  Inz
     D  RtnRcdNbr                    10i 0
     D  GrpNam                       10a
     D  SltCri                       10a
     **-- List information:
     D LstInf          Ds                  Qualified
     D  RcdNbrTot                    10i 0
     D  RcdNbrRtn                    10i 0
     D  Handle                        4a
     D  RcdLen                       10i 0
     D  InfSts                        1a
     D  Dts                          13a
     D  LstSts                        1a
     D                                1a
     D  InfLen                       10i 0
     D  Rcd1                         10i 0
     D                               40a
     **-- User information:
     D AUTU0100        Ds                  Qualified
     D  UsrPrf                       10a
     D  UsrGrpI                       1a
     D  GrpMbrI                       1a
     **-- Open list of authorized users:
     D LstAutUsr       Pr                  ExtPgm( 'QGYOLAUS' )
     D  RcvVar                    65535a          Options( *VarSize )
     D  RcvVarLen                    10i 0 Const
     D  LstInf                       80a
     D  NbrRcdRtn                    10i 0 Const
     D  FmtNam                        8a   Const
     D  SltCri                       10a   Const
     D  GrpNam                       10a   Const
     D  Error                      1024a          Options( *VarSize )
     **-- Get list entry:
     D GetLstEnt       Pr                  ExtPgm( 'QGYGTLE' )
     D  RcvVar                    65535a          Options( *VarSize )
     D  RcvVarLen                    10i 0 Const
     D  Handle                        4a   Const
     D  LstInf                       80a
     D  NbrRcdRtn                    10i 0 Const
     D  RtnRcdNbr                    10i 0 Const
     D  Error                      1024a          Options( *VarSize )
     **-- Close list:
     D CloseLst        Pr                  ExtPgm( 'QGYCLST' )
     D  Handle                        4a   Const
     D  Error                      1024a          Options( *VarSize )

     **-- Entry parameters:
     D EXA511          Pr
     **
     D EXA511          Pi

      /Free

        LstApi.RtnRcdNbr = 1;
        LstApi.SltCri = '*MEMBER';
        // LstApi.GrpNam = 'Insert Group Profile'
        LstApi.GrpNam = 'NOVAGRPIT';

        LstAutUsr( AUTU0100
                 : %Size( AUTU0100 )
                 : LstInf
                 : 1
                 : 'AUTU0100'
                 : LstApi.SltCri
                 : LstApi.GrpNam
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl = *Zero;

          DoW  LstInf.LstSts <> '2'  Or  LstInf.RcdNbrTot >= LstApi.RtnRcdNbr;

            ExSr  GetPrfInf;

            LstApi.RtnRcdNbr = LstApi.RtnRcdNbr + 1;

            GetLstEnt( AUTU0100
                     : %Size( AUTU0100 )
                     : LstInf.Handle
                     : LstInf
                     : 1
                     : LstApi.RtnRcdNbr
                     : ERRC0100
                     );

            If  ERRC0100.BytAvl > *Zero;
              Leave;
            EndIf;

          EndDo;
        EndIf;

        *InLr = *On;
        Return;


        BegSr  GetPrfInf;

        // Structure AUTU0100 now contains member user profile information...

        EndSr;

      /End-Free

Thanks to Carsten Flensburg
Back

QSYRAUTU
Retrieve authorized users

     **
     **  Program . . : EXA512
     **  Description : Retrieve authorized users (QSYRAUTU) API example
     **  Author  . . : Carsten Flensburg
     **
     **
     **  Compile and setup instructions:
     **    CrtRpgMod   Module( EXA512 )
     **                DbgView( *LIST )
     **
     **    CrtPgm      Pgm( EXA512 )
     **                Module( EXA512 )
     **                ActGrp( *NEW )
     **
     **
     **-- Control specification:  --------------------------------------------**
     H Option( *SrcStmt )
     **-- System information:
     D PgmSts         SDs                  Qualified
     D  PgmNam           *Proc
     **-- API error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a
     **-- Global variables:
     D Idx             s             10i 0
     D BytAlc          s             10i 0
     D RcvVar          s          65535a   Based( pRcvVar )
     **-- Global constants:
     D PRF_NAM_GT      c                   '0'
     D PRF_NAM_GE      c                   '1'
     **-- Retrieve API parameters:

     D RtvApi          Ds                  Qualified  Inz
     D  GrpNam                       10a
     D  SltCri                       10a
     **-- List information:
     D RtnRcdFbi       Ds                  Qualified  Inz
     D  BytRtn                       10i 0
     D  BytAvl                       10i 0
     D  NbrPrf                       10i 0
     D  EntLen                       10i 0
     **-- User information:
     D AUTU0100        Ds                  Qualified  Based( pAUTU0100 )
     D  UsrPrf                       10a
     D  UsrGrpI                       1a
     D  GrpMbrI                       1a
     **-- Retrieve authorized users:
     D RtvAutUsr       Pr                  ExtPgm( 'QSYRAUTU' )
     D  RcvVar                    65535a          Options( *VarSize )
     D  RcvVarLen                    10i 0 Const
     D  RtnRcdFbi                    16a
     D  FmtNam                        8a   Const
     D  SltCri                       10a   Const
     D  StrPrf                       10a   Const
     D  StrPrfOpt                     1a   Const
     D  GrpNam                       10a   Const
     D  Error                      1024a          Options( *VarSize )
     D  EndPrf                       10a   Const  Options( *NoPass )

     **-- Entry parameters:
     D EXA512          Pr
     **
     D EXA512          Pi

      /Free

        RtvApi.SltCri = '*MEMBER';
        // RtvApi.GrpNam = 'Insert Group Profile'
        RtvApi.GrpNam = 'NOVAGRPIT';

        BytAlc = 4096;
        pRcvVar = %Alloc( BytAlc );

        DoU  RtnRcdFbi.BytAvl <= BytAlc;

          If  RtnRcdFbi.BytAvl > BytAlc;
            BytAlc = RtnRcdFbi.BytAvl;
            pRcvVar = %ReAlloc( pRcvVar: BytAlc );
          EndIf;

          RtvAutUsr( RcvVar
                   : BytAlc
                   : RtnRcdFbi
                   : 'AUTU0100'
                   : RtvApi.SltCri
                   : '*FIRST'
                   : PRF_NAM_GE
                   : RtvApi.GrpNam
                   : ERRC0100
                   );

          If  ERRC0100.BytAvl > *Zero;
            Leave;
          EndIf;
        EndDo;

        If  ERRC0100.BytAvl = *Zero;

          ExSr  GetPrfInf;
        EndIf;

        *InLr = *On;
        Return;


        BegSr  GetPrfInf;

          pAUTU0100 = pRcvVar;

          For  Idx = 1  to  RtnRcdFbi.NbrPrf;

            // Structure AUTU0100 now contains member user profile information...

            If  Idx < RtnRcdFbi.NbrPrf;
              pAUTU0100 += RtnRcdFbi.EntLen;
            EndIf;
          EndFor;

        EndSr;

      /End-Free

Thanks to Carsten Flensburg
Back

QSYLATLO
List authorization list IFS objects

     **
     **  Program . . : CBX708
     **  Description : List authorization list IFS objects
     **  Author  . . : Carsten Flensburg
     **
     **
     **  Compile options:
     **    CrtRpgMod Module( CBX708 )
     **              DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX708 )
     **              Module( CBX708 )
     **              ActGrp( QILE )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )

     **-- Global variables:
     D Idx             s             10u 0
     D PthNam          s           5000a   Varying
     **-- Global constants:
     D OFS_MSGDTA      c                   16
     D USRSPC          c                   'AUTLSTOBJ QTEMP'

     **-- Api error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPro                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0 Inz
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a

     **-- API path:
     D Qlg_Path_Name   Ds                  Qualified  Based( pQlg_Path_Name )
     D  CcsId                        10i 0
     D  CtrId                         2a
     D  LngId                         3a
     D                                3a
     D  PthTypI                      10i 0
     D  PthNamLen                    10i 0
     D  PthNamDlm                     2a
     D                               10a
     D  PthNam                     5000a
     **-- API header information:
     D ApiHdrInf       Ds                  Qualified  Based( pHdrInf )
     D  AutLst                       10a
     D  AutLstLib                    10a
     D  ObjOwn                       10a
     D  ObjPgp                       10a
     D  RsnCod                       10i 0
     D  OfsQsysObj                   10i 0
     D  NbrQsysEnt                   10i 0
     D  NbrQsysObj                   10i 0
     D  OfsQdlsObj                   10i 0
     D  NbrQdlsEnt                   10i 0
     D  NbrQdlsObj                   10i 0
     D  OfsDirEobj                   10i 0
     D  NbrDirEent                   10i 0
     D  NbrDirEobj                   10i 0
     **-- Authorization list IFS object entry:
     D ATLO0210        Ds                  Qualified  Based( pLstEnt )
     D  OfsPthNam                    10i 0
     D  LenPthNam                    10i 0
     D  ObjTyp                       10a
     D  AutHlr                        1a
     D  ObjOwn                       10a
     D  ObjAtr                       10a
     D  TxtDsc                       50a
     D  ObjPgp                       10a
     D                                1a
     D  AspDev                       10

     **-- User space generic header:
     D UsrSpcHdr       Ds                  Qualified  Based( pUsrSpc )
     D  OfsHdr                       10i 0 Overlay( UsrSpcHdr: 117 )
     D  OfsLst                       10i 0 Overlay( UsrSpcHdr: 125 )
     D  NumLstEnt                    10i 0 Overlay( UsrSpcHdr: 133 )
     D  SizLstEnt                    10i 0 Overlay( UsrSpcHdr: 137 )
     **-- User space pointers:
     D pUsrSpc         s               *   Inz( *Null )
     D pHdrInf         s               *   Inz( *Null )
     D pLstEnt         s               *   Inz( *Null )

     **-- Create user space:
     D CrtUsrSpc       Pr                  ExtPgm( 'QUSCRTUS' )
     D  SpcNamQ                      20a   Const
     D  ExtAtr                       10a   Const
     D  InzSiz                       10i 0 Const
     D  InzVal                        1a   Const
     D  PubAut                       10a   Const
     D  Text                         50a   Const
     D  Replace                      10a   Const  Options( *NoPass )
     D  Error                     32767a          Options( *NoPass: *VarSize )
     D  Domain                       10a   Const  Options( *NoPass )
     **-- Delete user space:
     D DltUsrSpc       Pr                  ExtPgm( 'QUSDLTUS' )
     D  SpcNamQ                      20a   Const
     D  Error                     32767a          Options( *VarSize )
     **-- Retrieve pointer to user space:
     D RtvPtrSpc       Pr                  ExtPgm( 'QUSPTRUS' )
     D  SpcNamQ                      20a   Const
     D  Pointer                        *
     D  Error                     32767a          Options( *NoPass: *VarSize )
     **-- List authorization list objects:
     D LstAutLstObj    Pr                  ExtPgm( 'QSYLATLO' )
     D  SpcNamQ                      20a   Const
     D  FmtNam                        8a   Const
     D  AutLst                       10a   Const
     D  Error                     32767a          Options( *VarSize )
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  MsgId                         7a   Const
     D  MsgFq                        20a   Const
     D  MsgDta                      128a   Const
     D  MsgDtaLen                    10i 0 Const
     D  MsgTyp                       10a   Const
     D  CalStkE                      10a   Const  Options( *VarSize )
     D  CalStkCtr                    10i 0 Const
     D  MsgKey                        4a
     D  Error                      1024a          Options( *VarSize )

     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying

     **-- Entry parameters:
     D CBX708          Pr
     D  PxAutLst                     10a

     D CBX708          Pi
     D  PxAutLst                     10a

      /Free

        CrtUsrSpc( USRSPC
                 : *Blanks
                 : 65535
                 : x'00'
                 : '*CHANGE'
                 : *Blanks
                 : '*YES'
                 : ERRC0100
                 );

        LstAutLstObj( USRSPC
                    : 'ATLO0210'
                    : PxAutLst
                    : ERRC0100
                    );

        If  ERRC0100.BytAvl = *Zero;
          ExSr  PrcLstEnt;

        Else;
          If  ERRC0100.BytAvl < OFS_MSGDTA;
            ERRC0100.BytAvl = OFS_MSGDTA;
          EndIf;

          SndEscMsg( ERRC0100.MsgId
                   : 'QCPFMSG'
                   : %Subst( ERRC0100.MsgDta
                           : 1
                           : ERRC0100.BytAvl - OFS_MSGDTA
                           ));
        EndIf;

        DltUsrSpc( USRSPC: ERRC0100 );

        *InLr = *On;

        Return;

        BegSr  PrcLstEnt;

          RtvPtrSpc( USRSPC: pUsrSpc );

          pHdrInf = pUsrSpc + UsrSpcHdr.OfsHdr;
          pLstEnt = pUsrSpc + UsrSpcHdr.OfsLst;

          For  Idx = 1  to UsrSpcHdr.NumLstEnt;

            pQlg_Path_Name = pUsrSpc + ATLO0210.OfsPthNam;

            PthNam = %Subst( Qlg_Path_Name.PthNam: 1: Qlg_Path_Name.PthNamLen );

            If  Idx < UsrSpcHdr.NumLstEnt;
              pLstEnt += UsrSpcHdr.SizLstEnt +
                       ( %Size( Qlg_Path_Name ) -
                         %Size( Qlg_Path_Name.PthNam )) +
                         Qlg_Path_Name.PthNamLen;
            EndIf;
          EndFor;

        EndSr;

      /End-Free

     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : PxMsgF + '*LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndEscMsg       E


Two things are worth mentioning regarding the processing of the list
entries:

- The offset to the path name structure is calculated from the beginning of
the user space, as opposed to the beginning of the list entry.

- The offset to the next list entry is calculated based on the following
variables: API header list entry size + size of fixed part of Path name
structure + Path name length.

Thanks to Carsten Flensburg
Back

QWCRDTAA
Retrieve Data Area

     D QwcRdtAA        pr                  ExtPgm('QWCRDTAA')
     D  aRcvVar                            Like(DtaAraRcv)
     D  aRcvVarLen                   10i 0 Const
     D  aDtaAra                      20a   Const
     D  aStrPos                      10i 0 Const
     D  aDtaLen                      10i 0 Const
     D   ApiError                          Like(ApiError)

     D DtaAraRcv       ds
     D  AraBytes                     10i 0
     D  AraBytesOut                  10i 0
     D  AraDtaType                   10a
     D  AraLibrary                   10a
     D  AraLength                    10i 0
     D  AraDecimals                  10i 0
     D  AraValue                   2000a

     D RtvDtaAra       pr          2000a   Varying
     D  iDtaAra                      10a   Const
     D  iDtaAraLib                   10a   Const Options(*NoPass)
     D  iStrPos                       5p 0 Const Options(*NoPass)
     D  iDtaLen                       5p 0 Const Options(*NoPass)

     P RtvDtaAra       b                   Export
     D RtvDtaAra       pi          2000a   Varying
     D  iDtaAra                      10a   Const
     D  iDtaAraLib                   10a   Const Options(*NoPass)
     D  iStrPos                       5p 0 Const Options(*NoPass)
     D  iDtaLen                       5p 0 Const Options(*NoPass)

     D wDtaAra         s             10a
     D wDtaAraLib      s             10a
     D wStrPos         s              5p 0
     D wDtaLen         s              5p 0

     D qDtaAra         s             20a

      * Prepare all input parameters...
     C                   Eval      wDtaAra = iDtaAra

     C                   If        %Parms < 2
     C                   Eval      wDtaAraLib = '*LIBL'
     C                   Else
     C                   Eval      wDtaAraLib = iDtaAraLib
     C                   EndIf

     C                   If        %Parms < 3
     C                   Eval      wStrPos = 1
     C                   Else
     C                   Eval      wStrPos = iStrPos
     C                   EndIf

      * Prepare API parameters...
     C                   If        wDtaAra = '*LDA' or
     C                             wDtaAra = '*GDA' or
     C                             wDtaAra = '*PDA'
     C                   Eval      wDtaAraLib = *Blanks
     C                   EndIf

     C                   Eval      qDtaAra = wDtaAra + wDtaAraLib

      * Call the API to retrieve the data area...
     C                   Reset                   ApiError
     C                   CallP     QwcRdtAA(DtaAraRcv       :
     C                                      %Size(DtaAraRcv):
     C                                      qDtaAra         :
     C                                      -1              :
     C                                      2000            :
     C                                      ApiError        )

      * If any errors were detected then return an error flag...
     C                   If        AraBytesOut  = 0
     C                   Return    '*ERROR'
     C                   EndIf

      * Return the data area value...
     C                   If        %Parms < 4
     C                   Eval      wDtaLen = araLength - wStrPos + 1
     C                   Else
     C                   Eval      wDtaLen = iDtaLen
     C                   EndIf

     C                   Return    %Subst(AraValue : wStrPos : wDtaLen)

     P RtvDtaAra       e

Thanks to Jonathan Mason
Back

QgldExportLdif
Export LDIF File (LDAP)

Q: I'm looking for an RPG example of using the QgldExportLdif API. This API creates a .LDIF file of your entire LDAP on the iSeries so it can be exported to another iSeries LDAP. A: Okay, here's an example that I wrote up real quick: H DFTACTGRP(*NO) D QgldExportLdif PR Extproc('QgldExportLdif') D InputData 32767A const options(*varsize) D InputLen 10I 0 value D Format 8A const D ErrorCode 32767A options(*varsize) D LDIF0100 DS D File_off 10I 0 D File_len 10I 0 D AdminDN_off 10I 0 D AdminDN_len 10I 0 D AdminPW_off 10I 0 D AdminPW_len 10I 0 D Subtree_off 10I 0 D Subtree_len 10I 0 D File 200C CCSID(13488) D AdminDN 200C CCSID(13488) D AdminPW 200C CCSID(13488) D Subtree 200C CCSID(13488) D ErrorCode ds D BytesProv 10I 0 inz(0) D BytesAvail 10I 0 inz(0) /free // Set parameters // FIXME: Change these to appropriate values!! File = %ucs2('/tmp/dirsrv_output.ldif'); AdminDN = %ucs2('cn=Administrator'); AdminPW = %ucs2('mySecretPassword'); Subtree = *blanks; // Calculate offsets File_off = %addr(file) - %addr(LDIF0100); AdminDN_off = %addr(AdminDN) - %addr(LDIF0100); AdminPW_off = %addr(AdminPW) - %addr(LDIF0100); Subtree_off = %addr(Subtree) - %addr(LDIF0100); // Calculate lengths File_len = %len(%trimr(file)); AdminDN_len = %len(%trimr(AdminDN)); AdminPW_len = %len(%trimr(AdminPW)); Subtree_len = 0; // Call API QgldExportLdif( LDIF0100 : %size(LDIF0100) : 'LDIF0100' : ErrorCode ); *inlr = *on; /end-free In this example, it dumps the whole directory server (since I set the subtree length to zero, it won't do a subtree, it'll do everything) to a file named /tmp/dirsrv_output.ldif in the IFS. Obviously, you'll have to change the userid, password and maybe the IFS filename to be something appropriate for your system. > Also, if anyone has an RPG example of the QgldImportLdif API that will > load the .LDIF file into the destination iSeries. I haven't used QgldImportLdif. (I export it for import into an OpenLDAP2 server, not for another iSeries) but I took a quick peek at the docs, and they appear to be just about identical to those for QgldExportLdif, so you might be able to use the same program, just change the prototype name (and the EXTPROC keyword) from Export to Import. Note that the contents of the ExtProc() keyword are case-sensitive. Make sure you capitalize it the same way I did. Note also that the 2nd parameter to QgldExportLdif is passed by VALUE... this one was tricky at first, since it doesn't say anything about this in the IBM docs (unless they've changed them since I wrote this?) You have to look at the C prototype to know this :) > I realize that the export and import can be done via iSeries Navigator, > but I want to do the export and import as scheduled jobs that will run > unattended during the middle of the night. Any help is greatly > appreciated. It's probably also possible from QShell using ldapsearch, but I haven't tried it. This API seems simpler, actually :) Thanks to Scott Klement

Back

QUSLRCD
List Record Formats - and other DBF API's below

     '*---------------------------------------------------------------*
     h option(*nodebugio)
     '* Program Name: LISTPF          Program Author:  Tommy Holden   *
     '* Program Date: 08/09/2004      Program Purpose:                *
     '*---------------------------------------------------------------*

     '* Report Output
     FQSysPrt   o    f  132        Printer OflInd(*InOF)

     '* Create User Space API Procedure
     DCrtUsrSpc        pr                  ExtPgm('QUSCRTUS')
     DCUSQualUSName                  20a   CONST
     DCUSExtAttribut                 10a   CONST
     DCUSInitSize                    10I 0 CONST
     DCUSInitValue                    1a   CONST
     DCUSPublicAuth                  10a   CONST
     DCUSDescription                 50a   CONST
     DCUSReplace                     10a   CONST
     DErrorCode                   32766A   options(*varsize)

     '* List Record Formats API Procedure
     DListRcdFmts      pr                  ExtPgm('QUSLRCD')
     d  CUSQualUSName                20a   Const
     d  CUSRcdFmt                     8a   Const
     d  CUSPFName                    20a   Const
     d  OverrideProc                  1a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* List Fields API Procedure
     DListFields       pr                  ExtPgm('QUSLFLD')
     d  CUSFldUSName                 20a   Const
     d  CUSRcdFmt                     8a   Const
     d  CUSPFName                    20a   Const
     D  PFRcdFmt                     10a   Const
     d  OverrideProc                  1a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* List Key Fields (QDBRTVFD retrieve file desc)API Procedure
     DListFileDesc     pr                  ExtPgm('QDBRTVFD')
     d  OutputData                32766a   Options(*Varsize)
     d  OutputDataLen                10i 0 Const
     d  CUSPFNameRet                 20a
     D  PFRcdFmt                      8a   Const
     d  CUSPFName                    20a   Const
     D  RcdFmt                        8a   Const
     d  OverrideProc                  1a   Const
     d  System                       10a   Const
     d  FormatType                   10a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* List Members API Procedure
     DListMembers      pr                  ExtPgm('QUSLMBR')
     d  CUSMbrUSName                 20a   Const
     d  CUSRcdFmt                     8a   Const
     d  CUSPFName                    20a   Const
     D  Members                      10a   Const
     d  OverrideProc                  1a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* List Database Relations API Procedure
     DListDBR          pr                  ExtPgm('QDBLDBR')
     d  CUSDBRUSName                 20a   Const
     d  CUSRcdFmt                     8a   Const
     d  CUSPFName                    20a   Const
     D  Members                      10a   Const
     d  RcdFmt                       10a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* List Members Info (QUSRMBRD retrieve member desc)API Procedure
     DListMemberInfo   pr                  ExtPgm('QUSRMBRD')
     d  OutputData                32766a   Options(*Varsize)
     d  OutputDataLen                10i 0 Const
     D  PFRcdFmt                      8a   Const
     d  CUSPFName                    20a   Const
     d  Member                       10a   Const
     d  OverrideProc                  1a   Const
     d  ErrorCode                 32766a   options(*varsize)

     '* ReSend Message API Procedure
     D SendMsg         PR                  ExtPgm('QMHRSNEM')
     D   MsgKey                       4A   const
     D   ErrorCode                32766A   options(*varsize)
     D   ToStkEntry               32766A   options(*varsize: *nopass)
     d   ToStkEntryLn                10I 0 const options(*nopass)
     D   Format                       8A   const options(*nopass)
     D   FromEntry                     *   const options(*nopass)
     D   FromCounter                 10I 0 const options(*nopass)

     '* Get User Space Pointer API Procedure
     D UserSpacePntr   PR                  ExtPgm('QUSPTRUS')
     D CUSQualUSName                 20A   CONST
     D  CUSPointer                     *

     '* Error Code DS For API Calls
     D ErrorDS         DS
     D   dsEC1                       10I 0 inz(0)
     D   dsEC2                       10I 0 inz(0)

     '* Program Stack DS For API Calls
     D StackDS         ds
     d   dsRS_StkCnt                 10I 0 inz(2)
     D   dsRS_StkQual                20A   inz('*NONE     *NONE')
     D   dsRS_IDLen                  10I 0 inz(7)
     D   dsRS_StkID                   7A   inz('*')

     '* User Space Header DS
     D USHeader        ds                  Based(CUSPointer)
     d HdrUserArea                   64a
     d HdrHdrSize                    10i 0
     d HdrStrLvl                      4a
     d HdrFormat                      8a
     d HdrAPIUsed                    10a
     d HdrCrtDate                    13a
     d HdrInfoSts                     1a
     d HdrSizeOfUS                   10i 0
     d HdrOffsetToInp                10i 0
     d HdrSizeOfInp                  10i 0
     d HdrOffsetToHdr                10i 0
     d HdrSizeOfHdr                  10i 0
     d HdrOffsetToDtl                10i 0
     d HdrSizeOfDtl                  10i 0
     d HdrNumberOfDtl                10i 0
     d HdrEntrySize                  10i 0
     d HdrCCSID                      10i 0
     d HdrCountry                     2a
     d HdrLangID                      3a
     d HdrSubsetInd                   1a
     d HdrReserved1                  42a
     DSaveHdrDS        ds
     d SavUserArea                   64a
     d SavHdrSize                    10i 0
     d SavStrLvl                      4a
     d SavFormat                      8a
     d SavAPIUsed                    10a
     d SavCrtDate                    13a
     d SavInfoSts                     1a
     d SavSizeOfUS                   10i 0
     d SavOffsetToInp                10i 0
     d SavSizeOfInp                  10i 0
     d SavOffsetToHdr                10i 0
     d SavSizeOfHdr                  10i 0
     d SavOffsetToDtl                10i 0
     d SavSizeOfDtl                  10i 0
     d SavNumberOfDtl                10i 0
     d SavEntrySize                  10i 0
     d SavCCSID                      10i 0
     d SavCountry                     2a
     d SavLangID                      3a
     d SavSubsetInd                   1a
     d SavReserved1                  42a
     DSav2HdrDS        ds
     d Sv2UserArea                   64a
     d Sv2HdrSize                    10i 0
     d Sv2StrLvl                      4a
     d Sv2Format                      8a
     d Sv2APIUsed                    10a
     d Sv2CrtDate                    13a
     d Sv2InfoSts                     1a
     d Sv2SizeOfUS                   10i 0
     d Sv2OffsetToInp                10i 0
     d Sv2SizeOfInp                  10i 0
     d Sv2OffsetToHdr                10i 0
     d Sv2SizeOfHdr                  10i 0
     d Sv2OffsetToDtl                10i 0
     d Sv2SizeOfDtl                  10i 0
     d Sv2NumberOfDtl                10i 0
     d Sv2EntrySize                  10i 0
     d Sv2CCSID                      10i 0
     d Sv2Country                     2a
     d Sv2LangID                      3a
     d Sv2SubsetInd                   1a
     d Sv2Reserved1                  42a

     '* List Record Format Header DS
     D  RcdFmtHdrPtr   s               *
     DRcdFmtHdrDS      ds                  Based(RcdFmtHdrPtr)
     D  RcdPFName                    10a
     D  RcdPFLib                     10a
     D  RcdPFType                    10a
     D  RcdPFText                    50a
     D  RcdPFCCSID                   10i 0
     D  RcdPFCrtDate                 13a

     '* List Record Formats DS
     D RcdFmtPtr       s               *
     DRcdFmtDS         ds                  Based(RcdFmtPtr)
     D  RcdFmtName                   10a
     D  RcdLvlChkID                  13a
     D  RcdReserved                   1a
     D  RcdLength                    10i 0
     D  RcdNumFlds                   10i 0
     D  RcdFmtDesc                   50a
     D  RcdReserved1                  2a
     D  RcdCCSID                     10i 0

     '* List Fields DS
     D FldPtr          s               *
     DLstFldDS         ds                  Based(FldPtr)
     D  FldName                      10a
     D  FldDataType                   1a
     D  FldUsage                      1a
     D  FldOutBuffPos                10i 0
     D  FldInBuffPos                 10i 0
     D  FldLength                    10i 0
     D  FldDigits                    10i 0
     D  FldDecimals                  10i 0
     D  FldDesc                      50a
     D  FldEditC                      2a
     D  FldEditWLen                  10i 0
     D  FldEditWord                  64a
     D  FldColHdg1                   20a
     D  FldColHdg2                   20a
     D  FldColHdg3                   20a
     D  FldIntName                   10a
     D  FldAltName                   30a
     D  FldAltLen                    10i 0
     D  FldDBCS#                     10i 0
     D  FldAllowNull                  1a
     D  FldHostVar                    1a
     D  FldDateFormat                 4a
     D  FldDateSep                    1a
     D  FldVarSize                    1a
     D  FldDescCCSID                 10i 0
     D  FldDataCCSID                 10i 0
     D  FldColHCCSID                 10i 0
     D  FldEdtWCCSID                 10i 0
     D  FldUSC2Len                   10i 0
     D  FldDataEncode                10i 0
     D  FldMaxObjLen                 10i 0
     D  FldPadLen                    10i 0
     D  FldUDTLen                    10i 0
     D  FldUDTName                  132a
     D  FldUDTLib                    10a
     D  FldDLCntl                     1a
     D  FldDLInteg                    1a

     '* List File Description Header DS
     D  FDHDS          ds
     D  FDHBytesRet                  10i 0
     D  FDHBytesAvail                10i 0
     D  FDHMaxKeyLen                  5i 0
     D  FDHKeyCount                   5i 0
     D  FDHReserved                  10a
     D  FDHFormatCnt                  5i 0
     D  KeyRecFmt                    10a
     D  KeyReserve                    2a
     D  Key#OfKeys                    5i 0
     D  KeyReserv1                   14a
     D  KeyInfoOffset                10i 0

     '* List Key Information DS
     D KeyDS           ds
     D  KeyIntName                   10a
     D  KeyExtName                   10a
     D  KeyDtaType                    5i 0
     D  KeyFldLen                     5i 0
     D  Key#OfDigits                  5i 0
     D  KeyDecPos                     5i 0
     D  KeyAttrFlg                    1a
     D  KeyAltLen                     5i 0
     D  KeyAltName                   30a
     D  KeyReserv3                    1a
     D  KeyAttrFlg1                   1a
     D  KeyReserv4                    1a

     '* List Members Header DS
     D  MbrHdrPtr      s               *
     D MbrHdrDS        ds                  Based(MbrHdrPtr)
     D  MbrQualPF                    20a
     D  MbrPFAttr                    10a
     D  MbrPFText                    50a
     D  #OfMembers                   10i 0
     D  MbrSrcFile1                   1a
     D  MbrRsv                        3a
     D  MbrPFCCSID                   10i 0

     '* Member Information DS
     D MemberDS        ds
     D MbrBytesRet                   10i 0
     D MbrBytesAvail                 10i 0
     D MbrPFName                     10a
     D MbrPFLib                      10a
     D MbrName                       10a
     D MbrFileAttr                   10a
     D MbrSrcType                    10a
     D MbrCrtDate                    13a
     D MbrLSrcChg                    13a
     D MbrText                       50a
     D MbrSrcFile                     1a
     D MbrRemote                      1a
     D MbrLForPF                      1a
     D MbrODPShare                    1a
     D MbrReserved                    2a
     D MbrCurrRcds                   10i 0
     D MbrDltRcds                    10i 0
     D MbrDataSpcSize                10i 0
     D MbrAccPthSize                 10i 0
     D Mbr#BasedOn                   10i 0
     D MbrChgDate                    13a
     D MbrSaveDate                   13a
     D MbrRstDate                    13a
     D MbrExpDate                     7a
     D MbrReserv1                     6a
     D Mbr#DaysUsed                  10i 0
     D MbrLstUsed                     7a
     D MbrUseReset                    7a
     D MbrReserv2                     2a
     D MbrDtaSpcMult                 10i 0
     D MbrAccPthMult                 10i 0
     D MbrOffset1                    10i 0
     D Mbr1Len                       10i 0
     D MbrCurrBORcds                 10u 0
     D MbrDltBORcds                  10u 0
     D MbrReserv3                     6a
     D MbrJoinMbr                     1a
     D MbrAccPthMaint                 1a
     D MbrSQLType                    10a
     D MbrReserv4                     1a
     d MbrAllowRead                   1a
     D MbrAllowWrite                  1a
     D MbrAllowUpdate                 1a
     D MbrAllowDelete                 1a
     D MbrReserv5                     1a
     D MbrRcdFrcWrite                10i 0
     D MbrMaxPctDlt                  10i 0
     D MbrInit#Rcds                  10i 0
     D MbrIncr#Rcds                  10i 0
     D MbrMaxIncrem                  10i 0
     D MbrCurIncrem                  10u 0
     D MbrRcdCapacity                10u 0
     D MbrRcdFmtPgm                  10a
     D MbrRcdFmtLib                  10a
     D Mbr#Constraint                 5i 0
     D MbrOffsetConst                10i 0
     D MbrReserv6                    46a

     '* Based On PF DS
     D BasedOnDS       DS
     D  BOPFName                     10a
     D  BOPFLib                      10a
     D  BOPFMember                   10a
     D  BORcdFmt                     10a
     D  BORest                41    112a

     '* DBR DS
     D DBRPtr          s               *
     D DBRDS           ds                  Based(DBRPtr)
     d DBRPFName                     10a
     d DBRPFLib                      10a
     D DBRDepFile                    10a
     D DBRDepLib                     10a
     D DBRDepType                     1a
     D DBRReserve                     3a
     D DBRJoinRef#                   10i 0
     D DBRCstLib                     10a
     D DBRCstNameLen                 10i 0
     D DBRCstName                   258a

     '* Work Fields
     DCUSQualUSName    s             20a
     DCUSFldUSName     s             20a
     DCUSDBRUSName     s             20a
     DCUSPFNameRet     s             20a
     DInputPFName      s             20a
     DCUSExtAttribut   s             10a
     DCUSInitSize      s             10I 0
     DOutputDataLen    s             10I 0 inz(32766)
     DOutputData       s          32766a
     DCUSInitValue     s              1a
     DCUSPublicAuth    s             10a
     DCUSDescription   s             50a
     DCUSReplace       s             10a
     DCUSMbrUSName     s             20a
     D MbrPtr          s               *
     D Member          s             10a   Based(MbrPtr)
     DFilNam           s             10a
     DStrPos           s             10i 0
     DOffset           s             10i 0
     DTimes            s             10i 0
     DEndBuf           s              5  0
     DSeq#             s              8  0
     D #OfDepFiles     s             10i 0
     Dtmpdate          s               d   inz(D'1995-01-01') datfmt(*usa/)
     Dlines            s            132a   inz(*All'_')
     d  OverrideProc   s              1a   Inz('0')
     D Dependancy      s             50a
     D a               s             10i 0
     D b               s             10i 0
     D c               s             10i 0
     D i               s             10i 0
     D j               s             10i 0
     D k               s             10i 0
     C     *Entry        PList
     C                   Parm                    CUSPFName        20
     '* Set up Date & Time Output Field...
     c                   movel     *date         tmpdate
     C                   time                    utime             6 0
     C                   Eval      FilNam=%Subst(CUSPFName:1:10)

     '* Create The User Space For The Record Format List
     c                   Eval      CUSQualUSName='RCDFMT    QTEMP'
     c                   Eval      CUSExtAttribut='USRSPC'
     c                   Eval      CUSInitSize=1024
     c                   Eval      CUSInitValue=x'00'
     c                   Eval      CUSPublicAuth='*ALL'
     c                   Eval      CUSDescription='Record Formats'
     c                   Eval      CUSReplace='*YES'
     c                   CallP(E)  CrtUsrSpc(CUSQualUSName:
     c                             CUSExtAttribut:CUSInitSize:
     c                             CUSInitValue:CUSPublicAuth:
     c                             CUSDescription:CUSReplace:
     c                             ErrorDS)

     '* Create Failed
     c                   If        %Error
     c                   callp     SendMsg(*blanks:
     c                                   ErrorDS:
     c                                   StackDS:
     c                                   %size(StackDS):
     c                                   'RSNM0100':
     c                                   *NULL:
     c                                   0)
     c                   endif

     '* List Record Formats Into User Space
     c                   CallP(E)  ListRcdFmts(CUSQualUSName:
     c                             'RCDL0200':
     c                             CUSPFName:
     c                             OverrideProc:
     c                             ErrorDS)

     '* Access The Data via Pointer
     c                   CallP(E)  UserSpacePntr(CUSQualUSName:CUSPointer)
     c                   Eval      SaveHdrDS=USHeader
     c                   Eval      RcdFmtHdrPtr=CUSPointer+SavOffsetToHdr
     c                             + ((a-1) * %Size(RcdFmtHdrDS))

     '* Process The Detail Data
     c                   Do        SavNumberOfDtli
     c                   Eval      RcdFmtPtr=CUSPointer+SavOffsetToDtl
     c                             + ((i-1) * %Size(RcdFmtDS))
     C                   Except    Heads
     C                   Except    Head1

     '* Get Record Format Info Printed
     c                   ExSR      RcdFmtSR

     '* Get Key Data Info Printed
     c                   ExSR      KeyDataSR

     '* Get Member Data Info Printed
     c                   ExSR      MbrDataSR
     c                   EndDo

     '* Terminate
     c                   ExSR      Terminate

     '* Record Format Information
     c     RcdFmtSR      BegSR

     '* Create The User Space For The Field List
     c                   Z-Add     0             Seq#
     c                   Eval      CUSFldUSName='FLDLST    QTEMP'
     c                   Eval      CUSExtAttribut='USRSPC'
     c                   Eval      CUSInitSize=1024
     c                   Eval      CUSInitValue=x'00'
     c                   Eval      CUSPublicAuth='*ALL'
     c                   Eval      CUSDescription='Field List'
     c                   Eval      CUSReplace='*YES'
     c                   CallP(E)  CrtUsrSpc(CUSFldUSName:
     c                             CUSExtAttribut:CUSInitSize:
     c                             CUSInitValue:CUSPublicAuth:
     c                             CUSDescription:CUSReplace:
     c                             ErrorDS)

     '* Create Failed
     c                   If        %Error
     c                   callp     SendMsg(*blanks:
     c                                   ErrorDS:
     c                                   StackDS:
     c                                   %size(StackDS):
     c                                   'RSNM0100':
     c                                   *NULL:
     c                                   0)
     c                   endif

     '* Create Field List
     c                   CallP(E)  ListFields(CUSFldUSName:
     c                             'FLDL0100':
     c                             CUSPFName:
     c                             RcdFmtName:
     c                             OverrideProc:
     c                             ErrorDS)

     '* Access Data via Pointer
     c                   CallP(E)  UserSpacePntr(CUSFldUSName:CUSPointer)
     c                   Eval      OutputData=*Blanks

     '* Process Detail Data
     c                   Do        HdrNumberOfDtlj
     c                   Eval      FldPtr=CUSPointer+HdrOffsetToDtl
     c                             + ((j-1) * %Size(LstFldDS))

     '* Get the Ending Buffer Position
     c                   Eval      EndBuf=FldOutBuffPos+(FldLength-1)

     '* If Numeric Field Set On Indicator 10
     c                   If        FldDataType ='B'
     c                             OR FldDataType='D'
     c                             OR FldDataType='F'
     c                             OR FldDataType='M'
     c                             OR FldDataType='N'
     c                             OR FldDataType='P'
     c                             OR FldDataType='S'
     c                   Eval      *In10=*On
     c                   Else
     c                   Eval      *In10=*Off
     c                   EndIf

     '* Increment the Sequence Number & Write The Details
     c                   Add       10            Seq#
     c   OF              Except    Heads
     C   OF              Except    Head1
     c                   Except    Detail
     c                   Eval      *InOF=*Off
     c                   EndDo

     '* Save The Number Of Fields For Total Printing
     c                   Z-Add     RcdNumFlds    FldCnt           10 0
     c                   EndSR

     '* Key Data Information
     c     KeyDataSR     BegSR

     '* Get The Key Information From API Into Output Variable
     c                   Except    KeyHed
     c                   Eval      OutputDataLen=32766
     c                   Eval      CUSPFNameRet=*Blanks
     c                   CallP(E)  ListFileDesc(OutputData:
     c                             OutputDataLen:
     c                             CUSPFNameRet:
     c                             'FILD0300':
     C                             CUSPFName:
     c                             RcdFmtName:
     c                             OverrideProc:
     c                             '*LCL':
     c                             '*EXT':
     c                             ErrorDS)

     '* If Any Errors Occur or No Key Fields Found, Set Number Of Keys To 0
     c                   If        OutputData=*Blanks
     C                             OR %Error
     c                             OR %len(%Trim(OutputData))=0
     c                   Eval      Key#OfKeys=0
     c                   Else
     c                   MoveL     OutputData    FDHDS
     c                   EndIf

     '* Process Key Information Stored in the OutputData Variable
     c                   Eval      StrPos=KeyInfoOffset+1
     c                   Do        Key#OfKeys
     c                   Eval      KeyDS=%Subst(OutputData:StrPos:
     c                             +%Size(KeyDS))

     '* Print Key Information
     c   OF              Except    Heads
     c   OF              Except    KeyHed
     c                   Except    KeyLine
     c                   Eval      *InOF=*Off
     c                   Eval      StrPos=StrPos+%Size(KeyDS)
     c                   EndDo
     c                   EndSR

     '* Member Information
     c     MbrDataSR     BegSR

     '* Create The User Space For The Member List
     c                   Except    MbrHed
     c                   Eval      CUSMbrUSName='MBRLST    QTEMP'
     c                   Eval      CUSExtAttribut='USRSPC'
     c                   Eval      CUSInitSize=1024
     c                   Eval      CUSInitValue=x'00'
     c                   Eval      CUSPublicAuth='*ALL'
     c                   Eval      CUSDescription='MembersList'
     c                   Eval      CUSReplace='*YES'
     c                   CallP(E)  CrtUsrSpc(CUSMbrUSName:
     c                             CUSExtAttribut:CUSInitSize:
     c                             CUSInitValue:CUSPublicAuth:
     c                             CUSDescription:CUSReplace:
     c                             ErrorDS)

     '* Create Failed
     c                   If        %Error
     c                   callp     SendMsg(*blanks:
     c                                   ErrorDS:
     c                                   StackDS:
     c                                   %size(StackDS):
     c                                   'RSNM0100':
     c                                   *NULL:
     c                                   0)
     c                   endif

     '* Get Member List
     c                   CallP(E)  ListMembers(CUSMbrUSName:
     c                             'MBRL0100':
     c                             CUSPFName:
     c                             '*ALL':
     c                             OverrideProc:
     c                             ErrorDS)

     '* Access Member List via Pointer
     c                   CallP(E)  UserSpacePntr(CUSMbrUSName:CUSPointer)
     c                   Eval      Sav2HdrDS=USHeader
     c                   Eval      MbrHdrPtr=CUSPointer
     c                   Eval      MbrHdrPtr=MbrHdrPtr+Sv2OffsetToHdr
     C                   Eval      InputPFName=CUSPFName

     '* Process The Member List
     c                   Do        Sv2NumberOfDtlk
     c                   Eval      MbrPtr=CUSPointer+Sv2OffsetToDtl
     c                             + ((k-1) * %Size(Member))
     c                   Eval      OutputDataLen=32766
     c                   Eval      OverrideProc='0'

     '* Retrieve The Member Information via API
     c                   If        Member<>*Blanks
     c                   CallP(E)  ListMemberInfo(OutputData:
     c                             OutputDataLen:
     c                             'MBRD0300':
     c                             InputPFName:
     c                             Member:
     c                             OverrideProc:
     c                             ErrorDS)

     '* Error During Retrieve The Member Information via API
     c                   If        OutputData=*Blanks
     C                             OR %Error
     c                             OR %len(%Trim(OutputData))=0
     c                   Eval      Mbr#BasedOn=0
     c                   Else
     c                   MoveL     OutputData    MemberDS
     c                   EndIf

     '* Print Member Information
     c   OF              Except    Heads
     c   OF              Except    MbrHed
     c                   Except    MbrLine

     '* If This is a LF, List the Based On PF Information
     c                   If        MbrLForPF='1'
     c                   Eval      StrPos=384
     c                   If        Mbr#BasedOn>0
     c                   SetOn                                        11
     c                   SetOff                                       12
     c                   Except    BasedOnHdr
     c                   Do        Mbr#BasedOn
     c                   Eval      BasedOnDS=%Subst(OutputData:StrPos:112)
     c                   Except    BasedOnDtl
     c                   Eval      StrPos=StrPos+112
     c                   EndDo
     c                   EndIf

     '* If This is a PF, List the Dependent File Information
     c                   Else
     c                   SetOn                                        12
     c                   SetOff                                       11
     c                   ExSR      ListDBRSR
     c                   EndIf
     c                   EndIf
     c                   EndDo

     '* Print File Totals
     c                   Except    Totals
     c                   EndSR

     '* List Database Relations Subroutine
     c     ListDBRSR     BegSR

     '* Create The User Space For The DBR List
     c                   Eval      CUSDBRUSName='DBRLST    QTEMP'
     c                   Eval      CUSExtAttribut='USRSPC'
     c                   Eval      CUSInitSize=1024
     c                   Eval      CUSInitValue=x'00'
     c                   Eval      CUSPublicAuth='*ALL'
     c                   Eval      CUSDescription='DBR List'
     c                   Eval      CUSReplace='*YES'
     c                   CallP(E)  CrtUsrSpc(CUSDBRUSName:
     c                             CUSExtAttribut:CUSInitSize:
     c                             CUSInitValue:CUSPublicAuth:
     c                             CUSDescription:CUSReplace:
     c                             ErrorDS)

     '* Create Failed
     c                   If        %Error
     c                   callp     SendMsg(*blanks:
     c                                   ErrorDS:
     c                                   StackDS:
     c                                   %size(StackDS):
     c                                   'RSNM0100':
     c                                   *NULL:
     c                                   0)
     c                   endif

     '* List DBR Into User Space
     c                   CallP(E)  ListDBR(CUSDBRUSName:
     c                             'DBRL0100':
     c                             CUSPFName:
     c                             '*ALL':
     c                             '*ALL':
     c                             ErrorDS)

     '* Access Data via Pointer
     c                   CallP(E)  UserSpacePntr(CUSDBRUSName:CUSPointer)
     c                   If        HdrNumberOfDtl>0
     C                   Except    DBRHeads
     c                   Eval      #OfDepFiles=HdrNumberOfDtl

     '* Process All Dependancies
     c                   Do        HdrNumberOfDtlc
     c                   Eval      DBRPtr=CUSPointer+HdrOffsetToDtl
     c                             + ((c-1) * %Size(DBRDS))

     '* Load Dependancy Type For Print
     c                   Select
     c                   When      DBRDepType='C'
     c                   Eval      Dependancy='Constraint'
     '*
     c                   When      DBRDepType='D'
     c                   Eval      Dependancy='Extracted Data'
     '*
     c                   When      DBRDepType='I'
     c                   Eval      Dependancy='Extracted Data(Shared AccPth)'
     '*
     c                   When      DBRDepType='O'
     c                   Eval      Dependancy='Extracted Data(Owned AccPth)'
     '*
     c                   When      DBRDepType='V'
     c                   Eval      Dependancy='SQL View'
     '*
     c                   Other
     c                   Eval      Dependancy='Unknown'
     c                   EndSL

     '* Print Dependent File Information
     C                   Except    DBRDtl
     c                   EndDo
     c                   EndIf
     c                   EndSR

     '* Termination
     c     Terminate     BegSR
     c                   Eval      *InLR=*On
     c                   Return
     c                   EndSR
     '* Output Specs...
     Oqsysprt   e            heads          1 03
     O                                              'Date:'
     O                       tmpdate             +1
     O                                           40 'File Name:'
     o                       filnam              +1
     o                                           +1 'In Library:'
     o                       RcdPFLib            +1
     O                                          123 'Time:'
     O                       utime              132 '  :  :  '
     '*
     O          e            heads          1
     O                                           42 'Rec. Format:'
     O                       RcdFmtName          +1
     o                       RcdPFText           +1
     O                                          123 'Page:'
     O                       page          z    132
     '*
     O          e            heads          0
     o                       lines
     '*
     O          e            head1          1
     O                                            8 'Seq. Nbr'
     O                                           +1 'Field Name'
     O                                           +1 'Description'
     O                                           89 'Buffer Pos.'
     O                                          109 'Attributes'
     '*
     O          e            detail         1
     o                       seq#          z      8
     o                       FldName             +1
     o                       FldDesc             +1
     o                       FldOutBuffPos z     +1
     o                                           +1 '-'
     o                       endbuf        z     +1
     o               10      FldDigits     z     +1
     o               10      FldDataType         +0
     o               10      FldDecimals         +2 '        0 '
     O              N10      FldLength     z    100
     o              n10      FldDataType        101
     '*
     o          e            keyhed      2  1
     O                                              'Keyed By'
     '*
     o          e            keyline        1
     O                       KeyExtName         +10
     '*
     o          e            mbrhed      2  1
     O                                              'Members In File:'
     '*
     o          e            mbrline        1
     O                       Member             +10
     O                       MbrText             +1
     '*
     O          e            BasedOnHdr     1
     o                                              'Based On:'
     '*
     o          e            BasedOnHdr     1
     o                                              'Physical File'
     o                                           25 'Library'
     o                                           35 'Member'
     o                                           53 'Record Format'
     '*
     o          e            BasedOnDtl     1
     o                       BOPFName
     o                       BOPFLib             27
     o                       BOPFMember          38
     o                       BORcdFmt            49
     '*
     o          e            DBRHeads       1
     o                                              'Dependent Files:'
     '*
     o          e            DBRHeads       1
     o                                              'File     '
     o                                           +1 'Library  '
     o                                           +1 'Dependancy Type'
     '*
     o          e            DBRDtl         1
     o                       DBRDepFile
     o                       DBRDepLib           +1
     o                       Dependancy          +1
     '*
     o          e            totals      2  1
     o                       lines
     '*
     o          e            totals         1
     o                                              'Number Of Fields:'
     o                       FldCnt              37 '        0 '
     '*
     o          e            totals         1
     o                                              'Number Of Keys:'
     o                       Key#OfKeys          37 '        0 '
     '*
     o          e            totals         1
     o                                              'Number Of Members:'
     o                       #OfMembers          37 '        0 '
     '*
     o          e    11      totals         1
     o                                              'Number Of Based On Files:'
     o                       Mbr#BasedOn         37 '        0 '
     '*
     o          e    12      totals         1
     o                                              'Number Of Dependent Files:'
     o                       #OfDepFiles         37 '        0 '

Thanks to Tommy Holden
Back

QWCRTVCA & QWCCCJOB
How to tell if the user pressed F3 when a command was running?
This is the code you can use to retrieve the F3/F12.

QWCRTVCA - Retrieve Current Attributes QWCCCJOB - Change Current Job d*------------------------------------------------------------------------- d*.Parameters d*------------------------------------------------------------------------- d F3 s 1 d F12 s 1 d*------------------------------------------------------------------------- d*.API QWCRTVCA d*------------------------------------------------------------------------- d** current attributes d §ca ds d 9b 0 d** d 16a d cancel_key 1 d 3 d** d 16a d exit_key 1 d 3 d** current attributes length d §ca£ s 9b 0 inz(%len(§ca)) d** format name d §cafmt s 8 inz('RTVC0100') d** no. of fields to return d §caflds s 9b 0 inz(2) d** keys fields to return d §cakey ds d** ... cancel key d 9b 0 inz(301) d** ... exit key d 9b 0 inz(503) d*------------------------------------------------------------------------- d*.API QWCCCJOB d*------------------------------------------------------------------------- d** reset keys d §cj ds d 9b 0 inz(2) d** ... reset cancel key d 9b 0 inz(1) d 9b 0 inz(1) d 1 inz('0') d** ... reset job key d 9b 0 inz(2) d 9b 0 inz(1) d 1 inz('0') d**--------------------------------------------------------------- d*.API error std d**--------------------------------------------------------------- d §apierror ds d §rr1 1 4b 0 inz(8) d §rr2 5 8b 0 inz(0) c***************************************************************** c*.MAINLINE c***************************************************************** c *entry plist c parm F3 c parm F12 c eval F3 = *off c eval F12 = *off c*------------------------------------------------------------------------- c*.retrieve cancel/exit key c*------------------------------------------------------------------------- c call 'QWCRTVCA' c parm §ca c parm §ca£ c parm §cafmt c parm §caflds c parm §cakey c parm §apierror c*------------------------------------------------------------------------- c*.reset keys c*------------------------------------------------------------------------- c call 'QWCCCJOB' c parm §cj c parm §apierror c*------------------------------------------------------------------------- c*.return F3 or F12 c*------------------------------------------------------------------------- c eval F3 = exit_key c eval F12 = cancel_key c return Thanks to Beppe Costagliola

Back

QGYOLSPL a.o.
QGYOLSPL - Open List of Spooled Files

     h NoMain
      *--------------------------------------------------------------------------------------------
      *    Program  . . :  LSTSPLF          Author . . :  Rick Chevalier
      *    Date . . . . :   6/04/2002
      *    Purpose  . . :  Generate a list of selected spool files
      *--------------------------------------------------------------------------------------------
      *    Modifications:                               Date/Prgrmmr
      *--------------------------------------------------------------------------------------------
      *      None to this point.
      *--------------------------------------------------------------------------------------------
      *--------------------------------------------------------------------------------------------
      * File definitions
      *--------------------------------------------------------------------------------------------

      *--------------------------------------------------------------------------------------------
      * External procedure prototypes
      *--------------------------------------------------------------------------------------------
      * Open list of spooled files
     d OpnLstSplF      Pr                  ExtPgm('QGY/QGYOLSPL')
     d                            32000                                         Receiver variable
     d                               10i 0                                      Receiver var length
     d                               80                                         List information
     d                               10i 0                                      Nbr of rec to retur
     d                             1024                                         Sort information
     d                             1024                                         Filter information
     d                               26                                         Qualified job name
     d                                8                                         Format of list
     d                              256                                         Error code

      *--------------------------------------------------------------------------------------------
      * Internal procedure prototypes
      *--------------------------------------------------------------------------------------------
     d LstSplF         Pr             4
     d                               80                                         List information
     d                                 *   Const                                Receiver variable
     d                               10i 0                                      Receiver var length
     d                               10i 0 Options(*Omit: *NoPass)              Nbr of rec to retur
     d                               26    Options(*Omit: *NoPass)              Qualified job name
     d                             1024    Options(*Omit: *NoPass)              Filter information
     d                             1024    Options(*Omit: *NoPass)              Sort information
     d                                8    Options(*NoPass)                     Format of list

      *--------------------------------------------------------------------------------------------
      * LstSplF - Open list of selected spool files
      *--------------------------------------------------------------------------------------------
     p LstSplF         b                   Export
     d LstSplF         pi             4
     d  pLstInf                      80
     d  pRcvVar@                       *   Const
     d  pRcvLen                      10i 0
     d  pNbrRtn                      10i 0 Options(*Omit: *NoPass)
     d  pQualJob                     26    Options(*Omit: *NoPass)
     d  pFltrInf                   1024    Options(*Omit: *NoPass)
     d  pSortInf                   1024    Options(*Omit: *NoPass)
     d  pLstFmt                       8    Options(*NoPass)

      * Variables for optional parameters and pointers
     d lsRcvVar        s          32000    Based(pRcvVar@)

     d lsLstInf        ds            80                                         List information
     d   liTotRec                    10i 0 Inz(0)
     d   liRecTrn                    10i 0 Inz(0)
     d   liReqHdle                    4
     d   liRecLen                    10i 0 Inz(0)
     d   liInfCmp                     1
     d   liCrtDtTm                   13
     d   liStsInd                     1
     d   liRsv1                       1
     d   liInfRtnLen                 10i 0 Inz(0)
     d   liRec1                      10i 0 Inz(0)
     d   liRsv2                      40

     d lsNbrRtn        s             10i 0 Inz(1)

     d lsSortInf       ds          1024                                         Sort information
     d   siNbrKeys                   10i 0 Inz(0)
     d   siStrPos                    10i 0 Inz(0)
     d   siFldLen                    10i 0 Inz(0)
     d   siDtaTyp                     5i 0 Inz(x'00')
     d   siSrtOrd                     1    Inz(x'00')
     d   siRsv1                       1    Inz(x'00')

     d lsFltrInf       ds          1024                                         Filter information
     d*  fiNbrUsr                    10i 0
     d*  fiUsrNme                    60
     d*  fiNbrOutQ                   10i 0
     d*  fiOutQ                     100
     d*  fiFrmType                   10
     d*  fiUsrDta                    10
     d*  fiNbrSts                    10i 0
     d*  fiSplSts                    60
     d*  fiNbrDev                    10i 0
     d*  fiDevNme                    60

     d lsQualJob       s             26
     d lsLstFmt        s              8    Inz('OSPL0300')

      * Error structure
     d lsErrCd         ds           256
     d   lsErrPrv                    10i 0 Inz(256)
     d   lsErrAvl                    10i 0 Inz(0)
     d   lsErrID                      7
     d   lsErrDta                   132

      *--------------------------------------------------------------------------------------------
      * Calculations
      *--------------------------------------------------------------------------------------------
      /Free

        // If job information is passed us it
        If %Parms > 4 And %Addr(pQualJob) <> *Null;
           lsQualJob = pQualJob;
        EndIf;

        // If filter information is passed us it
        If %Parms > 5 And %Addr(pFltrInf) <> *Null;
           lsFltrInf = pFltrInf;
        EndIf;

        // If sort information is passed us it
        If %Parms > 6 And %Addr(pSortInf) <> *Null;
           lsSortInf = pSortInf;
        EndIf;

        // If list format value is passed us it
        If %Parms > 7 And %Addr(pLstFmt) <> *Null;
           lsLstFmt = pLstFmt;
        EndIf;

        CallP OpnLstSplF(lsRcvVar: pRcvLen: lsLstInf: pNbrRtn: lsSortInf:
              lsFltrInf: lsQualJob: lsLstFmt: lsErrCd);

        // Place list information into return parameter
        pLstInf = lsLstInf;

        Return liReqHdle;

      /End-Free

     p LstSplF         e



     h nomain
      *--------------------------------------------------------------------------------------------
      *    Program  . . :  RtvLstEnt        Author . . :  Rick Chevalier
      *    Date . . . . :   6/05/2002
      *    Purpose  . . :  Retrieve entry or entries from a generated list
      *--------------------------------------------------------------------------------------------
      *    Modifications:                               Date/Prgrmmr
      *--------------------------------------------------------------------------------------------
      *      None to this point.
      *--------------------------------------------------------------------------------------------

      * Required Parameter Group:
      *   1  Parm 1                                    Input   Char(10)
      *   2  Parm 2                                    Input   Dec(5,0)
      *   3  Parm 3                                    Input   Binary(4)
      *   4  Parm 4                                    Input   *

      *--------------------------------------------------------------------------------------------
      * Internal procedure prototypes
      *--------------------------------------------------------------------------------------------
     d RtvLstEnt       pr
     d                                4                                         List handle
     d                                 *   Const                                Receiver variable
     d                               10i 0                                      Receiver length
     d                               10i 0                                      Records to return
     d                               10i 0                                      Starting record
     d                               80                                         List information

      *--------------------------------------------------------------------------------------------
      * External procedure prototypes
      *--------------------------------------------------------------------------------------------
     d GetLstEnt       pr                  ExtPgm('QGY/QGYGTLE')
     d                            32000                                         Receiver variable
     d                               10i 0                                      Receiver length
     d                                4                                         List handle
     d                               80                                         List information
     d                               10i 0                                      Records to return
     d                               10i 0                                      Starting record
     d                              256                                         Error information

      *--------------------------------------------------------------------------------------------
      * Internal procedure
      *--------------------------------------------------------------------------------------------
     p RtvLstEnt       b                   export
     d RtvLstEnt       pi
     d  LstHdl                        4
     d  RcvVar@                        *   Const
     d  RcvLen                       10i 0
     d  NbrToRtn                     10i 0
     d  StartRec                     10i 0
     d  ListInfo                     80

     d RcvVar          s          32000    Based(RcvVar@)

      * API standard error structure
     d Error           ds           256
     d  Provid                       10i 0 Inz(128)
     d  Avail                        10i 0 Inz(0)
     d  ErrID                         7
     d  ErrData                     128                                                      a

      /Free

        CallP GetLstEnt(RcvVar: RcvLen: LstHdl: ListInfo: NbrToRtn: StartRec:
                        Error);

      /End-Free

     p RtvLstEnt       e



     h BndDir('RMVSPLF') DftActGrp(*No) ActGrp(*Caller)
      *--------------------------------------------------------------------------------------------
      *    Program  . . :  RMVSPLF          Author . . :  Rick Chevalier
      *    Date . . . . :   6/04/2002
      *    Purpose  . . :  Remove selected spool files
      *--------------------------------------------------------------------------------------------
      *    Modifications:                               Date/Prgrmmr
      *--------------------------------------------------------------------------------------------
      *      None to this point.
      *--------------------------------------------------------------------------------------------
      *--------------------------------------------------------------------------------------------
      * File definitions
      *--------------------------------------------------------------------------------------------

      *--------------------------------------------------------------------------------------------
      * External procedure prototypes
      *--------------------------------------------------------------------------------------------
      * Open list of spooled files
     d LstSplF         Pr             4
     d                               80                                         List information
     d                                 *   Const                                Receiver variable
     d                               10i 0                                      Receiver var length
     d                               10i 0 Options(*Omit: *NoPass)              Nbr of rec to retur
     d                               26    Options(*Omit: *NoPass)              Qualified job name
     d                             1024    Options(*Omit: *NoPass)              Filter information
     d                             1024    Options(*Omit: *NoPass)              Sort information
     d                                8    Options(*NoPass)                     Format of list

      * Retrieve additional list entries
     d RtvLstEnt       pr
     d                                4                                         List handle
     d                                 *   Const                                Receiver variable
     d                               10i 0                                      Receiver length
     d                               10i 0                                      Records to return
     d                               10i 0                                      Starting record
     d                               80                                         List information

      * Close list
     d CloseList       Pr                  ExtPgm('QGY/QGYCLST')
     d                                4                                         Request handle
     d                              128                                         Error code

      * Process or run a command.
     dprccmd           pr              *
     d                            32702                                         Command string
     d                                1    options(*nopass: *omit)              Prompt type

      * Send a message to the program message queue.
     d SndPgmMsg       pr             4
     d                                7                                         Message ID
     d                               20                                         Qualified msg file
     d                                 *   Const                                Message data
     d                               10    Options(*NoPass)                     Message type
     d                               10    Options(*NoPass)                     Stack entry
     d                                9b 0 Options(*NoPass)                     Stack counter

      *--------------------------------------------------------------------------------------------
      * Internal procedure prototypes
      *--------------------------------------------------------------------------------------------

      *--------------------------------------------------------------------------------------------
      * Data definitions
      *--------------------------------------------------------------------------------------------
      * Program entry parameter definitions
     d pFile           s             10
     d pJob            s             26

     d pUsrLst         ds            52
     d  pNbrUsr                       5i 0 Overlay(pUsrLst: 1)
     d  pUsers                       50    Overlay(pUsrLst: 3)
     d pDltDate        s              7

     d pOutQLst        ds           102
     d  pNbrOutQ                      5i 0 Overlay(pOutQLst: 1)
     d  pOutQs                      100    Overlay(pOutQLst: 3)
     d pFrmType        s             10
     d pUsrDta         s             10

     d pStsLst         ds            52
     d  pNbrSts                       5i 0 Overlay(pStsLst: 1)
     d  pStatus                      50    Overlay(pStsLst: 3)

     d pDevLst         ds            52
     d  pNbrDev                       5i 0 Overlay(pDevLst: 1)
     d  pDevices                     50    Overlay(pDevLst: 3)

      * Parameters for call to SndPgmMsg
     d spmMsgID        s              7    Inz(' ')
     d spmMsgF         s             20    Inz(' ')
     d spmMsgDta@      s               *   Inz(%Addr(spmMsgDta))
     d spmMsgDta       s           1024
     d spmMsgTyp       s             10    Inz('*INFO')
     d spmStkEnt       s             10    Inz('*')
     d spmStkCtr       s              9b 0 Inz(3)

      * Parameters for call to LstSplF
     d lsRcvVar@       s               *
     d lsRcvVar        s          32000                                         Receiver variable
     d lsRcvLen        s             10i 0 Inz(%Size(lsRcvVar))                 Receiver var length
     d lsLstInf        ds            80                                         List information
     d   liTotRec                    10i 0 Inz(0)
     d   liNbrRtn                    10i 0 Inz(0)
     d   liReqHdle                    4
     d   liRecLen                    10i 0 Inz(0)
     d   liInfCmp                     1
     d   liCrtDtTm                   13
     d   liStsInd                     1
     d   liRsv1                       1
     d   liInfRtnLen                 10i 0 Inz(0)
     d   liRec1                      10i 0 Inz(0)
     d   liRsv2                      40

     d lsNbrRtn        s             10i 0 Inz(50)                              Nbr of ent to retur

     d lsSortInf       ds          1024                                         Sort parameters
     d   siNbrKeys                   10i 0 Inz(0)
     d   siStrPos                    10i 0 Inz(0)
     d   siFldLen                    10i 0 Inz(0)
     d   siDtaTyp                     5b 0 Inz(x'00')
     d   siSrtOrd                     1    Inz(x'00')
     d   siRsv1                       1    Inz(x'00')

     d lsFltrInf       s           1024                                         Filter parameters
     d lsQualJob       s             26                                         Qualified job name
     d lsLstFmt        s              8                                         Returned list forma

      * Returned spool entry information
     d spRcvVar@       s               *
     d spRcvVar        ds                  Based(spRcvVar@)
     d   spJobNme                    10
     d   spUsrNme                    10
     d   spJobNbr                     6
     d   spSplNme                    10
     d   spSplNbr                    10i 0
     d   spSts                       10i 0
     d   spDteOpn                     7
     d   spTmeOpn                     6
     d   spSplSch                     1
     d   spSysNme                    10
     d   spUsrDta                    10
     d   spFrmType                   10
     d   spOutQ                      10
     d   spOutQLib                   10
     d   spAuxStg                    10i 0
     d   spSplSize                   10i 0
     d   spSizeMlt                   10i 0
     d   spTotPgs                    10i 0
     d   spCpyRmn                    10i 0
     d   spPrty                       1
     d   spRsv1                       3

      * Error structure
     d lsErrCd         ds           256
     d   lsErrPrv                    10i 0 Inz(256)
     d   lsErrAvl                    10i 0 Inz(0)
     d   lsErrID                      7
     d   lsErrDta                   132

      * Returned list handle
     d LstHdl          s              4

      * Miscellaneous variables
     d DltCmd          s          32702
     d Start           s             10i 0 Inz(1)
     d x               s             10i 0
     d y               s             10i 0
     d EndOfList       s               n   Inz(*Off)                            End of list flag
     d DltEntry        s               n   Inz(*Off)                            Delete entry flag
     d NbrRmv          s             10i 0                                      Number removed
     d NbrRead         s             10i 0                                      Number read

     d                 ds             4
     d Bin4                          10i 0                                      Convert from 2 to 4
     d chrBin4                        4    Overlay(Bin4)                        Substring field

      *--------------------------------------------------------------------------------------------
      * Calculations
      *--------------------------------------------------------------------------------------------
      /Free

        // Format input parameters for list generation
        lsQualJob = pJob;
        Bin4 = pNbrUsr;
        lsFltrInf = chrBin4;
        y = 5;

        For x = 1 to pNbrUsr;
           %Subst(lsFltrInf: y) = %Subst(pUsers: (x * 10) - 9: 10);
           y = y + 12;
        EndFor;

        Bin4 = pNbrOutQ;
        %Subst(lsFltrInf: y) = chrBin4;
        y = y + 4;

        For x = 1 to pNbrOutQ;
           %Subst(lsFltrInf: y) = %Subst(pOutQs: (x * 20) - 19: 20);
           y = y + 20;
        EndFor;

        %Subst(lsFltrInf: y: 10) = pFrmType;
        y = y + 10;
        %Subst(lsFltrInf: y :10) = pUsrDta;
        y = y + 10;

        Bin4 = pNbrSts;
        %Subst(lsFltrInf: y) = chrBin4;
        y = y + 4;

        For x = 1 to pNbrSts;
           %Subst(lsFltrInf: y) = %Subst(pStatus: (x * 10) - 9: 10);
           y = y + 12;
        EndFor;

        Bin4 = pNbrDev;
        %Subst(lsFltrInf: y) = chrBin4;
        y = y + 4;

        For x = 1 to pNbrDev;
           %Subst(lsFltrInf: y) = %Subst(pDevices: (x * 10) - 9: 10);
           y = y + 12;
        EndFor;

        // Begin list generation
        lsRcvVar@ = %Addr(lsRcvVar);
        LstHdl = LstSplF(lsLstInf: lsRcvVar@: lsRcvLen: lsNbrRtn: lsQualJob:
                         lsFltrInf);

        // If no entries are returned set end of list flag
        If liNbrRtn <= 0;
           EndOfList = *On;
        EndIf;

        // Substring return field into it's parts
        DoW Not EndOfList;
           spRcvVar@ = %Addr(lsRcvVar);

           // Process list entries
           For x = 1 to liNbrRtn;

              // File and date are not selected by the API.  Check relationships
              // and set delete flag accordingly.
              Select;
                 When pFile = *Blanks or pFile = spSplNme;

                    Select;
                       When pDltDate = *Zeros;
                          DltEntry = *On;

                       When pDltDate <> *Zeros and spDteOpn < pDltDate;
                          DltEntry = *On;

                       When pDltDate <> *Zeros and spDteOpn >= pDltDate;
                          DltEntry = *Off;
                    EndSl;

                 When pFile <> spSplNme;
                    DltEntry = *Off;
              EndSl;

              // If entry matches selection criteria remove it
              If DltEntry;
                 DltCmd = 'DLTSPLF FILE(' + %TrimR(spSplNme)  + ') JOB(' +
                           spJobNbr + '/' + %TrimR(spUsrNme) + '/' +
                           %TrimR(spJobNme) + ') SPLNBR(' + %Char(spSplNbr) +
                           ')';
                 PrcCmd(DltCmd);
                 NbrRmv += 1;
              EndIf;

              spRcvVar@ = spRcvVar@ + liRecLen;
           EndFor;

           // If list is not complete retrieve next group of list entries
           NbrRead += liNbrRtn;

           If (NbrRead < liTotRec and liStsInd = '2') or
              (liStsInd <>  '2' and liStsInd <> '3');
              Start = Start + liNbrRtn;
              Clear lsRcvVar;
              lsNbrRtn = %Size(lsRcvVar)/liRecLen;
              CallP RtvLstEnt(LstHdl: lsRcvVar@: lsRcvLen: lsNbrRtn:
                              Start: lsLstInf);

           // If list is complete set end of list flag
           Else;
              EndOfList = *On;
           EndIf;

        EndDo;

        // Close the list
        CallP CloseList(LstHdl: lsErrCd);

        // Send completion message
        spmMsgDta = %Char(NbrRmv) + ' spool file entries removed.';
        CallP     SndPgmMsg(spmMsgID: spmMsgF: spmMsgDta@:
                            spmMsgTyp :spmStkEnt :spmStkCtr);

        *InLR = *On;

      /End-Free

      *--------------------------------------------------------------------------------------------
      * Define - Define key lists and parameter lists
      *--------------------------------------------------------------------------------------------
     c     Define        BegSr

     c     *Entry        PList
     c                   Parm                    pFile
     c                   Parm                    pJob
     c                   Parm                    pUsrLst
     c                   Parm                    pDltDate
     c                   Parm                    pOutqLst
     c                   Parm                    pFrmType
     c                   Parm                    pUsrDta
     c                   Parm                    pStsLst
     c                   Parm                    pDevLst

     c                   EndSr



     h nomain
      *--------------------------------------------------------------------------------------------
      *    Program  . . :  PRCCMD           Author . . :  Rick Chevalier
      *    Date . . . . :   1/19/2000
      *    Purpose  . . :  Process or run a command.
      *--------------------------------------------------------------------------------------------
      *    Modifications:                               Date/Prgrmmr
      *--------------------------------------------------------------------------------------------
      *      None to this point.
      *--------------------------------------------------------------------------------------------
      * Required Parameter Group:
      *  1  Source command string                     Input   Char(*)
      * Optional Parameter Group:
      *  2  Processing type                           Input   Char(1)
      *        '0' - Never prompt the command
      *        '1' - Always prompt the command
      *   Dft  '2' - Prompt the command if selective prompting characters are present in the comman
      *        '3' - Show help
      *--------------------------------------------------------------------------------------------
      * Internal procedure prototypes
      *--------------------------------------------------------------------------------------------
      * Prototype for process command procedure (PrcCmd)
     d PrcCmd          pr              *
     d                            32702                                         Command
     d                                1    options(*nopass: *omit)              Prompt type

      *--------------------------------------------------------------------------------------------
      * External procedure prototypes.
      *--------------------------------------------------------------------------------------------
      * Send program message.
     dsndpgmmsg        pr             4
     d##_msgid                        7
     d##_msgf                        20
     d##_msgdta@                       *   const
     d##_msgtyp                      10    options(*nopass)                     Defaults to *DIAG

      *--------------------------------------------------------------------------------------------
      * Process command (QCAPCMD) API.  Check or run a CL command.
      *--------------------------------------------------------------------------------------------
     pprccmd           b                   export
     dprccmd           pi              *
     d##_cmd                      32702
     d##_pmttyp                       1    options(*nopass: *omit)              Default = 2

      *  1  Length of source command string           Input   Binary(4)
      *  2  Options control block                                         Input   Char(*)
      *  3  Options control block length                                  Input   Binary(4)
      *  4  Options control block format                                  Input   Char(8)
      *  5  Changed command string                                        Output  Char(*)
      *  6  Length available for changed command string                   Input   Binary(4)
      *  7  Length of changed command string available to return          Output  Binary(4)
      *  8  Error code                                                    I/O     Char(*)

     d##_cmdlen        s              9b 0
     d##_ocb           ds
     d  ##_typprc                     9b 0 inz(2)                               Type of processing
     d  ##_dbcs                       1    inz('0')                             DBCS data handling
     d  ##_pmtact                     1                                         Prompter action
     d  ##_cmdstx                     1    inz('0')                             Command syntax
     d  ##_msgkey                     4    inz(*blanks)                         Msg retrieve key
     d  ##_reserve                    9    inz(x'000000000000000000')           Reserved
     d##_ocblen        s              9b 0 inz(20)
     d##_ocbfmt        s              8    inz('CPOP0100')
     d##_chgcmd        s          32702
     d##_chglen        s              9b 0
     d##_chgavl        s              9b 0 inz(32702)
     d##_error         ds
     d  ##_erbp                1      4B 0 inz(128)                             Bytes provided
     d  ##_erba                5      8B 0                                      Bytes available
     d  ##_erexid              9     15                                         Exception ID
     d  ##_erexdta            17    116                                         Exception data

     d##_msgf          s             20    inz('QCPFMSG   *LIBL     ')

      * Parameter list for API call.
     c     qcapcmd       plist
     c                   parm                    ##_cmd
     c                   parm                    ##_cmdlen
     c                   parm                    ##_ocb
     c                   parm                    ##_ocblen
     c                   parm                    ##_ocbfmt
     c                   parm                    ##_chgcmd
     c                   parm                    ##_chglen
     c                   parm                    ##_chgavl
     c                   parm                    ##_error

      * Determine the length of the command string to process.
     c                   eval      ##_cmdlen = %len(%trim(##_cmd))

      * Determine the length of the command string to process.
     c                   if        (%parms = 2 and %addr(##_pmttyp) = *null) or
     c                             %parms = 1
     c                   eval      ##_pmtact = '2'
     c                   else
     c                   eval      ##_pmtact = ##_pmttyp
     c                   endif

      * Process command.
     c                   call      'QCAPCMD'     qcapcmd

      * If no error return address of attribute information.
     c                   if        ##_erexid = *blanks
     c                   return    %addr(##_chgcmd)

      * Send error message to job log and return null address.
     c                   else
     c                   callp     sndpgmmsg(##_erexid: ##_msgf:
     c                                       %addr(##_erexdta))
     c                   return    *null
     c                   endif

     pprccmd           e



     h nomain
      *--------------------------------------------------------------------------------------------
      *    Program  . . :  SNDPGMMSG        Author . . :  Rick Chevalier
      *    Date . . . . :  12/11/2000
      *    Purpose  . . :  Send a program message.
      *--------------------------------------------------------------------------------------------
      *    Modifications:                               Date/Prgrmmr
      *--------------------------------------------------------------------------------------------
      *      None to this point.
      *--------------------------------------------------------------------------------------------
      * Parameter definitions
      *   1  Message identifier                         Input    Char(7)
      *   2  Qualified message file name                Input    Char(20)
      *   3  Message data or immediate text             Input    Char(*)
      *   4  Message type                               Input    Char(10)
      *   5  Call stack counter                         Input    Binary(4)
      *--------------------------------------------------------------------------------------------
      * Internal procedure prototypes.
      *--------------------------------------------------------------------------------------------
     dsndpgmmsg        pr             4
     d##_msgid                        7
     d##_msgf                        20
     d##_msgdta@                       *   const
     d##_msgtyp                      10    options(*nopass)
     d##_stkent                      10    options(*nopass)
     d##_stkctr                       9b 0 options(*nopass)
      *--------------------------------------------------------------------------------------------
      * Send program message.
      *--------------------------------------------------------------------------------------------
     psndpgmmsg        b                   export
     dsndpgmmsg        pi             4
     d##_msgid                        7
     d##_msgf                        20
     d##_msgdta@                       *   const
     d##_msgtypi                     10    options(*nopass)
     d##_stkenti                     10    options(*nopass)
     d##_stkctri                      9b 0 options(*nopass)

      * Additional API parameters.
      *   4  Length of message data or immediate text   Input    Binary(4)
      *   6  Call stack entry                           Input    Char(*) or Pointer
      *   7  Call stack counter                         Input    Binary(4)
      *   8  Message key                                Output   Char(4)
      *   9  Error code                                 I/O      Char(*)

      * Parameters for Send Program Message (QMHSNDPM) API
     d##_msgdta        ds          1024    based(##_msgdta@)
     d##_dtalen        s              9b 0
     d##_msgtyp        s             10
     d##_stkent        s             10    inz('*')
     d##_stkctr        s              9b 0
     d##_msgkey        s              4
     d##_error         ds           128
     d  ##_erbp                1      4B 0 inz(0)                               Bytes provided
     d  ##_erba                5      8B 0 inz(0)                               Bytes available
     d  ##_erexid              9     15                                         Exception ID
     d  ##_erexdta            17    116                                         Exception data

     c                   eval      ##_dtalen = %len(%trimr(##_msgdta))

      * If message type is passed use it.  If not default to *DIAG.
     c                   if        %parms >= 4
     c                   eval      ##_msgtyp = ##_msgtypi
     c                   else
     c                   eval      ##_msgtyp = '*DIAG'
     c                   endif

      * If stack entry is passed use it.  If not default to current entry (*).
     c                   if        %parms >= 5
     c                   eval      ##_stkent = ##_stkenti
     c                   else
     c                   eval      ##_stkent = '*'
     c                   endif

      * If stack counter is passed use it.  If not default to 0.
     c                   if        %parms >= 6
     c                   eval      ##_stkctr = ##_stkctri
     c                   else
     c                   eval      ##_stkctr = 0
     c                   endif

      * Send message.
     c                   call      'QMHSNDPM'
     c                   parm                    ##_msgid
     c                   parm                    ##_msgf
     c                   parm                    ##_msgdta
     c                   parm                    ##_dtalen
     c                   parm                    ##_msgtyp
     c                   parm                    ##_stkent
     c                   parm                    ##_stkctr
     c                   parm                    ##_msgkey
     c                   parm                    ##_error

     c                   return    ##_msgkey

     psndpgmmsg        e

Thanks to Rick Chevalier
Back

QSYLOBJA

QSYLOBJA - List Objects User Is Authorized to, Owns, or Is Primary Group of

     **
     **  Program . . : CBX9562
     **  Description : List user's objects
     **  Author  . . : Carsten Flensburg
     **
     **
     **
     **  Compile instructions:
     **    CrtRpgMod   Module( CBX9562 )
     **                DbgView( *LIST )
     **
     **    CrtPgm      Pgm( CBX9562 )
     **                Module( CBX9562 )
     **                ActGrp( *NEW )
     **
     **
     **-- Control specification:  --------------------------------------------**
     H Option( *SrcStmt )

     **-- System information:
     D PgmSts         sDs                  Qualified
     D  JobUsr                       10a   Overlay( PgmSts: 254 )
     D  CurUsr                       10a   Overlay( PgmSts: 358 )
     **-- API error data structure:
     D ERRC0100        Ds                  Qualified
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))
     D  BytAvl                       10i 0
     D  MsgId                         7a
     D                                1a
     D  MsgDta                      128a
     **-- Global constants:
     D USR_SPC_Q       c                   'AUTOBJLST QTEMP'
     D OFS_MSGDTA      c                   16
     **-- Global variables:
     D Idx             s             10i 0
     D CntHdl          s             20a   Inz

     **-- Entry format OBJA0100:
     D OBJA0100        Ds                  Qualified  Based( pLstEnt )
     D  ObjNam                       10a
     D  ObjLib                       10a
     D  ObjTyp                       10a
     D  AutHlr                        1a
     D  ObjOwn                        1a
     D  AspDevLib                    10a
     D  AspDevObj                    10a
     **-- Entry format OBJA0110:
     D OBJA0110        Ds          5120    Qualified  Based( pLstEnt )
     D  OfsPthNam                    10i 0
     D  LenPthNam                    10i 0
     D  ObjTyp                       10a
     D  AutHlr                        1a
     D  ObjOwn                        1a
     D  AspDevNam                    10a
     **
     D Path            Ds                  Qualified  Based( pPath )
     D  PthCcsId                     10i 0
     D  CtrRegId                      2a
     D  LngId                         3a
     D                                3a
     D  FlgByt                       10i 0
     D  PthNamLen                    10i 0
     D  PthDlm                        2a
     D                               10a
     D  PthNam                     5000a
     **
     D PthNam          s           5000a   Varying
     **-- API input parameter information:
     D InpPrm          Ds                  Qualified  Based( pInpPrm )
     D  UsrSpc                       10a
     D  UsrSpcLib                    10a
     D  FmtNam                        8a
     D  UsrPrf                       10a
     D  ObjTyp                       10a
     D  RtnObj                       10a
     D  CntHdl                       20a
     D  OfsRqsLst                    10i 0
     D  NbrLstEnt                    10i 0
     D  RqsLst                       30a
     **-- API header information:
     D HdrInf          Ds                  Qualified  Based( pHdrInf )
     D  UsrPrf                       10a
     D  CntHdl                       20a
     D  RsnCod                       10i 0
     **-- User space generic header:
     D UsrSpc          Ds                  Qualified  Based( pUsrSpc )
     D  HdrSiz                       10i 0 Overlay( UsrSpc:  65 )
     D  RelLvl                        4a   Overlay( UsrSpc:  69 )
     D  FmtNam                        8a   Overlay( UsrSpc:  73 )
     D  ApiNam                       10a   Overlay( UsrSpc:  81 )
     D  CrtDtm                       13a   Overlay( UsrSpc:  91 )
     D  InfSts                        1a   Overlay( UsrSpc: 104 )
     D  UsrSpcSiz                    10i 0 Overlay( UsrSpc: 105 )
     D  OfsInp                       10i 0 Overlay( UsrSpc: 109 )
     D  SizInp                       10i 0 Overlay( UsrSpc: 113 )
     D  OfsHdr                       10i 0 Overlay( UsrSpc: 117 )
     D  SizHdr                       10i 0 Overlay( UsrSpc: 121 )
     D  OfsLst                       10i 0 Overlay( UsrSpc: 125 )
     D  SizLst                       10i 0 Overlay( UsrSpc: 129 )
     D  NumLstEnt                    10i 0 Overlay( UsrSpc: 133 )
     D  SizLstEnt                    10i 0 Overlay( UsrSpc: 137 )
     D  LstCcsId                     10i 0 Overlay( UsrSpc: 141 )
     D  CtrRegId                      2a   Overlay( UsrSpc: 145 )
     D  LngId                         3a   Overlay( UsrSpc: 147 )
     D  SubSetInd                     1a   Overlay( UsrSpc: 149 )
     **-- Space pointers:
     D pUsrSpc         s               *   Inz( *Null )
     D pInpPrm         s               *   Inz( *Null )
     D pHdrInf         s               *   Inz( *Null )
     D pLstEnt         s               *   Inz( *Null )

     **-- List user objects:
     D LstUsrObj       Pr                  ExtPgm( 'QSYLOBJA' )
     D  SpcNamQ                      20a   Const
     D  FmtNam                        8a   Const
     D  UsrPrf                       10a   Const
     D  ObjTyp                       10a   Const
     D  RtnObj                       10a   Const
     D  CntHdl                       20a   Const
     D  Error                     32767a          Options( *VarSize )
     D  RqsLst                       30a          Options( *VarSize: *NoPass )
     **-- Create user space:
     D CrtUsrSpc       Pr                  ExtPgm( 'QUSCRTUS' )
     D  SpcNamQ                      20a   Const
     D  ExtAtr                       10a   Const
     D  InzSiz                       10i 0 Const
     D  InzVal                        1a   Const
     D  PubAut                       10a   Const
     D  Text                         50a   Const
     D  Replace                      10a   Const  Options( *NoPass )
     D  Error                     32767a          Options( *NoPass: *VarSize )
     D  Domain                       10a   Const  Options( *NoPass )
     D  TfrSizRqs                    10i 0 Const  Options( *NoPass )
     D  OptSpcAlg                     1a   Const  Options( *NoPass )
     **-- Retrieve pointer to user space:
     D RtvPtrSpc       Pr                  ExtPgm( 'QUSPTRUS' )
     D  SpcNamQ                      20a   Const
     D  Pointer                        *
     D  Error                     32767a          Options( *NoPass: *VarSize )
     **-- Delete user space:
     D DltUsrSpc       Pr                  ExtPgm( 'QUSDLTUS' )
     D  SpcNamQ                      20a   Const
     D  Error                     32767a          Options( *VarSize )
     **-- Send program message:
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  MsgId                         7a   Const
     D  MsgFq                        20a   Const
     D  MsgDta                      128a   Const
     D  MsgDtaLen                    10i 0 Const
     D  MsgTyp                       10a   Const
     D  CalStkE                      10a   Const  Options( *VarSize )
     D  CalStkCtr                    10i 0 Const
     D  MsgKey                        4a
     D  Error                      1024a          Options( *VarSize )

     **-- Send escape message:
     D SndEscMsg       Pr            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **-- Send completion message:
     D SndCmpMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying

     D CBX9562         Pr
     D  PxUsrPrf                     10a
     **
     D CBX9562         Pi
     D  PxUsrPrf                     10a

      /Free

        CrtUsrSpc( USR_SPC_Q
                 : *Blanks
                 : 65535
                 : x'00'
                 : '*CHANGE'
                 : *Blanks
                 : '*YES'
                 : ERRC0100
                 );

        RtvPtrSpc( USR_SPC_Q: pUsrSpc );

        DoU  CntHdl = *Blanks;

          LstUsrObj( USR_SPC_Q
                   : 'OBJA0100'
                   : PxUsrPrf
                   : '*ALL'
                   : '*OBJOWN'
                   : CntHdl
                   : ERRC0100
                   );

          If  ERRC0100.BytAvl > *Zero;

            Leave;
          Else;

            ExSr  GetUsrObj;
          EndIf;
        EndDo;

        DoU  CntHdl = *Blanks;

          LstUsrObj( USR_SPC_Q
                   : 'OBJA0110'
                   : PxUsrPrf
                   : '*ALL'
                   : '*OBJOWN'
                   : CntHdl
                   : ERRC0100
                   );

          If  ERRC0100.BytAvl > *Zero;

            Leave;
          Else;

            ExSr  GetUsrFil;
          EndIf;
        EndDo;

        DltUsrSpc( USR_SPC_Q: ERRC0100 );

        If  ERRC0100.BytAvl > *Zero;

          If  ERRC0100.BytAvl < OFS_MSGDTA;
            ERRC0100.BytAvl = OFS_MSGDTA;
          EndIf;

          SndEscMsg( ERRC0100.MsgId
                   : 'QCPFMSG'
                   : %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl-OFS_MSGDTA )
                   );
        Else;

          SndCmpMsg( 'Command completed normally.' );
        EndIf;

        *InLr = *On;
        Return;


        BegSr  GetUsrObj;

          pInpPrm = pUsrSpc + UsrSpc.OfsInp;
          pHdrInf = pUsrSpc + UsrSpc.OfsHdr;
          pLstEnt = pUsrSpc + UsrSpc.OfsLst;

          For  Idx = 1  To  UsrSpc.NumLstEnt;


            If  Idx < UsrSpc.NumLstEnt;
              pLstEnt += UsrSpc.SizLstEnt;
            EndIf;
          EndFor;

          CntHdl = HdrInf.CntHdl;

        EndSr;

        BegSr  GetUsrFil;

          pInpPrm = pUsrSpc + UsrSpc.OfsInp;
          pHdrInf = pUsrSpc + UsrSpc.OfsHdr;
          pLstEnt = pUsrSpc + UsrSpc.OfsLst;

          For  Idx = 1  To  UsrSpc.NumLstEnt;

            pPath = pUsrSpc + OBJA0110.OfsPthNam;
            PthNam = %Subst( Path.PthNam: 1: Path.PthNamLen );

            If  Idx < UsrSpc.NumLstEnt;
              pLstEnt += UsrSpc.SizLstEnt + OBJA0110.LenPthNam;
            EndIf;
          EndFor;

          CntHdl = HdrInf.CntHdl;

        EndSr;

      /End-Free

     **-- Send escape message:
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgId                       7a   Const
     D  PxMsgF                       10a   Const
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( PxMsgId
                 : PxMsgF + '*LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*ESCAPE'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return   0;
        EndIf;

      /End-Free

     P SndEscMsg       E
     **-- Send completion message:
     P SndCmpMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **
     D MsgKey          s              4a

      /Free

        SndPgmMsg( 'CPF9897'
                 : 'QCPFMSG   *LIBL'
                 : PxMsgDta
                 : %Len( PxMsgDta )
                 : '*COMP'
                 : '*PGMBDY'
                 : 1
                 : MsgKey
                 : ERRC0100
                 );

        If  ERRC0100.BytAvl > *Zero;
          Return  -1;

        Else;
          Return  0;

        EndIf;

      /End-Free

     P SndCmpMsg       E

Thanks to Carsten Flensburg

QSYLOBJA - A CLLE version pgm ( + &pUsrPrf + ) dcl &pUsrPrf *char 10 dcl &UsrPrf *char 10 dcl &TempLib *char 10 value( 'QTEMP' ) dcl &qusrspc *char 20 dcl &ErrCod *char 4 dcl &hCont *char 20 dcl &us_hdr *char 150 /* Space header */ dcl &l_hdr *char 34 /* List header */ /* This is a general-purpose field to hold objlck data... */ dcl &us_obje *char 108 /* A single entry */ /* When retrieving *usrspc entries, we need a start position,.. */ dcl &STRPOS *dec 9 /* Loop checking... */ dcl &LoopChk *dec 11 value( 0 ) /* Total objects... */ dcl &tObjOwn *dec 11 value( 0 ) dcl &tObjOwn2 *dec 11 value( 0 ) /* General fields for RUSGENHDR... */ dcl &nbrlste *dec 7 dcl &ists *char 1 dcl &offshdr *char 4 SNDPGMMSG MSG('Begin') TOPGMQ(*EXT) MSGTYPE(*INFO) chgvar &UsrPrf &pUsrPrf chgvar &hCont ' ' chgvar &qusrspc ( 'LOBJOWN ' *cat &TempLib ) call QUSCRTUS ( + &qusrspc + 'TMPLST ' + x'00001000' + X'00' + '*ALL ' + 'Temp list obj owned ' + '*YES ' + x'0000000000000000' + ) QFS_obj: call QSYLOBJA ( + &qusrspc + 'OBJA0100' + &UsrPrf + '*ALL ' + '*OBJOWN ' + &hCont + x'0000000000000000' + ) /* Retrieve the initialization data... */ call QUSRTVUS ( + &qusrspc + x'00000001' + x'00000096' + &us_hdr + ) chgvar &nbrlste %bin( &us_hdr 133 4 ) chgvar &ists %sst( &us_hdr 104 1 ) chgvar &offshdr %sst( &us_hdr 117 4 ) chgvar %bin( &offshdr ) ( %bin( &offshdr ) + 1 ) call QUSRTVUS ( + &qusrspc + &offshdr + x'00000022' + &l_hdr + ) chgvar &hCont %sst( &l_hdr 11 20 ) dmpclpgm if ( &nbrlste *eq 0 ) do sndpgmmsg msgid( CPF9898 ) msgf( QCPFMSG ) + msgdta( 'No objects listed' ) goto Clean_up enddo /* Add this count to our total... */ chgvar &tObjOwn ( &tObjOwn + &nbrlste ) chgvar &LoopChk ( &LoopChk + 1 ) if ( &ists *eq 'P' ) do goto QFS_obj enddo SNDPGMMSG MSG('Next') TOPGMQ(*EXT) MSGTYPE(*INFO) chgvar &hCont ' ' IFS_obj: call QSYLOBJA ( + &qusrspc + 'OBJA0110' + &UsrPrf + '*ALL ' + '*OBJOWN ' + &hCont + x'0000000000000000' + ) /* Retrieve the initialization data... */ call QUSRTVUS ( + &qusrspc + x'00000001' + x'00000096' + &us_hdr + ) chgvar &nbrlste %bin( &us_hdr 133 4 ) chgvar &ists %sst( &us_hdr 104 1 ) if ( &nbrlste *eq 0 ) do sndpgmmsg msgid( CPF9898 ) msgf( QCPFMSG ) + msgdta( 'No IFS objects listed' ) goto Clean_up enddo /* Add this count to our total... */ chgvar &tObjOwn2 ( &tObjOwn2 + &nbrlste ) chgvar &LoopChk ( &LoopChk + 1 ) if ( &ists *eq 'P' ) do goto IFS_obj enddo Clean_up: SNDPGMMSG MSG('End') TOPGMQ(*EXT) MSGTYPE(*INFO) dmpclpgm return endpgm Thanks to Tom Liotta

Back

Qp0zGetSysEnv
Qp0zGetSysEnv - Get System Level Environment



File   : QRPGLESRC
Member : RTVENVVAR
Type   : RPGLE
Usage  : CRTBNDRPG PGM(RTVENVVAR) TGTRLS(V5R1M0)

    H Debug
    H OPTION(*NODEBUGIO : *SRCSTMT) DFTACTGRP(*NO) BNDDIR('QC2LE')
      **************************************************************************
      **  This program returns the environment variable's value.
      **  It is stuffed into the CL variable passed on the 2nd parm.
      **  CPP for RTVENVVAR CL command.
      **************************************************************************

      ** Template definition used for 2nd parameter
    D CL_RTNVAR_T    DS                  based(pNothing_T) QUALIFIED
    D  nLen                          5I 0
    D  Data                      32766A

    D RtvEnvVar      PR
    D  envvar                      256A
    D  rtnVar                            LIKEDS(CL_RTNVAR_T)
    D  envlvl                        4A

    D RtvEnvVar      PI
    D  envvar                      256A
    D  rtnVar                            LIKEDS(CL_RTNVAR_T)
    D  envlvl                        4A

      * Get job level env
    D Qp0zGetEnv      PR              *  ExtProc('Qp0zGetEnv')
    D  envvar                        *  VALUE OPTIONS(*STRING)
    D  nCCSID                      10I 0

      * Get sys level env
    D Qp0zGetSysEnv  PR            10I 0 ExtProc('Qp0zGetSysEnv')
    D  envVarName                    *  VALUE OPTIONS(*STRING)
    D  rtnBuffer                65535A  OPTIONS(*VARSIZE)
    D  bufLen                      10I 0
    D  nCCSID                      10I 0
    D  reserved                      *  OPTIONS(*OMIT)

    D  rtnBuffer      S            512A
    D  pRtnBuffer    S              *  Inz
    D  pEnv          S              *  Inz
    D  bufLen        S            10I 0
    D  nCCSID        S            10I 0 Inz(0)
    D  nRtn          S            10I 0 Inz(0)

    C                  eval      *INLR = *ON
    C                  if        envlvl = '*JOB'
      ** Retrieve a pointer to the environment variable's value
    C                  eval      pEnv = Qp0zGetEnv(%TRIMR(ENVVAR):nCCSID)

      **  If nothing came back, then the ENVVAR is bad, so return nothing.
    C                  if        pEnv = *NULL
    C                  return
    C                  endif

      **  Copy the environment variable to the return variable,
      **  being careful not to overstep the variable's length.
    C                  eval      %subst(rtnVar.Data:1:rtnVar.nLen) =
    C                                %str(pEnv)
    C                  else
    C                  eval      bufLen = %len(rtnBuffer)
    C                  eval      nRtn = Qp0zGetSysEnv(%TRIMR(ENVVAR):
    C                                                  rtnBuffer  :
    C                                                  bufLen    :
    C                                                  nCCSID :
    C                                                  *OMIT)
    C                  if        nRtn <> 0
    C                  dump
    C                  return
    C                  endif

    C                  eval      rtnVar.nLen = bufLen
    C                  eval      pRtnBuffer = %addr(rtnBuffer)
    C                  eval      %subst(rtnVar.Data:1:bufLen) =
    C                                %str(pRtnBuffer)
    C                  endif

    C                  return

File : QCMDSRC Member : RTVENVVAR Type : CMD Usage : CRTCMD CMD(your-lib/RTVENVVAR) PGM(your-lib/RTVENVVAR) ALLOW(*IPGM *BPGM) RTVENVVAR: CMD PROMPT('Retrieve Environment Variable') /* Command processing program is RTVENVVAR */ PARM KWD(ENVVAR) TYPE(*CHAR) LEN(256) MIN(1) + EXPR(*YES) INLPMTLEN(17) + PROMPT('Environment variable') PARM KWD(RTNVAL) TYPE(*CHAR) LEN(1) RTNVAL(*YES) + VARY(*YES) CHOICE('Environment var return + value') PROMPT('CL Var. for return value') PARM KWD(LEVEL) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*JOB) SPCVAL((*JOB) (*SYS)) + EXPR(*YES) PMTCTL(*PMTRQS) PROMPT('Level')

File : QCLSRC Member : RTVENVVARC Type : CLP Usage : CRTCLPGM RTVENVVARC CALL RTVENVVARC /* Before you run the program run following command to set sample */ /* environment variable for testing: */ /* ADDENVVAR ENVVAR(JOBCLASSPATH) VALUE('.:/java') */ /* ADDENVVAR ENVVAR(SYSCLASSPATH) VALUE('.:/system') LEVEL(*SYS) */ /* After you run the program run following command to reset ENVVAR */ /* RMVENVVAR ENVVAR(JOBCLASSPATH) */ /* RMVENVVAR ENVVAR(SYSCLASSPATH) LEVEL(*SYS) */ /* You can browse spooled file QPPGMDMP under current job for job */ /* and system level value same as we set above */ PGM DCL &SYSPATH *CHAR 32 DCL &JOBPATH *CHAR 32 RTVENVVAR ENVVAR(JOBCLASSPATH) RTNVAL(&JOBPATH) RTVENVVAR ENVVAR(SYSCLASSPATH) RTNVAL(&SYSPATH) + LEVEL(*SYS) DMPCLPGM ENDPGM Thanks to Vengoal Chang

Back

More API's, when I have the time

Back