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

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