iSeries & System i

#1 Tips & Tricks - Table of Contents #3

Hex Conversion Routine - sprintf
Check if TCP/IP is up
Find all System Commands having had one or more defaults changed
Colorizing Fields
Get Key System Information Into a Library
Binary Characters to Decimal
Last IPL Date & Time
UDS vs LDA
Print Report on Time Spent in IPL Phases/Steps
Converting from C prototypes to RPG prototypes
Centering Text On a Field
Identify the serial number or ID of various LPARS configured on iSeries
Display the amount of temporary storage a job is using
Checking lots of Queries for a field
List ILE Builtin Functions
Play with Qsort()
iSeries (AS/400) Front Panel Keys Configuration
Loading PTF Cover Letters from CD-Rom
Where %Eof, %Equal, and %Found may be used
How many objects in a system?



Hex Conversion Routine - sprintf

One way to convert *several* numeric values to a string containing
hex values is to use the C runtime library function "sprintf".

Coding the prototype is a bit tricky.  The trick to calling C
functions with varying length argument list is to code
OPTIONS(*NOPASS) for at least one of the arguments.  (It has
something to do with making sure the arguments are not passed in
registers.)  Check the following RPG program for an example of how
to call "sprintf":


	H dftactgrp(*no) bnddir('QC2LE')
	D sprintfxxx      pr            10i 0 extproc(*cwiden:'sprintf')
	D   recvr                         *   value
	D   format                        *   value options(*string)
	D   red                          3u 0 value
	D   blue                         3u 0 value
	D   green                        3u 0 value options(*nopass)
	D FMTXXX          c                   '"#%2.2lx%2.2lx%2.2lx"'
	D recv            s             50a
	D len             s             10i 0
	 /free
	    len = sprintfxxx(%addr(recv):FMTXXX:12:34:45);
	    dsply ('|' + %subst(recv:1:len) + '|');
	    *inlr = *on;
	 /end-free


This working program displays the html color argument value:

DSPLY  |"#0c222d"|

Note that it's important to save the length returned by "sprintf"
and use it to substring the receiver variable since C likes to
deal with null terminated strings.  (Or, you could access the
result value by coding "result=%str(%addr(recv));".)

Thanks to Hans Boldt
Back

Check if TCP/IP is up

	Pgm

	Dcl Var(&InlSize) +
	           Type(*Dec) +
	           Len(6 0) +
	Value(1000)
	Dcl Var(&Size) +
	           Type(*Char) +
	           Len(4)
	Dcl        Var(&Start) +
	           Type(*Dec) +
	           Len(6 0) +
	           Value(133)
	Dcl        Var(&Len) +
	           Type(*Dec) +
	           Len(4 0) +
	Value(4)
	Dcl        Var(&StrPos) +
	           Type(*Char) +
	           Len(4)
	Dcl        Var(&DataLen) +
	           Type(*Char) +
	           Len(4)
	Dcl        Var(&Receiver) +
	           Type(*Char) +
	           Len(1000)
	Dcl        Var(&Entries) +
	           Type(*Dec) +
	           Len(8 0) +

	ChgVar   Var(%bin(&Size)) +
	Value(&InlSize )
	ChgVar   Var(%bin(&StrPos)) +
	         Value(&Start)
	ChgVar   Var(%bin(&DataLen)) +
	         Value(&Len)

	Call Pgm(QUSCrtUS) +
	Parm('QTEMP     TCPSTSCHK ' +
	    'PROD' +
	    &Size +
	    ' ' +
	    '*EXCLUDE' +
	    'TCP/IP Status Check')

	 Call       Pgm(QUSLJob)
	Parm('QTEMP     TCPSTSCHK ' +
	               'JOBL0100' +
	               'QTCPIP    *ALL      *ALL      ' +
	                '*ACTIVE')

	Call       Pgm(QUSRtvUS) +
	Parm('QTEMP     TCPSTSCHK ' +
	                &StrPos
	                &DataLen
	                &Receiver )

	ChgVar   Var(&Entries)           +
	           Value(%bin(&Receiver 1 4))

	If         Cond(&Entries *gt 0) +
	           Then(Do)
		TCP/IP is active.... continue
	EndDo
	Else    Cmd(Do)
		TCP/IP is not active... loop and recheck
	EndDo

	EndPgm:
	EndPgm

Thanks to Todd Kidwell

Tom Liotta comments: Although the risk may be negligible, keep in mind that the CLP does not tell whether TCP/IP is active or not; rather, it tells whether a job named QTCPIP is active or not -- a job with that name _can_ come from anyone and be doing anything. If this is the route you want to take, I'd suggest simply calling the Retrieve Configuration Status (QDCRCFGS) API with the name of your TCP/IP network device. Check the returned status to see if it's 'ACTIVE' and maybe check the returned job name to see if it's active under job QTCPIP. Much simpler and even less risk though still not eliminated.
Back

Find all System Commands where defaults has been changed
Run the following command:

   DSPOBJD OBJ(QSYS/*ALL)
           OBJTYPE(*CMD)
           OUTPUT(*OUTFILE)
           OUTFILE('filename')


- and then, using query or sql, select all records in 'filename' with an Apar Id (field ODAPAR)
equal  'CHGDFT'.
Thanks to Carsten Flensburg
Back

Colorizing Fields
Just add a hex constant where you want color.
This works for any displayable field. Here's a set of color constants I use:

 *** COLORS ***
D White           C                   CONST( X'22'                        )
D White_UL        C                   CONST( X'26'                        )
D White_RI        C                   CONST( X'23'                        )
D White_RI_CS     C                   CONST( X'33'                        )

D PR_White        C                   CONST( X'A2'                        )
D PR_White_UL     C                   CONST( X'A6'                        )
D PR_White_RI     C                   CONST( X'A3'                        )
D PR_White_RI_CS  C                   CONST( X'B3'                        )

D Green           C                   CONST( X'20'                        )
D Green_RI        C                   CONST( X'21'                        )
D Green_UL        C                   CONST( X'24'                        )
D Green_UL_RI     C                   CONST( X'25'                        )

D PR_Green        C                   CONST( X'A0'                        )
D PR_Green_RI     C                   CONST( X'A1'                        )
D PR_Green_UL     C                   CONST( X'A4'                        )
D PR_Green_UL_RI  C                   CONST( X'A5'                        )

D Red             C                   CONST( X'28'                        )
D Red_RI          C                   CONST( X'29'                        )
D Red_HI          C                   CONST( X'2A'                        )
D Red_HI_RI       C                   CONST( X'2B'                        )
D Red_UL          C                   CONST( X'2C'                        )
D Red_UL_RI       C                   CONST( X'2D'                        )
D Red_UL_BL       C                   CONST( X'2E'                        )

D PR_Red          C                   CONST( X'A8'                        )
D PR_Red_RI       C                   CONST( X'A9'                        )
D PR_Red_HI       C                   CONST( X'AA'                        )
D PR_Red_HI_RI    C                   CONST( X'AB'                        )
D PR_Red_UL       C                   CONST( X'AC'                        )
D PR_Red_UL_RI    C                   CONST( X'AD'                        )
D PR_Red_UL_BL    C                   CONST( X'AE'                        )

D Turq_CS         C                   CONST( X'30'                        )
D Turq_CS_RI      C                   CONST( X'31'                        )
D Turq_UL_CS      C                   CONST( X'34'                        )
D Turq_UL_RI_CS   C                   CONST( X'35'                        )

D PR_Turq_CS      C                   CONST( X'B0'                        )
D PR_Turq_CS_RI   C                   CONST( X'B1'                        )
D PR_Turq_CS_UL   C                   CONST( X'B4'                        )
D PR_Turq_CSULRI  C                   CONST( X'B5'                        )

D Yellow_CS       C                   CONST( X'32'                        )
D Yellow_CS_UL    C                   CONST( X'36'                        )

D PR_Yellow_CS    C                   CONST( X'B2'                        )
D PR_Yellow_CSUL  C                   CONST( X'B6'                        )

D Pink            C                   CONST( X'38'                        )
D Pink_RI         C                   CONST( X'39'                        )
D Pink_UL         C                   CONST( X'3C'                        )
D Pink_UL_RI      C                   CONST( X'3D'                        )

D PR_Pink         C                   CONST( X'B8'                        )
D PR_Pink_RI      C                   CONST( X'B9'                        )
D PR_Pink_UL      C                   CONST( X'BC'                        )
D PR_Pink_UL_RI   C                   CONST( X'BD'                        )

D Blue            C                   CONST( X'3A'                        )
D Blue_RI         C                   CONST( X'3B'                        )
D Blue_UL         C                   CONST( X'3E'                        )

D PR_Blue         C                   CONST( X'BA'                        )
D PR_Blue_RI      C                   CONST( X'BB'                        )
D PR_Blue_UL      C                   CONST( X'BE'                        )

Thanks to Nelson Smith
Back

Get Key System Information Into a Library

Joe Pluta wrote:
> I agree, Rob.  In fact, I just did it.  The nice thing is that it includes
> third party licenses as well, so you have one simple sheet for all of it.
> Not only that, but there is an option to dump everything to a license key
> file for backup.

As part of our daily backup, I run a program, GETSYSINF, that does a
RTVSYSINF into a library that then immediately gets backed up.

I just added a DSPLICKEY statement at the end to add license information
to the same library.

This is the code:

/* GET KEY SYSTEM INFORMATION INTO A LIBRARY */
/* MUST BE OWNED BY QSECOFR AND USRPRF(*OWNER) */

              PGM
              DCL        VAR(&LIB) TYPE(*CHAR) LEN(10) +
                           VALUE('SYSTEMINFO') /* Library to contain +
                           system info */

              CLRLIB     LIB(&LIB)
              MONMSG     MSGID(CPF0000) EXEC(DO)
              CRTLIB     LIB(&LIB) TEXT('Output of RTVSYSINF (Key +
                           system information)')
              ENDDO
              RTVSYSINF  LIB(&LIB)
              DSPLICKEY  OUTPUT(*LICKEYFILE) LICKEYFILE(&LIB/LICKEYINFO)
              ENDPGM

Thanks to Jeff Crosby
Back

Binary Characters to Decimal

Q: I've been tasked with converting a character representation of a binary number
to it's decimal equivalent and vice versa. For example I have a series of nine
characters '001011101' and I'm suppose to get the AS/400 to come up with 93. Or I
have the decimal number 321 and I need to get to '101000001'

A: It's pretty easy to check each '1' or '0' and calculate it up.  See below.


      h dftactgrp(*no)

      D DEBUG           c                   const(1)

      D char2dec        pr            15p 0
      D  binstring                   256    const

      D  test0          c                   '0'
      D  test1          c                   '1'
      D  test2          c                   '11111111'
      D  test4          c                   '010101010101111010101010111101'
      D  somenum        s             15p 0
       /free
           // do the conversion
           somenum = char2dec(test0);
           somenum = char2dec(test1);
           somenum = char2dec(test2);
           somenum = char2dec('1111 1111');
           somenum = char2dec(test4);
           eval *inlr = *on;
       /end-free

       * Convert a bit string into its decimal number
      P char2dec        b
      D char2dec        pi            15p 0
      D  binstring                   256    const

      D  max            c                   const(256)
      D  i              s             10i 0
      D  multiplier     s             15p 0 inz(1)
      D  bindigit       s              1
      D  result         s             15p 0 inz
      D  resultc        s             15
       /free
          for i = max downto 1;
              bindigit = %subst(binstring:i:1);
              select;
                  when bindigit = '1';
                      result = result + multiplier;
                      multiplier = multiplier * 2;
                  when bindigit = '0';
                      multiplier = multiplier * 2;
              endsl;
          endfor;

          // display the results
          if DEBUG = 1;
               resultc = %char(result);
               dsply resultc;
          endif;
          return result;
       /end-free
      P char2dec        e

Thanks to Rich Duzenbury

Another example:
For conversion of numbers in base 2 to decimal, try the C run-time library function "strtol()". Here's an example:
H dftactgrp(*no) bnddir('QC2LE') D strtol pr 10i 0 extproc('strtol') D*strtoll pr 10i 0 extproc('strtoll') D* (for large numbers) D nptr * value options(*string) D endptr * value D base 10i 0 value D ptr s * /free dsply (strtol('1': %addr(ptr): 2)); dsply (strtol('10': %addr(ptr): 2)); dsply (strtol('11': %addr(ptr): 2)); dsply (strtol('100': %addr(ptr): 2)); dsply (strtol('10010101': %addr(ptr): 2)); *inlr = *on; /end-free Thanks to Hans Boldt
Back

Last IPL Date & Time

I like to use this little CL for the last ipl date time:


	PGM
	DCL        VAR(&DATA) TYPE(*CHAR) LEN(150)
	DCL        VAR(&BIN) TYPE(*CHAR) LEN(4) VALUE(X'00000096')
	DCL        VAR(&CEN) TYPE(*CHAR) LEN(1)
	DCL        VAR(&YY) TYPE(*CHAR) LEN(2)
	DCL        VAR(&MM) TYPE(*CHAR) LEN(2)
	DCL        VAR(&DD) TYPE(*CHAR) LEN(2)
	DCL        VAR(&HH) TYPE(*CHAR) LEN(2)
	DCL        VAR(&M) TYPE(*CHAR) LEN(2)
	DCL        VAR(&SS) TYPE(*CHAR) LEN(2)
	DCL        VAR(&FMT) TYPE(*CHAR) LEN(8) VALUE('JOBI0400')
	DCL        VAR(&JOB) TYPE(*CHAR) LEN(26) +
	             VALUE('SCPF      QSYS      000000')
	DCL        VAR(&JOBI) TYPE(*CHAR) LEN(16)
	CALL       PGM(QUSRJOBI) PARM(&DATA &BIN &FMT &JOB &JOBI)
	CHGVAR     VAR(&CEN) VALUE(%SST(&DATA 63 1))
	CHGVAR     VAR(&YY) VALUE(%SST(&DATA 64 2))
	CHGVAR     VAR(&MM) VALUE(%SST(&DATA 66 2))
	CHGVAR     VAR(&DD) VALUE(%SST(&DATA 68 2))
	CHGVAR     VAR(&HH) VALUE(%SST(&DATA 70 2))
	CHGVAR     VAR(&M) VALUE(%SST(&DATA 72 2))
	CHGVAR     VAR(&SS) VALUE(%SST(&DATA 74 2))
	 SNDPGMMSG  MSG('The system was last IPL''d on ' || &MM +
	                 || '/' || &DD || '/' || &YY || ' at ' || +
	                 &HH || ':' || &M || ':' || &SS || '.')
	 END:        ENDPGM

Thanks to Bryan Dietz
Back

UDS vs LDA

When you define a data area using UDS, the RPG program will read it
automatically when the program starts, lock it, and update/unlock it
only when the program ends.   That's what UDS is for.

If you want to read a data area without doing that, use the IN & OUT
RPG op-codes instead of UDS.

Here's an example of that:


     D LDA             DS                  DTAARA(*LDA)
     D  RptDate                1      8A
     D  RptType              105    106A

     D MyDtaAra        DS           200    DTAARA('QGPL/MYDTAARA')
     D  LastRun                1      8A
     D  LastRptType          105    106A

      ** Load the LDA.  This does not lock it.
     c                   in        LDA
     c                   dsply                   RptDate
     c                   dsply                   RptType

      ** Load My Data Area.  This does not lock it.
     c                   in        MyDtaAra
     c                   dsply                   LastRun
     c                   dsply                   LastRptType

      ** Load My Data Area again, this time lock it and update it.
     c     *lock         in        MyDtaAra
     c                   eval      LastRun = RptDate
     c                   eval      LastRptType = RptType
     c                   out       MyDtaAra

     c                   eval      *inlr = *on

Thanks to Scott Klement
Back

Print Report on Time Spent in IPL Phases/Steps

There is a tool/program that may be used (not available on releases prior to R310) that
generates a spool file which shows how long the system spent in each of the IPL phases.
To generate the spool file, type the following on the OS/400 command line:

	CALL QWCCRTEC

Press the Enter key.

It is rather handy for customers to run this occasionally or at least after IPLs following
abnormal system ending (which forces the 2C40 cleanup) to provide data regarding how long
the IPL stays in each phase. There are major differences between doing an IPL on a fast
newer processor and doing an IPL on an older and much slower box. Major changes have been
made during the various Version 4 releases to speed up the IPL process.

Thanks to IBM

Back

Converting from C prototypes to RPG prototypes

Barbara Morris' "Converting from C prototypes to RPG prototypes" has a small section that
describes C strings, in addition to other useful tips. www.opensource400.org

Thanks to Barbara Morris
Back

Centering Text On a Field

The main body of this was taken from a Bob Cozzi example I think.
If not then I apologize to the person who I got it from.

     H nomain

     H debug(*YES) option(*SRCSTMT) indent('| ')

     D CenterFld       PR         32766    OpDesc
     D   FieldToCtr               32766    Options(*varsize)

     P CenterFld       B                   Export

     D CenterFld       PI         32766    OpDesc
     D   FieldToCtr               32766    Options(*varsize)

     D CEEDOD          PR
     D   ParmNum                     10I 0 Const
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               10I 0
     D                               12A   Options(*omit)

     D DescType        S             10I 0 Inz
     D DataType        S             10I 0 Inz
     D DescInfo1       S             10I 0 Inz
     D DescInfo2       S             10I 0 Inz
     D InLen           S             10I 0 Inz
     D HexLen          S             10I 0 Inz
     D X               S              5  0 Inz
     D Y               S              5  0 Inz
     D Z               S              5  0 Inz
     D ReturnFld       S                   Like(FieldToCtr)

     C                   CallP     CEEDOD( 1         :
     C                                     DescType  :
     C                                     DataType  :
     C                                     DescInfo1 :
     C                                     DescInfo2 :
     C                                     InLen     :
     C                                     *omit )

     C                   Z-Add     InLen         X
     C     ' '           Checkr    FieldToCtr:X  Y
     C                   Eval      Z = ((X - Y) / 2) + 1

     C                   Eval      %subst(ReturnFld:Z:Y) =
     C                             %subst(FieldToCtr:1:Y)

     C                   Return    ReturnFld

     P CenterFld       E

Thanks to Bob Cozzi (??)

And another example:
Here are the special attributes of this procedure: - it accept string of up to 1000 characters - if you do not pass the length of the string, it find it out by itself - you can decide to center the string in another string of a different length This procedure is part of a service progam that handle string manipulation
p Center b export d pi 1000a opdesc d String 1000a options(*varsize) const d StringLen 4s 0 options(*nopass) const d @CalStrLen s like(StringLen) d @SpaceBefore s like(StringLen) d @WrkStr s 1000a d @Return s 1000a * compute size of input parameter c callp CEEDOD(1 : DescType : DataType: c DescInfo1: DescInfo2: Inlen : *OMIT) * extract input string in work field c eval @WrkStr = %subst(String:1:Inlen) * decide the length to use for centering calculation c if %parms < 2 c eval @CalStrLen = InLen c else c eval @CalStrLen = StringLen c endif * center the string c clear @Return c eval @spaceBefore = c (@CalStrLen - %len(%trim(@WrkStr)))/2 + 1 c if @spaceBefore <= 0 c eval @return = %trim(@WrkStr) c else c eval %subst(@return:@spaceBefore) = c %trim(@WrkStr) c endif c return @return p Center e Thanks to Denis Robitaille

And another example:
Here's the routine that I use for such things. It's intended to be generic enough that it'll work for any string that's 256 chars or shorter:
**++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ** util_center(): Center text in a field ** ** peText = text to center ** peSize = size of output field ** ** Returns the centered text. **++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P util_center B export D util_center PI 256A D peText 256A varying const options(*varsize) D peSize 10I 0 value D wwPos s 10I 0 D wwRet s 256A /free wwRet = *blanks; wwPos = ((peSize/2) - (%len(peText)/2)) + 1; %subst(wwRet:wwPos:%len(peText)) = peText; return wwRet; /end-free P E To call it (using your example) you'd do the following: D myString s 65A /free myString = '123 test string 321'; myString = util_center(myString: %size(myString)); /end-free I keep this routine in a service program that's in a binding directory that I specify with every compile that I do, so that anytime I want to center a string, I just code "util_center", as if it's a part of the RPG language. :) Thanks to Scott Klement

A comment from a user trying Scott's version: I don't know if it's a version problem or nobody tried this but the only way I could get Scott Klement's Centering code to work on my V5R4 was to use %trim inside the %Len function. Otherwise it just returns 1. wwPos = ((peSize/2) - (%len(%trim(peText))/2)) + 1; %subst(wwRet:wwPos:%len(%trim(peText))) = peText; Comment from Think400: I think Scott forgot to make myString varying !!! And another 'look alike' to Scott's example:
We've used this procedure for a couple of years. You can change the inbound/outbound variable attributes as needed P CenterText B D CenterText PI 38A D Text 38A Const D Length S 2 0 Inz D TextOut S Like(Text) /Free Monitor; Length = (%Len(Text) - %Len(%Trimr(Text)))/2; TextOut = %Subst(TextOut:1:Length) + Text; On-error *All; TextOut = Text; Endmon; Return TextOut; /End-free Thanks to Kevin McLaughlin

Back

Identify the serial number or ID of various LPARS

Q:  Is there a command to identify the serial number or ID of the various LPARS
configured on an iSeries?
A: There is no command. This program should demonstrate the trick, though
H DFTACTGRP(*NO) ACTGRP(*CALLER) H OPTION(*SRCSTMT:*NODEBUGIO) DMatMAtr PR EXTPROC('_MATMATR1') D * VALUE D 2 CONST * Working variables for Materialize DAttribPtr s * inz(%addr(Attributes)) DMatOption s 2 inz(x'01E0') * Receiver variable for Materialize DAttributes DS 512 D BytPrv 10i 0 D BytAvl 10i 0 D NumParts 3u 0 D CurPart 3u 0 D PriPart 3u 0 D Reserved 5 D LogSerial 10 D Reserved2 5 D PartShrPrcAtr 1 D MinPrc 5u 0 D MaxPrc 5u 0 D CurPrc 5u 0 D Reserved3 2 D CfgMinMem 10u 0 D CfgMaxMem 10u 0 D CurAvlMem 10u 0 D MinPctInt 3u 0 D MaxPctInt 3u 0 D CurPctInt 3u 0 D Reserved4 1 D ConnAtr 2 D OptAtr 2 D MinPrcCap 10u 0 D MaxPrcCap 10u 0 D CurPrcCap 10u 0 D CurAvlPrcShr 10u 0 D NumPrcShr 5u 0 D Reserved5 2 * Set Bytes Provided to size of Receiver Variable (Attributes) C eval BytPrv = %size(Attributes) * Use MATMATR MI instruction C callp MatMAtr(AttribPtr: MatOption) * Determine if information returned C if BytAvl >= 56 * display configured active partitions C NumParts dsply * display current partition C CurPart dsply * display current interactive percentage C CurPctInt dsply C else C 'Error ' dsply C endif * Shut down, C eval *inlr = '1' C return Thanks to Mlpolutta
Back

Display the amount of temporary storage a job is using

Here is the program I use to display the amount of temporary storage a job is using.

The whole utility consists of a never-ending job that takes a look at subsystem QBATCH
every 5 minis or so and then sends messages to a message queue and/or to a list of users
if a job is using more that 2GB of storage....


    100 /* ************************************************************** */
    200 /* PROGRAM DESCRIPTION :                                        */
    300 /*                                        */
    400 /* RETRIVE A JOBS TEMP STORAGE USE.                               */
    500 /* THIS PROGRAM IS CALLED BY MONTMPSTG2                           */
    600 /*                                        */
    700 /* SPECIAL COMPILE OPTIONS:                                       */
    800 /*                                        */
    900 /*           WRITTEN BY: KEN GRAAP 03/11/99                       */
   1000 /*           UPDATED BY:           03/19/99 RMV SAE COMMAND       */
   1100 /*                                        */
   1200 /* ************************************************************** */
   1300              PGM        PARM(&JOB &USER &NUMBER)
   1400 /* ************************************************************** */
   1500 /*                                        */
   1600 /* DECLARE PROGRAM VARIABLES                                      */
   1700 /*                                        */
   1800 /* ************************************************************** */
   1900              DCL        &ERRORSW *LGL                     /* Std err */
   2000              DCL        &MSGID *CHAR LEN(7)               /* Std err */
   2100              DCL        &MSGDTA *CHAR LEN(100)            /* Std err */
   2200              DCL        &MSGF *CHAR LEN(10)               /* Std err */
   2300              DCL        &MSGFLIB *CHAR LEN(10)            /* Std err */
   2400              DCL        VAR(&JOBN) TYPE(*CHAR) LEN(26)
   2500              DCL        VAR(&JOB) TYPE(*CHAR) LEN(10)
   2600              DCL        VAR(&USER) TYPE(*CHAR) LEN(10)
   2700              DCL        VAR(&NUMBER) TYPE(*CHAR) LEN(6)
   2800              DCL        VAR(&TMPSTG) TYPE(*CHAR) LEN(4)
   2900              DCL        VAR(&TMPSTGDEC) TYPE(*DEC) LEN(8 0)
   3000              DCL        VAR(&TMPSTGMSG) TYPE(*CHAR) LEN(8)
   3100              DCL        VAR(&RECEIVER) TYPE(*CHAR) LEN(124)
   3200              DCL        VAR(&LENGTH) TYPE(*CHAR) LEN(4)
   3300              DCL        VAR(&ERRLENGTH) TYPE(*CHAR) LEN(4)
   3400 /* ************************************************************** */
   3500 /*                                        */
   3600 /* GLOBAL MESSAGE MONITOR                                        */
   3700 /*                                        */
   3800 /* ************************************************************** */
   3900              MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(STDERR1))
   4000 /* ************************************************************** */
   4100 /*                                        */
   4200 /* DISPLAY THE CURRENT AMOUNT OF TEMP STORAGE USED BY A JOB       */
   4300 /* IF MORE THAN 2GB SEND A MSG VIA THE SHOUT COMMAND              */
   4400 /*                                        */
   4500 /* ************************************************************** */
   4600
   4700              CHGVAR     VAR(&JOBN) VALUE(&JOB *CAT &USER *CAT +
   4800                           &NUMBER)
   4900              CHGVAR     VAR(%BIN(&LENGTH)) VALUE(124)
   5000              CHGVAR     VAR(%BIN(&ERRLENGTH)) VALUE(0)
   5100              CHGVAR     VAR(%BIN(&TMPSTG)) VALUE(4)
   5200              CALL       PGM(QUSRJOBI) PARM(&RECEIVER &LENGTH +
   5300                           JOBI0150 &JOBN '               ' &ERRLENGTH)
   5400              CHGVAR     VAR(&TMPSTG) VALUE(%SST(&RECEIVER 109 4))
   5500              CHGVAR     VAR(&TMPSTGDEC) VALUE(%BIN(&TMPSTG 1 4))
   5600              IF         COND(&TMPSTGDEC *GT 1999999) THEN(DO)
   5700              SHOUT      USERS(KEG RSJ CAS JAE JAEA) MSG('Job' *BCAT +
   5800                           &NUMBER *TCAT '/' *TCAT &USER *TCAT '/' +
   5900                           *TCAT &JOB *BCAT 'is using more than 2GB +
   6000                           of temporary storage. Please monitor it +
   6100                           and total aux storage usage closely.')
   6200              SNDPGMMSG  MSG('Job' *BCAT &NUMBER *TCAT '/' *TCAT +
   6300                           &USER *TCAT '/' *TCAT &JOB *BCAT 'is +
   6400                           using more than 2GB of temporary storage. +
   6500                           Please monitor it and total aux storage +
   6600                           usage closely.') TOMSGQ(QGPL/DSPTMPSTG)
   6700              ENDDO
   6800              CHGVAR     VAR(&TMPSTGMSG) VALUE(&TMPSTGDEC)
   6900              SNDPGMMSG  MSG('Job' *BCAT &NUMBER *TCAT '/' *TCAT +
   7000                           &USER *TCAT '/' *TCAT &JOB *BCAT 'is +
   7100                           using' *BCAT &TMPSTGMSG *BCAT 'of +
   7200                           temporary storage') TOMSGQ(QGPL/DSPTMPSTG)
   7300
   7400 /* ************************************************************** */
   7500 /*                                        */
   7600 /* NORMAL END OF PROGRAM                                        */
   7700 /*                                        */
   7800 /* ************************************************************** */
   7900  END:        RETURN
   8000 /* ************************************************************** */
   8100 /*                                        */
   8200 /* STANDARD ERROR PROCESSING                                      */
   8300 /*                                        */
   8400 /* ************************************************************** */
   8500  STDERR1:               /* Standard error handling routine */
   8600              IF         &ERRORSW SNDPGMMSG MSGID(CPF9999) +
   8700                           MSGF(QCPFMSG) MSGTYPE(*ESCAPE) /* Func chk */
   8800              CHGVAR     &ERRORSW '1' /* Set to fail ir error occurs */
   8900  STDERR2:    RCVMSG     MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +
   9000                           MSGF(&MSGF) MSGFLIB(&MSGFLIB)
   9100              IF         (&MSGID *EQ '       ') GOTO STDERR3
   9200              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
   9300                           MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
   9400              GOTO       STDERR2 /* Loop back for addl diagnostics */
   9500  STDERR3:    RCVMSG     MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
   9600                           MSGF(&MSGF) MSGFLIB(&MSGFLIB)
   9700              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
   9800                           MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
   9900              ENDPGM

Thanks to Ken Graap
Back

Checking lots of Queries for a field

I had the same need.  With the DMPSYSOBJ hint, I threw this together.
So far, it seems to meet my needs.


/*********************************************************************/
/* UTE015C                                        */
/*  Call this pgm w/ a parm of lib and string.                       */
/*  A report will be printed showing all queries containing the      */
/*  string.                                        */
/* Note:                                        */
/*  The string cannot contain any blanks!                            */
/*********************************************************************/
             PGM        PARM(&LIB &STRNG)
             DCLF       *LIBL/QADSPOBJ
             DCL        &LIB   *CHAR 10
             DCL        &STRNG *CHAR 20

             CHKOBJ     QTEMP/OBJDMP *FILE
             MONMSG     MSGID(CPF9801) EXEC( +
             CRTPF      QTEMP/OBJDMP RCDLEN(132))
             CHGPF      FILE(QTEMP/OBJDMP) SIZE(*NOMAX)

             CPYSPLF    QPSRVDMP QTEMP/OBJDMP MBROPT(*ADD)
             MONMSG     MSGID(CPF3309) EXEC(DO)
             GOTO       ITSOK
             ENDDO

             SNDMSG     MSG('This utility cannot be used when +
                          QPSRVDMP spool files exists') +
                          TOUSR(*REQUESTER)
             GOTO       THATSALL

 ITSOK:      DSPOBJD    &LIB/*ALL *QRYDFN OUTPUT(*OUTFILE) +
                                      OUTFILE(QTEMP/QRYS)
             OVRDBF     FILE(QADSPOBJ) TOFILE(QTEMP/QRYS)

 READIT:     RCVF       RCDFMT(QLIDOBJD) WAIT(*YES)

             MONMSG     MSGID(CPF0864) EXEC(GOTO CMDLBL(SCANIT))

             DMPSYSOBJ OBJ(&ODOBNM) CONTEXT(&LIB) OBJTYPE(*QRYDFN)

             CPYSPLF    QPSRVDMP TOFILE(QTEMP/OBJDMP) MBROPT(*ADD)
             DLTSPLF    QPSRVDMP

             GOTO       READIT

 SCANIT:     CALL UTE015C2 &STRNG

 THATSALL:   RCLRSC
             CLRPFM QTEMP/OBJDMP
             ENDPGM

/*********************************************************************/
/* UTE015C2                                        */
/*  Called from UTE015C                                        */
/* Before compiling this pgm,                                        */
/*  CRTPF FILE(*libl/OBJDMP) RCDLEN(132)                             */
/*  After compiling, DLTF *libl/OBJDMP                               */
/*********************************************************************/
             PGM        &STRNG
             DCLF       OBJDMP
             DCL        &STRNG   *CHAR 20
             DCL        &QRY     *CHAR 10
             DCL        &OBJDMP  *CHAR 132
             DCL        &PRTD    *CHAR 1
             DCL        &CURDAT  *CHAR 6
/* QCLSCAN VARS */
             DCL        &STRLEN  *DEC  LEN(3 0) VALUE(132)
             DCL        &STRPOS  *DEC  LEN(3 0) VALUE(1)
             DCL        &PATLEN  *DEC  LEN(3 0)
             DCL        &TRANS   *CHAR LEN(1)
             DCL        &TRIM    *CHAR LEN(1)
             DCL        &WILD    *CHAR LEN(1)
             DCL        &RESULT  *DEC  LEN(3 0) VALUE(1)

             CHGVAR     &PATLEN 1
             CALL       QCLSCAN PARM(&STRNG &STRLEN &STRPOS +
                          ' ' &PATLEN &TRANS &TRIM &WILD &RESULT)
             CHGVAR     &PATLEN &RESULT

             RTVJOBA    DATE(&CURDAT)
             LPRINT     DATA('UTE015C - Queries contaning string ' +
                          *cat &STRNG *CAT '     ' *CAT &CURDAT)
 READIT:     RCVF       RCDFMT(OBJDMP) WAIT(*YES)
             MONMSG     MSGID(CPF0864) EXEC(GOTO CMDLBL(THATSALL))

             IF         (%SST(&OBJDMP 1 4) = 'OBJ-') THEN(DO)
             CHGVAR     &QRY (%SST(&OBJDMP 6 10))
             CHGVAR     &PRTD '0'
             GOTO       READIT
             ENDDO

             IF         (&PRTD = '1') THEN(GOTO READIT)

             CALL       QCLSCAN PARM(&OBJDMP &STRLEN &STRPOS +
                          &STRNG &PATLEN &TRANS &TRIM &WILD &RESULT)
             IF         (&RESULT > 0) THEN(DO)
             LPRINT     &QRY
             CHGVAR     &PRTD '1'
             ENDDO

             GOTO READIT

 THATSALL:   RCLRSC
             ENDPGM

Thanks to Ron Hudson
Back

List ILE Builtin Functions

Here's a REXX program that lists ILE builtin functions.
Run it with STRREXPRC.  It reveals interesting things.


OS/400 V5R1
	Data = ''
	Get = Copies('00'x, 512)
	Obj = 'QWXHTSPC  QSYS      '
	"CALL QUSRUSAT (&Get X'00000200' SPCA0100 &Obj X'00000000')"
	Do X = 1 By 512 For C2D(Substr(Get,9,4))/512
	   "CALL QUSRTVUS (&Obj X'"D2X(X,8)"' X'00000200' &Get)"
	   Data = Insert(Get, Data, X-1, 512); End X
	"OVRPRTF STDOUT QSYSPRT"
	Do X = 173 By 20 While X < Int(5)+1
	   Line = Left(Substr(Data, Int(5)+Int(X)+1, Int(X+4)), 23)
	   If Int(X+12) = 0 Then Do
	      Line = '             ' Line
	      Do Y = Int(9)+Int(X+16)+1 By 4 For Int(X+20)/4
	         Line = Line Format(Int(Y), 5); End Y
	      X = X + 4; End
	   Else Line = Format(Int(X+12), 5) Format(Int(X+16), 5) ' ' Line
	   Say Line; End
	Return
	INT: Return C2D(Substr(Data, Arg(1), 4), 4)

Thanks to Gene Gaunt

OS/400 V5R2
/********************************************************************/
/*  PROGRAM  - PRTBUILTIN                                           */
/*  FUNCTION - print the ILE built-in functions, V5R2-specific      */
/*  LANGUAGE - REXX                                                 */
/*  AUTHOR   - Gene Gaunt                                           */
/********************************************************************/
"crtsavf file(qtemp/stdin)"
"savobj  obj(qwxcrtmd) ",
        "lib(qsys) ",
        "objtype(*pgm) ",
        "dev(*savf) ",
        "savf(qtemp/stdin) ",
        "updhst(*no) ",
        "dtacpr(*no)"
"ovrdbf  file(stdin) ",
        "tofile(qtemp/stdin)"
"ovrprtf file(stdout) ",
        "tofile(qsysprt) ",
        "splfname(prtbuiltin)"
data = ''
do forever
   parse linein record
   if record == '' then leave
   data = data || left( record, 512 )
end
walk = c2d( substr( data, X(  75 ),        3 ))
walk = c2d( substr( data, X(  1D ) + walk, 3 ))
walk = c2d( substr( data, X(  75 ) + walk, 3 ))
walk = c2d( substr( data, X(  45 ) + walk, 3 ))
walk = c2d( substr( data, X( 665 ) + walk, 3 )) + X( 0 )
name = walk + x2d( 2190 )
code = walk + x2d( 37B0 )
do while walk < name
   AA = c2d( substr( data, walk,      4 ))
   BB = c2d( substr( data, walk +  4, 2 ))
   CC = c2d( substr( data, walk +  6, 2 ))
   DD = c2d( substr( data, walk +  8, 2 ))
   EE = c2d( substr( data, walk + 10, 2 ))
   if BB == 0 then leave
   show = left( substr( data, name + AA, BB ), 20 )
   do DD while EE == 0
      show = show ||,
             right( c2d( substr( data, code + CC * 4, 4 )), 6 )
      CC = CC + 1
   end
   say show
   walk = walk + 12
end
return
X: return x2d( 4001 ) + x2d( arg( 1 ))

Thanks to Gene Gaunt and Dave McKenzie

OS/400 V5R3
/********************************************************************/
/*  PROGRAM  - PRTBUILTIN                                           */
/*  FUNCTION - print the ILE built-in functions, V5R3-specific      */
/*  LANGUAGE - REXX                                                 */
/*  AUTHOR   - Gene Gaunt                                           */
/********************************************************************/
"crtsavf file(qtemp/stdin)"
"savobj  obj(qwxcrtmd) ",
        "lib(qsys) ",
        "objtype(*pgm) ",
        "dev(*savf) ",
        "savf(qtemp/stdin) ",
        "updhst(*no) ",
        "dtacpr(*no)"
"ovrdbf  file(stdin) ",
        "tofile(qtemp/stdin)"
"ovrprtf file(stdout) ",
        "tofile(qsysprt) ",
        "splfname(prtbuiltin)"
data = ''
do forever
   parse linein record
   if record == '' then leave
   data = data || left( record, 512 )
end
walk = c2d( substr( data, X(  75 ),        3 ))
walk = c2d( substr( data, X(  1D ) + walk, 3 ))
walk = c2d( substr( data, X(  75 ) + walk, 3 ))
walk = c2d( substr( data, X(  45 ) + walk, 3 ))
walk = c2d( substr( data, X( 665 ) + walk, 3 )) + X( 0 )
name = walk + x2d( 22A0 )
code = walk + x2d( 3980 )
do while walk < name
   AA = c2d( substr( data, walk,      4 ))
   BB = c2d( substr( data, walk +  4, 2 ))
   CC = c2d( substr( data, walk +  6, 2 ))
   DD = c2d( substr( data, walk +  8, 2 ))
   EE = c2d( substr( data, walk + 10, 2 ))
   if BB == 0 then leave
   show = left( substr( data, name + AA, BB ), 20 )
   do DD while EE == 0
      show = show ||,
             right( c2d( substr( data, code + CC * 4, 4 )), 6 )
      CC = CC + 1
   end
   say show
   walk = walk + 12
end
return
X: return x2d( 5001 ) + x2d( arg( 1 ))

Thanks to Gene Gaunt
Back

Play with Qsort()

Here's a test program I wrote last year to play with qsort(). Don't vouch
for the quality or style. It loads an array with 10,000 values and sorts it
100 times. I wouldn't be surprised if there weren't some ways to improve it.

The key to the use of qsort() and the C library binary search is the comparison
function passed in as a function pointer. This is what makes the function generic.
Qsort() calls the comparison function(procedure) and acts on the return value.
I may have set up my bench mark incorrectly, but I found quick sort over this data
isn't significantly faster than sorta (a Shell sort.) The C library binary search is
so much quicker than lookup (a linear search) that it's frightening.


     H OPTION( *SrcStmt: *NoDebugIO)
     Fhftrap    if   e             disk
     Dsortit           pr                  extproc('qsort')
     Darrbase                          *   value
     Delements                       10u 0 value
     Dsize                           10u 0 value
     Dcompfunc                         *   procptr value
     D
     Dcompfunc         pr             9b 0
     Dlookfor                          *   value
     Darrelt                           *   value
     Darray            s              7    dim(10000)
     Dstoreroom        s                   like(array) dim(10000)
     Dx                s              5u 0
     Darrsize          s             10u 0
     Dnumelems         s                   like(arrsize)
     Dfnptr            s               *   procptr
     Darrptr           s               *
     D
     C                   eval      arrsize = %size(array)
     C                   eval      numelems = %elem(array)
     C                   eval      fnptr = %paddr('COMPFUNC')
     C                   eval      arrptr = %addr(array)
     C*  Load up the array of test stuff
     C                   do        10000         x
     C                   read      rtrn                                   99
     C                   eval      storeroom(x) = trsr
     C                   enddo
     C* Sort it 100 times
     C                   do        100           x
     C                   movea     storeroom     array
     C                   callp     sortit(arrptr : numelems     :
     C                             arrsize       : fnptr             )
     C                   enddo
     C                   eval      *inlr = *on
     P*####################################################################
     Pcompfunc         b
     D                 pi             9b 0
     Dlookfor                          *   value
     Darreltptr                        *   value
     Dkey              s              7    based(lookfor)
     Darrelt           s              7    based(arreltptr)
     C                   select
     C                   when      key < arrelt
     C                   return    -1
     C                   when      key > arrelt
     C                   return    1
     C                   when      key = arrelt
     C                   return    0
     C                   endsl
     Pcompfunc         e

Thanks to Joel Fritz
Back

iSeries (AS/400) Front Panel Keys Configuration

  The IPL types and modes are:

  A M       Performs a Manual IPL from the A side of the disk.  This mode may be
              used when applying or removing Licensed Internal Code (LIC) PTFs.
              It can also be used to power off the system.

              Use this type and mode only under the direction of your support
              representative.

  A N       Performs a Normal IPL from the A side of the disk.

              This mode should only be used when B N does not work and you are
              told to do so by your support representative.

  B M       Performs a Manual IPL from the B side of the disk.  This mode should
              only be used when an attended IPL must be performed or you need to
              power off the system.  This type of IPL is used when you need to change
              the system date and time permanently.

  B N       Performs a normal IPL from the B side of the disk.  This is the type
              and mode used most of the time.  It is also the mode the system must
              be in if you want to do an unattended IPL.

  C M       Allows service representatives to perform a special IPL.  This mode
              is for use only by service representatives.  Never IPL in this type
              and mode.

  C N       Allows service representatives to perform a special IPL.  This mode
              is for use only by service representatives.  Never IPL in this type
              and mode.

  D M       Performs a manual IPL from either CD-ROM or tape.  This mode is used
              to install Licensed Internal Code and the OS/400 operating system in
              attended mode.  This is the most often used IPL type and mode for
              installation.

  D N       Performs a normal IPL from either CD-ROM or tape.  This mode is used
              to install Licensed Internal Code and the OS/400 operating system in
              unattended mode.

  Manual    When the mode is set to Manual (M), the system allows you to do all
               manual IPLs, such as an operator-attended IPL from disk, CD-ROM or tape.
               Manual mode also allows you to do some manual control functions, such
               as selecting an IPL type and mode or displaying the kind of IPL that
               the system is set to run. However, in manual mode, you cannot do a
               remote IPL, an IPL by date and time, or an IPL after a power failure.

               Note:  You should set the mode to Manual only when it is necessary.
               This ensures that no one accidentally presses the Power pushbutton
               and causes the system to stop.


  Normal    The Normal mode allows you to turn the power on and then automatically
               start the system in any of the following ways:

            .   IPL remotely

            .   IPL by date and time

            .   IPL after a power failure


            Note:  Your system should be in Normal mode most of the time.

Thanks to Seref  ERTEKIN
Back

Loading PTF Cover Letters from CD-Rom

If necessity is the mother of invention, laziness is the father...

I recently ordered 2 (just 2) PTFs from IBM and I received a cd-rom with
about 60 (the wonders of supercedes, co-reqs, pre-reqs, etc). Not wanting to
load the cover pages by hand for 60 PTFs I've written a quick CL program that
does this for me. Short, simple and crude, I release it to the public domain.


	PGM  PARM(&pPrd &pDev)

	dcl &pPrd *char 7 /*Product 5769SS1, 5769ST1, etc */
	dcl &pDev *char 10 /* Device OPT01, OPT02, etc. */
	dcl &wPath *dec 4
	dcl &wPathC *char 4

	/* Load PTF Cover Sheets */
	loop:
	chgvar &wPath (&wPath + 1)
	LODPTF LICPGM(&pPrd) DEV(&pDev) PATHID(&wPath) COVER(*ONLY)
	monmsg cpf355c exec(goto endloop) /* Bail on 'Path Not Found' error */
	goto loop

	endloop:
	rcvmsg /*Trash cpf355c from stack */

	/* Send completion message */
	chgvar &wPath (&wPath - 1)
	chgvar &wPathC (&wPath)
	sndpgmmsg msg(&wPathC || ' PTF Cover Sheets loaded.') MSGTYPE(*COMP)

	endpgm

Thanks to Walden H. Leverich
Back

Where %Eof, %Equal, and %Found may be used

This is from a V4R2 article in News400, but I still refer to it to make sure I'm using the right BIF.

	Chain 	- %Found
	Check 	- %Found
	CheckR 	- %Found
	Delete 	- %Found
	LookUp 	- %Equal, %Found
	Read 	- %Eof
	ReadC 	- %Eof
	ReadE 	- %Eof
	ReadP 	- %Eof
	ReadPE 	- %Eof
	Scan 	- %Found
	SetGT 	- %Found
	SetLL 	- %Equal, %Found
	Write (subfile only) - %Eof

Thanks to Jade Richtsmeier & News400
Back

How many objects in a system?

Q:	Does anyone know of a quick way to get the total number of objects in a system?

A:	As Leif points out, this is complicated by how you define "objects", with a
prime example being whether multi-member files (eg source files) count as one
object or one per member (plus one for the object itself).

But if all you want is an approximation, and you know how you want to handle
member counts, then I do have a partial solution for you.  I once spent some
time investigating how to get a fast object count for a single library, and came
up with the solution below.  It counts objects from a system perspective, so I
also have it back out the member count.  In my testing this made it match the
expected object count for most libraries, and was within 1% for QSYS.

The following program demonstrates the technique for a single library.  You'd
have to roll your own loop to accumulate the sum for all libraries after using
an API to list the library names.  I'll leave that as an excercise for the
reader.


     H Option( *SrcStmt: *NoDebugIO )
     H DftActGrp( *No )
     H ActGrp( *Caller )

      * Program to demonstrate how to get the approximate
      * number of objects in a specified library.
     D RtvObjCnt       PR            10I 0
     D  LibName                      10A   Const

     D Input           S             10A
     D Library         S             10A
     D Count           S             10I 0

     D BegTime         S               Z
     D EndTime         S               Z
     D Duration        S             15P 0
     D Seconds         S             12P 3
     D Msg             S             52A

     D Lower           C                   'abcdefghijklm+
     D                                      nopqrstuvwxyz'
     D Upper           C                   'ABCDEFGHIJKLM+
     D                                      NOPQRSTUVWXYZ'

      * Get library name; quit when no name is keyed
     C                   Eval      Input = *Blanks
     C     'Library?'    Dsply                   Input
     C                   If        Input = *Blanks
     C                   Eval      *InLR = *On
     C                   Return
     C                   Endif

      * Display object count and time required to retrieve it
     C     Lower:Upper   Xlate     Input         Library
     C                   Time                    BegTime
     C                   Eval      Count = RtvObjCnt( Library )
     C                   Time                    EndTime
     C     EndTime       Subdur    BegTime       Duration:*MS
     C                   Eval      Seconds = Duration / 1000000
     C                   Eval      Msg = %trim( %editc( Count: 'N' ) ) +
     C                                   ' Objects; ' +
     C                                   %trim( %editc( Seconds: 'N' ) ) +
     C                                   ' Seconds'
     C     Msg           Dsply

      * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     P RtvObjCnt       B

     D RtvObjCnt       PI            10I 0
     D  LibName                      10A   Const

     D                 DS
     D LibSysPtrA              1     16A
     D  LibSysPtr              1     16*   ProcPtr Inz( *Null )

     D ObjCnt          S             10I 0
     D MbrCnt          S             10I 0

     D RslvSp2         PR                  Extproc( '_RSLVSP2' )
     D  Object                         *   ProcPtr
     D  ObjID_Auth                   34A   Const

     D MatCtx          PR                  Extproc( 'QusMaterializeContext' )
     D  RcvVar                             Like( RcvVar )  Options( *VarSize )
     D  CtxSysPtr                    16A   Value
     D  Options                            Like( MatCtxOpt )  Const

     D MatCtxOpt       DS
     D  MatInfo                       1A   Inz( x'03' )
     D  MatSelect                     1A   Inz( x'00' )
     D  MatNamLen                     5I 0 Inz( 0 )
     D  MatType                       1A   Inz( x'00' )
     D  MatSubType                    1A   Inz( x'00' )
     D  MatName                      30A
     D  MatDTS                        8A   Inz( x'0000000000000000' )

     D RcvVar          DS
     D  CtxBytPrv                    10I 0 Inz( %size( RcvVar ) )
     D  CtxBytAvl                    10I 0 Inz( 0 )
     D  CtxID                        32A
     D   CtxType                      1A   Overlay( CtxID : 1 )
     D   CtxSubType                   1A   Overlay( CtxID : 2 )
     D   CtxName                     30A   Overlay( CtxID : 3 )
     D  CtxOptions                    4A
     D   CtxOpt1                      1A   Overlay( CtxOptions: 1 )
     D   CtxOpt2                      1A   Overlay( CtxOptions: 2 )
     D   CtxOpt3                      1A   Overlay( CtxOptions: 3 )
     D   CtxOpt4                      1A   Overlay( CtxOptions: 4 )
     D  CtxRecover                    4A
     D   CtxRecover1                  1A   Overlay( CtxRecover: 1 )
     D  CtxSize                      10I 0
     D  CtxInitVal                    1A
     D  CtxClass                      4A
     D   CtxClass1                    1A   Overlay( CtxClass: 1 )
     D                                7A
     D                               16A
     D CtxAccGrp                       *   ProcPtr
     D* (Array of entries would start here if RcvVar was bigger)

      * First resolve library name to system pointer; if the library
      * is not found *PSSR will get control and return an object
      * count of -1
     C                   Callp     RslvSp2( LibSysPtr:
     C                                      x'0401' +
     C                                      LibName +
     C                                      '                    ' +
     C                                      x'0000' )

      * Materialize Context with no selection criteria or room for any
      * context entries to be returned.  The bytes available in the
      * receiver variable will give us an estimate of the total number
      * of objects in the library if we subtract the size of the header
      * then divide by the entry length for one object.  This object
      * count is a low-overhead approximation and includes one entry for
      * each member in each database file.
     C                   Eval      MatSelect = x'00'
     C                   Callp     MatCtx( RcvVar:
     C                                     LibSysPtrA:
     C                                     MatCtxOpt )

      * If nothing got returned (not even the header data), then a
      * problem occured and we'll return -1 as the count rather than
      * zero which is an otherwise valid object count.
     C                   If        CtxBytAvl <= *Zero
     C                   Return    -1
     C                   Endif

      * Convert the bytes available into an object count
     C                   Eval      ObjCnt = (CtxBytAvl - 96 ) / 48

      * Repeat the operation but select only database file members
     C                   Eval      MatSelect  = x'02'
     C                   Eval      MatType    = x'0D'
     C                   Eval      MatSubtype = x'50'
     C                   Callp     MatCtx( RcvVar:
     C                                     LibSysPtrA:
     C                                     MatCtxOpt )

      * Convert the bytes available into a member count and adjust
      * our previous object count to exclude database members
     C                   Eval      MbrCnt = (CtxBytAvl - 96 ) / 48
     C                   Eval      ObjCnt = ObjCnt - MbrCnt

     C                   Return    ObjCnt

     C     *PSSR         Begsr
     C                   Return    -1
     C                   Endsr

     P RtvObjCnt       E

Thanks to Douglas Handy
Back

Page #1     Page #3

Back