iSeries & System i

#3 Tips & Tricks - Table of Contents #5

Convert lower to uppercase in a CL program
C runtime function bsearch & qsort
Prevent CA/400 from disconnecting when used remotely
Display Display Attributes
Debug: Stepping into Java from RPG
An example of a CHOICE-program
Convert the UNIX epoch to an RPG timestamp
QIPLSTS - IPL Status Indicator
Create an Excel file from AS/400 or ASP
CGI vs WDSC
Checking Your iSeries Batteries
Query object - retrieving spooled output details
Transfer users from v5.2 to v5.1
Julian Date vs. Lilian Date
Dynamically Increase an Array's Size
Change FTP port - iSeries
Date Handling in RPG IV
Zip files on IFS
Clearing an iSeries
Retrieve ASP percentage
Copy DB file to Excel format
Cleanup IFS
SNADS over TCP/IP
Quick intro to ILE
What is the HEX key for ??
Difference between CPF0000 and CPF9999
V5R4 - "patched" or "system state" programs


Convert lower to uppercase in a CL program

Q: Is there a way to convert lower to uppercase in a CL program, or do I need
to do an RPG thing?

A: Here you go..... /* variables for QDCXLATE */ DCL &TBLNAM *CHAR LEN(10) VALUE('QSYSTRNTBL') DCL &TBLLIB *CHAR LEN(10) VALUE('QSYS ') DCL &FLDLEN *DEC LEN(5 0) /* translate DATA "a-z" to uppercase "A-Z" */ CHGVAR VAR(&DATA) VALUE(&WHATEVER) CHGVAR VAR(&FLDLEN) VALUE(128) /* max size of DATA */ CALL PGM(QDCXLATE) PARM(&FLDLEN &DATA &TBLNAM &TBLLIB)
Thanks to Mark S. Waterbury
A: There is an API to provide upper and lower casing and which is sensitive to your job CCSID. And example of using it from CL is: PGM DCL VAR(&LOWER) TYPE(*CHAR) LEN(50) + VALUE('aBcâêÅÏ') DCL VAR(&UPPER) TYPE(*CHAR) LEN(50) DCL VAR(&REQUEST) TYPE(*CHAR) LEN(22) + VALUE(X'00000001000000000000000000000000000+ 000000000') /* Uppercase based on job + default CCSID */ DCL VAR(&LENGTH) TYPE(*INT) LEN(4) VALUE(50) DCL VAR(&ERRCODE) TYPE(*INT) LEN(4) VALUE(0) CALL PGM(QLGCNVCS) PARM(&REQUEST &LOWER &UPPER + &LENGTH &ERRCODE) ENDPGM When the program finishes &upper is 'ABCÂÊÅÏ '. There is also an ILE flavor of the API (QlgConvertCase). Thanks to Bruce Vining
A: It's pretty simple. To change it to convert the other direction (lower to upper) change the 3rd part of the control block so that it's all zeroes. For example, right now my sample code lists this: CHGVAR VAR(&CTLBLK) VALUE(X'00000001+ 00000025+ 00000001+ 00000000000000000000') To make it convert the other direction, do this instead: CHGVAR VAR(&CTLBLK) VALUE(X'00000001+ 00000025+ 00000000+ 00000000000000000000') One nice thing about this API is that it's able to use the job's CCSID. Unlike techniques that rely on QDCXLATE or RPG's XLATE or %xlate() capabilities, it'll work properly no matter what language your system is configured for.... without any changes... It's the best approach I've found. Thanks to Scott Klement
Back

C runtime function - bsearch & qsort

Q: I've been fighting with this same issue. Does anyone have an RPG Prototype
for the bsearch() c function. I think I can wrap that in a service program.

A: Really? I pretty much always load my arrays in order. (In other words, I first load element 1, then element 2, etc..) I don't usually have to search the array to find the next unused one, since all I need is a counter. The other thing... MODS are REALLY AWKWARD to use with qsort() or bsearch() since you can't really use them as parameters. You have to re-define the data structure each time you want to use them. That just drives me nuts. I really think a qualified DS array is much more elegant. The following sample code shows how LIKEDS makes it soooo much nicer than the alternatives:
H DFTACTGRP(*NO) BNDDIR('QC2LE') D qsort PR extproc('qsort') D base * value D num 10U 0 value D width 10U 0 value D compare * procptr value D bsearch PR * extproc('bsearch') D key * value D base * value D num 10U 0 value D size 10U 0 value D compare * procptr value D myTemplate ds qualified D based(Template) D LastName 20A D FirstName 20A D ext 10I 0 D users ds likeds(myTemplate) D dim(100) D p_match s * D match ds likeds(myTemplate) D based(p_match) D key ds likeds(myTemplate) D CompByLast pr 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) D CompByFirst pr 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) D CompByExt pr 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) D CompCase PR 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) D x s 10I 0 D numUsers s 10I 0 D msg s 52A /free // ------------------------------------------- // create some sample data // ------------------------------------------- x = 1; users(x).LastName = 'Klement'; users(x).FirstName = 'Scott'; users(x).ext = 292; x = x + 1; users(x).LastName = 'Lewis'; users(x).FirstName = 'Doug'; users(x).ext = 280; x = x + 1; users(x).LastName = 'Bizub'; users(x).FirstName = 'James'; users(x).ext = 291; x = x + 1; users(x).LastName = 'Michuda'; users(x).FirstName = 'Michael'; users(x).ext = 209; x = x + 1; users(x).LastName = 'Solano'; users(x).FirstName = 'Maria'; users(x).ext = 216; x = x + 1; users(x).LastName = 'Straw'; users(x).FirstName = 'Penny'; users(x).ext = 302; x = x + 1; users(x).LastName = 'Wiesner'; users(x).FirstName = 'Beatrice'; users(x).ext = 200; x = x + 1; users(x).LastName = 'Vogl'; users(x).FirstName = 'Jackie'; users(x).ext = 201; x = x + 1; users(x).LastName = 'Sotski'; users(x).FirstName = 'Daniel'; users(x).ext = 203; numUsers = x; // ------------------------------------------- // Sort array by Last name // ------------------------------------------- qsort( %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByLast) ); // ------------------------------------------- // Search for 'Klement' // then for 'Michuda' // ------------------------------------------- key.LastName = 'Klement'; p_match = bsearch( %addr(key) : %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByLast) ); if (p_match = *NULL); msg = %trimr(key.lastname) + ' not found!'; dsply msg; else; msg = %trimr(match.lastname) + ' is ext ' + %char(match.ext); dsply msg; endif; key.LastName = 'Michuda'; p_match = bsearch( %addr(key) : %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByLast) ); if (p_match = *NULL); msg = %trimr(key.lastname) + ' not found!'; dsply msg; else; msg = %trimr(match.lastname) + ' is ext ' + %char(match.ext); dsply msg; endif; // ------------------------------------------- // How about searching by complete name // (first & last) // ------------------------------------------- qsort( %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByFirst) ); key.FirstName = 'Scott'; key.LastName = 'Klement'; p_match = bsearch( %addr(key) : %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByFirst) ); if (p_match = *NULL); msg = %trimr(key.firstname) + ' ' + %trimr(key.lastname) + ' not found!'; dsply msg; else; msg = %trimr(match.firstname) + ' ' + %trimr(match.lastname) + ' is ext ' + %char(match.ext); dsply msg; endif; // ------------------------------------------- // How about searching by extension number // ------------------------------------------- qsort( %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByExt) ); key.ext = 291; p_match = bsearch( %addr(key) : %addr(users) : numUsers : %size(myTemplate) : %paddr(CompByExt) ); if (p_match = *NULL); msg = %char(key.ext) + ' not found!'; dsply msg; else; msg = %trimr(match.firstname) + ' ' + %trimr(match.lastname) + ' is ext ' + %char(match.ext); dsply msg; endif; // ------------------------------------------- // You can also do a case-insensitive sort // and search just by changing the // way the elements are compared // ------------------------------------------- qsort( %addr(users) : numUsers : %size(myTemplate) : %paddr(CompCase) ); key.LastName = 'stRaW'; p_match = bsearch( %addr(key) : %addr(users) : numUsers : %size(myTemplate) : %paddr(CompCase) ); if (p_match = *NULL); msg = %trimr(key.lastname) + ' not found!'; dsply msg; else; msg = %trimr(match.firstname) + ' ' + %trimr(match.lastname) + ' is ext ' + %char(match.ext); dsply msg; endif; *inlr = *on; /end-free *++++++++++++++++++++++++++++++++++++++++++++++++++++ * Compare Two Elements, using Last Name as the * only key. *++++++++++++++++++++++++++++++++++++++++++++++++++++ P CompByLast B D CompByLast PI 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) /free select; when (elem1.LastName < elem2.LastName); return -1; when (elem1.LastName > elem2.LastName); return 1; other; return 0; endsl; /end-free P E *++++++++++++++++++++++++++++++++++++++++++++++++++++ * Compare Two Elements, using a composite key * created from the first & last name *++++++++++++++++++++++++++++++++++++++++++++++++++++ P CompByFirst B D CompByFirst PI 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) /free select; when (elem1.FirstName < elem2.FirstName); return -1; when (elem1.FirstName > elem2.FirstName); return 1; when (elem1.LastName < elem2.LastName); return -1; when (elem1.LastName > elem2.LastName); return 1; other; return 0; endsl; /end-free P E *++++++++++++++++++++++++++++++++++++++++++++++++++++ * Compare Two Elements, using the telephone ext * as the key *++++++++++++++++++++++++++++++++++++++++++++++++++++ P CompByExt B D CompByExt PI 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) /free select; when (elem1.Ext < elem2.ext); return -1; when (elem1.Ext > elem2.ext); return 1; other; return 0; endsl; /end-free P E *++++++++++++++++++++++++++++++++++++++++++++++++++++ * Compare Two Elements, using the telephone ext * as the key *++++++++++++++++++++++++++++++++++++++++++++++++++++ P CompCase B D CompCase PI 10I 0 D elem1 likeds(myTemplate) D elem2 likeds(myTemplate) D upper c 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' D lower c 'abcdefghijklmnopqrstuvwxyz' D last1 s like(myTemplate.lastname) D last2 s like(myTemplate.lastname) /free last1 = %xlate(lower:upper: elem1.lastname); last2 = %xlate(lower:upper: elem2.lastname); select; when (last1 < last2); return -1; when (last1 > last2); return 1; other; return 0; endsl; /end-free P E Thanks to Scott Klement
Back

Prevent CA/400 disconnecting when used remotely

How to prevent iSeries Access Emulator from disconnecting when used remotely

Tech tip courtesy of Barsa Consulting, LLC and Dave Schnee

This tip follows an answer to a question I posed during the May, 2000 LISUG meeting.

My problem was that, when I used the 5250 green-screen emulator of iSeries Access
(F.K.A. Client Access) in the office (with a direct connection to the office LAN,
it was very reliable).  When I used it from home, with 2 firewalls, 2 ISPs and the
entire Internet between me and my iSeries machine, I had problems.

The problem was that, every time I stopped entering commands for any significant
interval (telephone call, scratch-my-head time, coffee, etc.) all my 5250 sessions
got disconnected.  I had pretty-much given-up on IBM's emulator and switched to
Mochasoft because that emulator has an option to use a TCP/IP “keepalive”.
The reason that it worked and IBM's did not was that, with many routers and paths
between me and my iSeries, whenever a “long” interval of no activity occurred, some
one of them would surmise that the connection had been abandoned.  The iSeries
responded by disconnecting and then canceling my interactive job.

No matter how hard I looked through the configuration options and help text for
iSeries Access, I found no solution.  So I asked.  Just recently, I got an answer
and IT WORKS!

The answer, courtesy of Jeffrey Stevens (IBM Rochester) and James Quigley (IBM
Raleigh) is that iSeries Access DOES have TCP/IP keepalive, but it's a SECRET!
It's not in the help text nor any manual nor does it have a GUI-based “switch”.
It does, however, work in response to a keyword in the workstation profile (that's
a Sysname.WS data file). In a “standard” installation, these will be in directory
C:\Program Files\IBM\Client Access\Emulator\Private.

You can edit these files with any standard text editor (Notepad, Wordpad, Textpad,
StarOffice, Lotus WordPro or even Microsoft WORD).  Just be sure to save them as
standard text and don't change the file extension.

The secret is to find (or create) a section named [Telnet5250] and add a line to it
which says KeepAlive=Y.  In my case, the section already existed, so I just added
the one line to it so the beginning of my Sysname.WS file looks like:

[Profile]
ID=WS
Version=5
[Telnet5250]
KeepAlive=Y
HostName=192.168.100.55
Security=Y
[Communication]
Link=telnet5250
. . . . (etc.)

That should be sufficient to keep from getting disconnected, but Jeffrey Stevens went
on to suggest yet another idea.  This one requires that you REALLY know some Windows
technology.  Don't try it if just the above idea solves your problem and don't try it
if you are not SURE of what you're doing.  Here it is anyway:

Set a Windows Keepalive timeout on your PC, so any firewalls or other boxes see
activity from your PC.  Navigate to the following registry entry (you may need to
create KeepAliveTime as a DWORD), you can set the value in milliseconds.
For example, 10 seconds would be set as 10000 decimal in the DWORD.

HKLM\System\CurrentControlSet\Services\TcpIp\Parameters\KeepAliveTime

This can be done using Microsoft's regedit or by using a registry “tweaking” tool
such as Xteq.

Enjoy!

Thanks to Dave Schnee
Back

Display Display Attributes

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

      * Display display attributes

      * Use SETATNPGM DSPDSPATR then use ATTN key to invoke this program.
      * The current Screen will have all display attributes replaced by
      * a @ character.  Move the cursor and press Enter to have the hex
      * value of that position displayed.  Use any Fx key to exit.

      * Copyright 2004 Douglas Handy.
      * Permission is granted to distribute freely; all other rights
      * are reserved.

      * Stand-alone variables used
     D BegRow          S             10I 0
     D BegCol          S             10I 0
     D Rows            S             10I 0
     D Cols            S             10I 0
     D R               S             10I 0
     D C               S             10I 0
     D Hex             S              2

     D CmdBuf          S             10I 0
     D InpHnd          S             10I 0
     D BytRead         S             10I 0

     D ScrImg          S           3564
     D ScrImgPtr       S               *   Inz( *Null )
     D ScrBytePtr      S               *   Inz( *Null )
     D ScrByte         S              1    Based( ScrBytePtr )

     D InpDtaPtr       S               *   Inz( *Null )
     D InpDta          DS          3564    Based( InpDtaPtr )
     D  InpCsrRow                     3U 0
     D  InpCsrCol                     3U 0
     D  InpAID                        1

      * Convert character string to hex string (eg ABC to C1C2C3)
     D CvtToHex        PR                  ExtProc( 'cvthc' )
     D  Hex                        2048    Options( *Varsize )
     D  Char                       1024    Options( *Varsize )
     D  LenSrc                       10I 0 Value

      * Copy a block of memory (operands should not overlap)
     D memcpy          PR              *   ExtProc( '__memcpy' )
     D  Target                         *   Value
     D  Source                         *   Value
     D  Length                       10U 0 Value

      * Standard API error code DS
     D ApiErrCode      DS
     D  ErrBytPrv                     9B 0 Inz( %size( ApiErrCode ) )
     D  ErrBytAvl                     9B 0 Inz( 0 )
     D  ErrMsgID                      7
     D  ErrResv                       1
     D  ErrMsgDta                    80

      * Retrieve Screen dimensions of current mode (not capability).
     D RtvScrDim       PR            10I 0 ExtProc( 'QsnRtvScrDim' )
     D  Rows                         10I 0
     D  Cols                         10I 0
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Clear buffer.
     D ClrBuf          PR            10I 0 ExtProc( 'QsnClrBuf' )
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Create command buffer.
     D CrtCmdBuf       PR            10I 0 ExtProc( 'QsnCrtCmdBuf' )
     D  InitSize                     10I 0 Const
     D  IncrAmt                      10I 0 Options( *Omit ) Const
     D  MaxSize                      10I 0 Options( *Omit ) Const
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Create input buffer.
     D CrtInpBuf       PR            10I 0 ExtProc( 'QsnCrtInpBuf' )
     D  InitSize                     10I 0 Const
     D  IncrAmt                      10I 0 Options( *Omit ) Const
     D  MaxSize                      10I 0 Options( *Omit ) Const
     D  InpBuf                       10I 0 Options( *Omit )
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Delete buffer.
     D DltBuf          PR            10I 0 ExtProc( 'QsnDltBuf' )
     D  BufHnd                       10I 0 Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Read Screen (without waiting for an AID key).
     D ReadScr         PR            10I 0 ExtProc( 'QsnReadScr' )
     D  NbrByt                       10I 0 Options( *Omit )
     D  InpBuf                       10I 0 Options( *Omit ) Const
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Retrieve pointer to data in input buffer.
     D RtvDta          PR              *   ExtProc( 'QsnRtvDta' )
     D  InpBuf                       10I 0 Const
     D  InpDtaPtr                      *   Options( *Omit )
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Read input fields.
     D ReadInp         PR            10I 0 ExtProc( 'QsnReadInp' )
     D  CCByte1                       1    Const
     D  CCByte2                       1    Const
     D  NbrFldByt                    10I 0 Options( *Omit )
     D  InpBuf                       10I 0 Options( *Omit ) Const
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Get cursor address (does not wait for AID key).
     D GetCsrAdr       PR            10I 0 ExtProc( 'QsnGetCsrAdr' )
     D  CsrRow                       10I 0 Options( *Omit )
     D  CsrCol                       10I 0 Options( *Omit )
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Set cursor address.
     D SetCsrAdr       PR            10I 0 ExtProc( 'QsnSetCsrAdr' )
     D  FldID                        10I 0 Options( *Omit ) Const
     D  CsrRow                       10I 0 Options( *Omit ) Const
     D  CsrCol                       10I 0 Options( *Omit ) Const
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

      * Write data.
     D WrtDta          PR            10I 0 ExtProc( 'QsnWrtDta' )
     D  Data                       3600    Const
     D  DataLen                      10I 0 Const
     D  FldID                        10I 0 Options( *Omit ) Const
     D  Row                          10I 0 Options( *Omit ) Const
     D  Col                          10I 0 Options( *Omit ) Const
     D  StrMonoAtr                    1    Options( *Omit ) Const
     D  EndMonoAtr                    1    Options( *Omit ) Const
     D  StrClrAtr                     1    Options( *Omit ) Const
     D  EndClrAtr                     1    Options( *Omit ) Const
     D  CmdBuf                       10I 0 Options( *Omit ) Const
     D  EnvHnd                       10I 0 Options( *Omit ) Const
     D  ErrorDS                            Options( *Omit ) Like( ApiErrCode )

     C/Free

       // Get display size and save current contents of Screen image
       RtvScrDim( Rows: Cols: *Omit: *Omit );
       GetCsrAdr( BegRow: BegCol: *Omit: *Omit );
       InpHnd     = CrtInpBuf( %size( ScrImg ): *Omit: *Omit: *Omit: *Omit );
       BytRead    = ReadScr( *Omit: InpHnd: *Omit: *Omit: *Omit );
       InpDtaPtr  = RtvDta( InpHnd: *Omit: *Omit );
       ScrImgPtr  = %addr( ScrImg );
       memcpy( ScrImgPtr : InpDtaPtr: BytRead );

       // Create command buffer with an output command to replace
       // each display attribute byte with a @ character, except
       // for the attribute at row/col 1,1 because overlaying it
       // effects at least some emulators
       CrtCmdBuf( 1024: 1024: 6192: CmdBuf: *Omit );
       ScrBytePtr = %addr( ScrImg );

       For R = 1 to Rows;
         For C = 1 to Cols;
           If ScrByte >= x'20' and ScrByte <= x'3F';
             If not ( R = 1 and C = 1 );
               WrtDta( '@': 1: 0: R: C: *Omit: *Omit: *Omit: *Omit:
                       CmdBuf: *Omit: *Omit );
             Endif;
           Endif;
           ScrBytePtr = ScrBytePtr + 1;
         Endfor;
       Endfor;

       // Output cmd buffer to display and wait for AID key
       SetCsrAdr( *Omit: BegRow: BegCol: CmdBuf: *Omit: *Omit );
       ReadInp( x'20': x'40': BytRead: InpHnd: CmdBuf: *Omit: *Omit );
       InpDtaPtr  = RtvDta( InpHnd: *Omit: *Omit );

       // Show hex contents of cursor position until Enter not pressed
       Dou InpAID <> x'F1';
         ClrBuf( CmdBuf: *Omit );
         ScrBytePtr = ScrImgPtr + ( ( InpCsrRow - 1 ) * Cols ) + InpCsrCol - 1;
         CvtToHex( Hex: ScrByte: 2 );
         WrtDta( Hex: 2: 0: Rows: Cols-1: x'22': *Omit: x'22': *Omit:
                 CmdBuf: *Omit: *Omit );
         SetCsrAdr( *Omit: InpCsrRow: InpCsrCol: CmdBuf: *Omit: *Omit );
         ReadInp( x'20': x'40': BytRead: InpHnd: CmdBuf: *Omit: *Omit );
         InpDtaPtr  = RtvDta( InpHnd: *Omit: *Omit );
       Enddo;

       // Delete DSM buffers and end program
       DltBuf( CmdBuf: *Omit );
       DltBuf( InpHnd: *Omit );
       *InLR = *On;
      /End-free

More QSN..... prototypes can be found here.

Thanks to Douglas Handy
Back

Debug: Stepping into Java from RPG

Q: I use STRDBG to debug an RPG program.  The RPG program is calling a
Java method (via JNI V5R1.)  When I attempt to step into the Java
method (F22) debugger does not proceed into the method but steps over
it.

The JAR file containing the java class had been run through CRTJVAPGM
with option 10.  The CLASS files were compiled with -g.

I'm guessing that the problem is that when I do a F22 it is trying to
step into to JNI layer, not my class.  So if I could figure out how to
bring up my class before doing the F22 I could set a breakpoint stop
at it.  Am I on the right track? or totally off base.

A: Unfortunately, there are some debugging limitations when using
RPG and Java this way.  Debugging of Java code isn't supported when the
JVM is running in the same process as the debugger.  You will have to
debug from another job.

You also have to do CRTJVAPGM on the classes you want to debug.  If you
don't do this, your Java breakpoints won't work the way you expect.
(You've already done this; I'm just putting this in for the record,
since it's an important step.)

You won't be able to step into the very first Java method.  You'll have
to wait until the JVM is started by RPG.  This doesn't happen until the
first Java method is called.  If you do want to debug the first method,
you'll have to wait until the time you run your program, or insert a
call into your RPG program to some dummy method just to get the JVM
started.

0. CRTJVAPGM 'yourclass.class' (you only need to do this once after you
   create the class)
1. From the RPG job:
   a. ===> DSPJOB
   b. Get the Name, User and Number-you will need this in the next step (*)
2. From the debugging job:
   a. ===> STRSRVJOB JOB(Number/User/Name)
   b. ===> STRDBG yourRpgPgm
   c. ===> Exit with F10.
3. From the RPG job, call your program.
4. Go back to the debugging job to step through your program.
5. From the debugging job:
   a. ===> ENDDBG
   b. ===> ENDSRVJOB JOB(whatever)

(*) Another, maybe easier, way to get the job info is to do WRKJOB
OPTION(*SPLF) in the RPG job, and do a 2 on one of the spoolfiles.  Then
use cut-and-paste on all three job fields at once from the spoolfile to
the prompted STRSRVJOB command.

Thanks to Barbara Morris
Back

An example of a CHOICE-program

Actually most any language could be used though it is a bit more
wordy in CL. It's nothing fancy and I just threw it together so
there may be some minor bugs (but it does display the choices :-))
but here is a sample command and choices program to display the
valid language ids on a system (I use this as an example because
this API will run on any reasonably current AS/400 and avoids
having to hardcode the choice text).

Command source

CMD PROMPT('Choices Command')
PARM KWD(CHOICE) TYPE(*CHAR) LEN(10) +
DFT('Default') CHOICE(*PGM) +
CHOICEPGM(*LIBL/CHOICES1) PROMPT('Choice +
	Parameter')

Create command

CRTCMD CMD(CHOICES) PGM(ABC)

And source for CHOICES1

PGM PARM(&PARM1 &PARM2)
DCL VAR(&PARM1) TYPE(*CHAR) LEN(21)
DCL VAR(&PARM2) TYPE(*CHAR) LEN(2000)
DCL VAR(&PGMTXT) TYPE(*CHAR) LEN(30) VALUE('The +
	Choices program did this')
DCL VAR(&RCVVAR) TYPE(*CHAR) LEN(4096)
DCL VAR(&RCVVARLEN) TYPE(*CHAR) LEN(4) +
	VALUE(X'00002000')
DCL VAR(&ERRCOD) TYPE(*CHAR) LEN(4) +
	VALUE(X'00000000')
DCL VAR(&BIN2) TYPE(*CHAR) LEN(2) VALUE(X'0020')
DCL VAR(&BIN4) TYPE(*CHAR) LEN(4)
DCL VAR(&X) TYPE(*DEC) LEN(4 0) VALUE(3)
DCL VAR(&OFFSET) TYPE(*DEC) LEN(4 0)
DCL VAR(&NUMLANGS) TYPE(*DEC) LEN(3 0)

IF COND(%SST(&PARM1 1 10) = 'CHOICES ' *AND +
	%SST(&PARM1 11 10) = 'CHOICE ' *AND +
	%SST(&PARM1 21 1) = 'C') THEN(DO)
CHGVAR VAR(&PARM2) VALUE('AFR, SQI, ARA, ...')
ENDDO

IF COND(%SST(&PARM1 1 10) = 'CHOICES ' *AND +
	%SST(&PARM1 11 10) = 'CHOICE ' *AND +
	%SST(&PARM1 21 1) = 'P') THEN(DO)

/* Get list of language ids */
CALL PGM(QSYS/QLGRTVLI) PARM(&RCVVAR +
	&RCVVARLEN 'RTVL0100' &ERRCOD)
CHGVAR VAR(&BIN4) VALUE(%SST(&RCVVAR 9 4))
CHGVAR VAR(&NUMLANGS) VALUE(%BIN(&BIN4))
CHGVAR VAR(%SST(&PARM2 1 2)) +
	VALUE(%SST(&BIN4 3 2))
CHGVAR VAR(&BIN4) VALUE(%SST(&RCVVAR 17 4))
CHGVAR VAR(&OFFSET) VALUE(%BIN(&BIN4) + 1)

LOOP: IF (&NUMLANGS > 0) DO
CHGVAR VAR(%SST(&PARM2 &X 2)) VALUE(&BIN2)
CHGVAR VAR(&X) VALUE(&X + 2)
CHGVAR VAR(%SST(&PARM2 &X 3)) +
	VALUE(%SST(&RCVVAR &OFFSET 3))
CHGVAR VAR(&X) VALUE(&X + 3)
CHGVAR VAR(%SST(&PARM2 &X 1)) VALUE(' ')
CHGVAR VAR(&X) VALUE(&X + 1)
CHGVAR VAR(&OFFSET) VALUE(&OFFSET + 3)
CHGVAR VAR(%SST(&PARM2 &X 28)) +
	VALUE(%SST(&RCVVAR &OFFSET 28))
CHGVAR VAR(&X) VALUE(&X + 28)
CHGVAR VAR(&OFFSET) VALUE(&OFFSET + 40)
CHGVAR VAR(&NUMLANGS) VALUE(&NUMLANGS - 1)

IF (&X > 1968) GOTO OUT
GOTO LOOP
ENDDO
ENDDO

OUT: ENDPGM

Thanks to Bruce Vining

Private comment (after testing):
Better change the two following lines ('cause I have 60 languageId's on my system):
DCL VAR(&PARM2) TYPE(*CHAR) LEN(2000) ---> LEN(2560)
IF (&X > 1968) GOTO OUT ---> 2530

--------------------------- updated 2006-09-23 by me: ---------------------------
After some mails with Tom Liotta and the problem above, I have changed the program and deleted the test with '&X > 1968'. Seems unnessesary because &NUMLANGS can do the job.
The length of 2612 for some of the parameters is based on the following calculation: I have 60 languageId's (3 bytes) and the names (40 bytes). The first 32 bytes contains some length definitions. That should be exactly 2612 bytes in total.
/***************************************************************/ /* Choice program */ /***************************************************************/ PGM PARM(&PARM1 &PARM2) DCL VAR(&PARM1) TYPE(*CHAR) LEN(21) DCL VAR(&PARM2) TYPE(*CHAR) LEN(2612) DCL VAR(&PGMTXT) TYPE(*CHAR) LEN(30) VALUE('The + Choices program did this') DCL VAR(&RCVVAR) TYPE(*CHAR) LEN(2612) DCL VAR(&RCVVARLEN) TYPE(*CHAR) LEN(4) + VALUE(X'00002612') DCL VAR(&ERRCOD) TYPE(*CHAR) LEN(4) + VALUE(X'00000000') DCL VAR(&BIN2) TYPE(*CHAR) LEN(2) VALUE(X'0020') DCL VAR(&BIN4) TYPE(*CHAR) LEN(4) DCL VAR(&X) TYPE(*DEC) LEN(4 0) VALUE(3) DCL VAR(&OFFSET) TYPE(*DEC) LEN(4 0) DCL VAR(&NUMLANGS) TYPE(*DEC) LEN(3 0) IF COND(%SST(&PARM1 1 10) = 'T4_0000 ' *AND + %SST(&PARM1 11 10) = 'CHOICE ' *AND + %SST(&PARM1 21 1) = 'C') THEN(DO) CHGVAR VAR(&PARM2) VALUE('AFR, SQI, ARA, ...') ENDDO IF COND(%SST(&PARM1 1 10) = 'T4_0000 ' *AND + %SST(&PARM1 11 10) = 'CHOICE ' *AND + %SST(&PARM1 21 1) = 'P') THEN(DO) /* Get list of language ids */ CALL PGM(QSYS/QLGRTVLI) PARM(&RCVVAR + &RCVVARLEN 'RTVL0100' &ERRCOD) CHGVAR VAR(&BIN4) VALUE(%SST(&RCVVAR 9 4)) CHGVAR VAR(&NUMLANGS) VALUE(%BIN(&BIN4)) CHGVAR VAR(%SST(&PARM2 1 2)) + VALUE(%SST(&BIN4 3 2)) CHGVAR VAR(&BIN4) VALUE(%SST(&RCVVAR 17 4)) CHGVAR VAR(&OFFSET) VALUE(%BIN(&BIN4) + 1) LOOP: IF (&NUMLANGS > 0) DO CHGVAR VAR(%SST(&PARM2 &X 2)) VALUE(&BIN2) CHGVAR VAR(&X) VALUE(&X + 2) CHGVAR VAR(%SST(&PARM2 &X 3)) + VALUE(%SST(&RCVVAR &OFFSET 3)) CHGVAR VAR(&X) VALUE(&X + 3) CHGVAR VAR(%SST(&PARM2 &X 1)) VALUE(' ') CHGVAR VAR(&X) VALUE(&X + 1) CHGVAR VAR(&OFFSET) VALUE(&OFFSET + 3) CHGVAR VAR(%SST(&PARM2 &X 28)) + VALUE(%SST(&RCVVAR &OFFSET 28)) CHGVAR VAR(&X) VALUE(&X + 28) CHGVAR VAR(&OFFSET) VALUE(&OFFSET + 40) CHGVAR VAR(&NUMLANGS) VALUE(&NUMLANGS - 1) GOTO LOOP ENDDO ENDDO OUT: ENDPGM Thanks to Bruce Vining
Back

Convert the UNIX epoch to an RPG timestamp

Here is a little subproc I wrote to convert the UNIX epoch to an RPG timestamp.
Can adjust for UTC if needed. I "copied" some of Scott's code for the UTC part.

// ----------------------------------------------------------------------- // CvtEpochTS // ---------- // Helper routine to convert UNIX-type epoch values (typically the number // of seconds from midnight, Jan 1, 1970) to an OS/400 timestamp value. // The UNIX-type epoch value is considered the "timestamp" value to the // UNIX world. // // INPUTS // inEpochSecs int // The UNIX timestamp, in UNIX epoch format (numbe of seconds since // midnight, Jan 1, 1970. // inAdjustUTC bool // Determine whether the time should be adjusted by the UTC offset. // true - adjust for UTC offset // false - do not adjust for UTC offset // // OUTPUTS // OS400Timestamp char[26] // Equivalent OS/400 timestamp value. p CvtEpochTS b d CvtEpochTS pi z d inEpochSecs 10i 0 const d inAdjustUTC n const // Constants. d EPOCHSTART s z inz(z'1970-01-01-00.00.00.000000') // Variables. d returnts s z inz(z'0001-01-01-00.00.00.000000') d utcoffhours s 10i 0 inz d utcoffmins s 10i 0 inz d utcoffsecs s 8f inz d utcoffset s 10i 0 inz d GetUTCOffset pr extproc('CEEUTCO') d offsethours 10i 0 d offsetminutes 10i 0 d offsetseconds 8f d feedback 12a options(*omit) /free returnts = EPOCHSTART + %seconds(inEpochSecs); if inAdjustUTC; callp(e) GetUTCOffset(utcoffhours:utcoffmins:utcoffsecs:*omit); utcoffset = utcoffsecs; returnts = returnts + %seconds(utcoffset); endif; return returnts; /end-free p CvtEpochTS e Thanks to Loyd Goodbar

Back

QIPLSTS - IPL Status Indicator

From my COMMON pitch, "Everything You Always Wanted to Know About System
Values (but were afraid to ask), which you will *NEVER hear at an IBM
Technical Conference:

  Name:               QIPLSTS
  Description:        IPL Status Indicator
  Length & Type:      Character:   1

  Valid Values and their Meanings:

           '0'        Operator Panel IPL
                      IPL occurred when requested from operator panel.

           '1'        Auto-IPL - following power failure
                      This is enabled by the QPWRRSTIPL system value.

           '2'        Restart IPL
                      After PWRDWNSYS RESTART(*YES)

           '3'        Time-of-day IPL
                      IPL occurred automatically at the date and time
                      specified by the QIPLDATTIM system value.

           '4'        Remote IPL
                      IPL occurred in response to a phone call.
                      This is enabled by the QRMTIPL system value.

  Comments:           OS/400 sets this value on each IPL.
                      Can not be changed by user written routine.


Thanks to Al Barsa
Back

Create an Excel file from AS/400 or ASP

Q: Excel with leading zeros ??
A: This has been discussed before. I get around this by creating a HTML file with the
Excel namespace. Here is some documentation I wrote for my coworkers on the subject.
Not comprehensive but works for us.

Create an Excel file from AS/400 or ASP
It is possible to create a file that Excel likes without being an actual
Excel-formatted file. The trick is to create a HTML file, but named .xls.

A template for creating the HTML file: Excel.txt

Thanks to Loyd Goodbar
Back

CGI vs WDSC

Q: I am trying to build the case for CGIDEV2.

I have been playing with easy400 and BVS examples for a few months
and I blown away by this technology. A year ago, I would have never
thought that I would be writing dynamic web pages in RPG!  I think
the potential market for this technology is extraordinary.  I just
wonder why it has such a low profile compared to other IBM Web
solutions on their roadmap.

Like any product, I have concerns about how well it scales, security
and other issues that may become apparent after a large deployment.

Does anyone have case studies of large mission critical applications?
Many of the customer references on easy400 site seem to be intranet
examples or static 'corporate identity' web pages with a page or two
of dynamic code.  How about good examples of CGIDEV2 transactional
web sites that are accessible to public scrutiny via WWW?

Are there any 'commercial' packages based on CGIDEV2 technology yet?
Has anyone tried CGIDEV2 development for handheld devices?

A: The main reason why CGI is so low profile in the IBM official roadmaps, is that - in spite of its enormous success world wide - CGIDEV2 is totally unknown (as to easiness and performance) to the Rocheter/Toronto people who wrote those guidelines. Besides, any attempt to draw their attention on this phenomenal tool, has no hope, as they evaluate "in principle" any CGI based tool as "non strategic" and opposite to their WDSC strategy. I have tried, but I just got the invitation to join back the official strategy. I do believe that CGIDEV2 is simply a great step from plain RPG into a "basic" WEB environment, covering all traditional user needs for the WEB. Of course, Websphere is the IBM strategic vehicle, already providing some advanced services which go far beyond CGI (e.g. portal support). Question is however, why small or medium WEB servers should pay the amount of human and HW resources required by Websphere, if their initial target is a "basic" WEB environment. They may start quickly at almost no cost with CGIDEV2, and grow later on, if they need, adopting Websphere, which is compatible with CGI on the same server. About scalability, some words have already spent in this forum. First of all, as a CGIDEV2 based solution wil consume from 10 to 20 times less resources than a similar Websphere solution, scalability problems are delayed by the same factor. I know of CGI based iSeries servers that are running more than 1,000 users. In my references ( http://www-922.ibm.com/easy400p/ref00.html ), you will for instance find the case of the Kaert Software,. They did migrate with great success from iNET to CGIDEV2 one of the largest European Order Entry server. You may also get in touch with the one who did the job. He can give you details about performance etc. Anyone else having achieved large user numbers with CGIDEV2 is encouraged to publish her/his achievements on the Easy40 testimonial page, http://www-922.ibm.com/easy400p/ref01.html Giovanni B. Perotti Easy400 site owner http://www-922.ibm.com Thanks to Giovanni Perotti

Back

Checking Your iSeries Batteries

You may not realize it, but your iSeries boxes contain a set of nickel batteries,
which are used as cache battery packs on your systems' I/O adapters. And, like
any battery, they eventually have to be replaced; otherwise your system may start
to malfunction. This week's "Admin Alert" explains how to check the batteries on
your system, so you can determine when they need to be replaced.

Most people don't pay attention to their cache batteries until they spot an OS/400
error message stating that their cache battery is about to die. If you're under
maintenance, you can call IBM to arrange for a replacement battery, as well as a
visit from a technician to install the new battery and to reset the error. Because
of the potential for system problems, you should call IBM as soon as possible after
getting a battery warning error. But these errors are generally timed so that you
have about 90 days to replace the battery before it fails. So don't panic, but
don't ignore the warning, either, or you may find yourself in trouble if the
battery suddenly fails before its 90 days are up.

IBM will send you a replacement battery (which is about the size of a battery you
might see in a portable phone), and will give you instructions for calling for a
replacement appointment once the battery arrives. To replace the battery, you must
take down the partition where the I/O adapters with the failing cache battery resides,
so that the technician can pull the I/O adapter card and put in the new battery.

But the batteries don't always fail at the same time, especially if you've added
or replaced I/O adapters on your system. So while you're planning to take down a
partition or two (especially if the failed battery resides in a primary partition,
which will disable the whole system), you may want to inventory the other batteries
on your system and ask IBM to change any that are close to issuing a failure warning.
This way, you only have to take your system down once to replace all of your older
batteries.

To find the status of batteries, open a green-screen 5250 session and go into each
partition's "system service tools" menu, by typing in the Start System Service Tools
(STRSST) command. Beginning with OS/400 V5R1, IBM requires you to type in a user
ID and password before entering SST. While this sounds easy, it's also incredibly
easy to disable or forget your SST password. (If you need help understanding how to
set or reset an SST password, see "Bringing V5R1 DST Passwords Under Control.")

Once you enter the SST menu, perform the following commands to display the status
of your batteries.

Type in option 1 from the "system services" menu, "start a service tool."

Select option 4 from the "start a service tool" menu, "display/alter/dump."

Select option 1 from the "display/alter/dump" output device menu, "display/alter
storage.

Select option 2, "licensed internal code (LIC) data," from the "select data" menu.

Select option 14, "advanced analysis," from the "select LIC data" menu.

On the "select advanced analysis command" screen, place a 1 in front of the
BATTERYINFO command, and press Enter.

On the option line for the BATTERYINFO command, type -INFO –ALL, and press Enter.

Performing this procedure displays the status of all batteries assigned to your
partition. This BATTERYINFO results screen shows the frame and card position of
each battery, the battery type, and the estimated time (in days) before OS/400
issues an oncoming failure warning on that battery, as well as the estimated
time (in days) before the battery actually could fail. And if you have multiple
partitions with multiple I/O adapter cards on your system, you should run this
procedure on every partition to get a complete inventory of batteries needing
maintenance.

My personal guideline is to ask IBM to replace any battery that is within a year of
issuing a failure warning. Since iSeries boxes are renowned for running for months or
even longer without a shutdown, this should be a reasonable timeframe. After you get
the complete information on all batteries on the system that need to be replaced
within a year, call IBM to order the batteries and schedule the service call.

There are several other options you can run once you're inside BATTERYINFO. You can
find these options by running the BATTERYINFO macro with the "help" option. But be
careful when running this command, because it contains one option that will force an
error on an active battery cache pack.

Also be aware that, if you're running OS/400 V5R2, there is a PTF that you must apply
in order to display battery pack status information or to force a battery pack error.
The PTF number is MF32343, which is applied to licensed program 5722999.

By following these simple instructions, you can easily inventory your battery pack
to monitor the health of your I/O adapter cards and to plan for orderly battery
replacements.

Thanks to Joe Hertvik and IT-Jungle (Four Hundred Guru)
Back

Query object - retrieving spooled output details

- Here's the Retrieve Query Information source that the EXTQRYDFN utility
was based on - it has a little more details:

     **-- Info:  -------------------------------------------------------------**
     **
     **   The *PSSR subroutine could be modified to more elegantly inform
     **   the caller about the actual exception that occurred.
     **
     **   It is up to you to add parameters to return the information you
     **   are interested in to the program's parameter list and subsequently
     **   add code to move the relevant subfields to these parameters.
     **
     **-- Header:  -----------------------------------------------------------**
     H DftActGrp( *No )  BndDir( 'QC2LE' )
     **-- MI Functions:  -----------------------------------------------------**
     D rslvsp          Pr              *   ProcPtr  ExtProc( 'rslvsp' )
     D  ObjTyp                        2a   Value
     D  ObjNam                         *   Value  Options( *String )
     D  ObjLib                         *   Value  Options( *String )
     D  AutReq                        2a   Value
     **
     D setsppfp        Pr              *   ExtProc( 'setsppfp' )
     D   Object                        *   Value  ProcPtr
     **
     D setsppo         Pr              *   ExtProc( 'setsppo' )
     D   SpcPtr                        *   Value
     D   Offset                      10i 0 Value
     **
     D MemCpy          Pr              *   ExtProc( 'memcpy' )
     D  pOutMem                        *   Value
     D  pInpMem                        *   Value
     D  iMemSiz                      10u 0 Value
     **-- Query outfile specification:  --------------------------------------**
     D QiOutFil        Ds
     D  OfDtaLen                     10i 0 Inz
     D  OfFilNam                     10a
     D                                5i 0 Inz
     D  OfLibNam                     10a
     D                                5i 0
     D  OfMbrNam                     10a
     D                                5i 0
     D  OfDtaOpt                      1a
     D                                3i 0
     D  OfFilAut                     10a
     **-- Query inputfile(s) specification:  ---------------------------------**
     D QiInpFil        Ds
     D  IfNbrFil                      5i 0 Inz
     D  IfFilInf                     80a   Dim( 32 )
     D                                5i 0 Overlay( IfFilInf:  1 )
     D  IfFilNam                     10a   Overlay( IfFilInf:  3 )
     D                                5i 0 Overlay( IfFilInf: 13 )
     D  IfLibNam                     10a   Overlay( IfFilInf: 15 )
     D                                5i 0 Overlay( IfFilInf: 25 )
     D  IfMbrNam                     10a   Overlay( IfFilInf: 27 )
     D                                5i 0 Overlay( IfFilInf: 37 )
     D  IfRcdNam                     10a   Overlay( IfFilInf: 39 )
     D                                5i 0 Overlay( IfFilInf: 49 )
     D  IfFilId                       4a   Overlay( IfFilInf: 51 )
     D                                5i 0 Overlay( IfFilInf: 55 )
     D  IfRcdId                      13a   Overlay( IfFilInf: 57 )
     D                               11a   Overlay( IfFilInf: 70 )
     **-- Query printed output specifications:  ------------------------------**
     D QiOutWtr        Ds
     D  OwDtaLen                     10i 0 Inz
     D  OwWtrNam                     10a
     D                               26a
     D  OwPprLen                      5i 0
     D  OwPprWdt                      5i 0
     D                                5i 0
     D                                5i 0
     D                                5i 0
     D  OwFrmTyp                     10a
     D                               12a
     D  OwPrtLin1                     5i 0
     D  OwPrtLinLst                   5i 0
     D  OwPrtLinDst                   5i 0
     D  Owx90                         3i 0
     D  OwPrtDfn                      3i 0
     **
     D QiRptHdr        Ds
     D  RhHdrLen                     10i 0 Inz
     D                               10i 0
     D                               10i 0
     D  RhNbrLin                      5i 0
     D  RhLinLen                      5i 0
     D  RhDta                       320a
     **
     D QiPagHdr        Ds
     D  PhHdrLen                     10i 0 Inz
     D                               10i 0
     D                               10i 0
     D  PhNbrLin                      5i 0
     D  PhLinLen                      5i 0
     D  PhDta                       240a
     **
     D QiPagTrl        Ds
     D  PtTrlLen                     10i 0 Inz
     D                               10i 0
     D                               10i 0
     D  PtNbrLin                      5i 0
     D  PtLinLen                      5i 0
     D  PtDta                        80a
     **-- Query selection criterias:  ----------------------------------------**
     D QiSelCriHdr     Ds
     D  ScTotLen                     10i 0 Inz
     D                               10i 0
     D                               10i 0
     D                               10i 0
     D  ScNbrCri                      5i 0
     **
     D QiSelCriDtl     Ds
     D  ScCriLen                      5i 0 Inz
     D                               10i 0
     D                               10i 0
     D  ScCriRelN                    10i 0
     D  ScCriRel                      1a   Overlay( ScCriRelN: 4 )
     D  ScCriArg1                    14a
     D  ScCriOpr                      2a
     D  ScCriArg2Lin                  5i 0
     D  ScCriArg2Dta               4096a
     **
     D QiSelCriArg2    Ds                  Based( pArg2 )
     D  ScCriArg2Len                  5i 0
     D  ScCriArg2                   512a
     ** Formatted selection criterias:
     D SelCri          Ds
     D SelTxt                        55a   Dim( 256 )
     D  SelRel                        3a   Overlay( SelTxt:  1 )
     D  SelArg1                      14a   Overlay( SelTxt:  5 )
     D  SelOpr                        5a   Overlay( SelTxt: 20 )
     D  SelArg2                      30a   Overlay( SelTxt: 26 )
     **
     D Opr             Ds
     D Opr1                          14a   Inz('INLKNKNSNSNTBT')
     D Opr2                          35a   Inz('LIST LIKE NLIKENLISTISNOTRANGE')
     D OprMnm                         2a   Dim( 7 ) Overlay( Opr1 )
     D OprTxt                         5a   Dim( 7 ) Overlay( Opr2 )
     **-- Global variables:  -------------------------------------------------**
     D pQryObj         s               *   ProcPtr
     D pQryTpl         s               *
     D QryTpl          s          32767a   Based( pQryTpl )
     **
     D Int             s             10i 0
     D Idx             s              5i 0
     D Lin             s              5i 0
     D OutOpt          s              1a
     **-- Parameters:  -------------------------------------------------------**
     D PxQryNam        s             10a
     D PxQryLib        s             10a
     **
     C     *Entry        Plist
     C                   Parm                    PxQryNam
     C                   Parm                    PxQryLib
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      pQryObj =  rslvsp( x'1911'
     C                                              : %TrimR( PxQryNam )
     C                                              : %TrimR( PxQryLib )
     C                                              : x'0000'
     C                                              )
     **
     c                   Eval      pQryTpl  = setsppfp( pQryObj )
     **
     c                   Eval      pQryTpl  = setsppo( pQryTpl: 260 )
     C                   CallP     MemCpy( %Addr( OutOpt )
     C                                   : pQryTpl
     C                                   : %Size( OutOpt )
     C                                   )
     **
     C                   If        OutOpt   = '3'
     C                   Eval      OfFilNam = '*DFT'
     C                   Eval      OfLibNam = '*PRV'
     C                   Eval      OfDtaLen = 25
     C                   EndIf
     **
     c                   Eval      pQryTpl  = setsppo( pQryTpl: 380 )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     c                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiOutFil )
     C                                   : pQryTpl
     C                                   : %Size( QiOutFil )
     C                                   )
     C                   EndIf
     **
     c                   Eval      pQryTpl  = setsppo( pQryTpl: 396 )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     c                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiOutWtr )
     C                                   : pQryTpl
     C                                   : %Size( QiOutWtr )
     C                                   )
     C                   EndIf
     **
     C                   Eval      pQryTpl  = setsppo( pQryTpl: x'019C' )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     c                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiRptHdr )
     C                                   : pQryTpl
     C                                   : %Size( QiRptHdr )
     C                                   )
     C                   EndIf
     **
     c                   Eval      pQryTpl  = setsppo( pQryTpl: x'01AC' )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     c                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiPagHdr )
     C                                   : pQryTpl
     C                                   : %Size( QiPagHdr )
     C                                   )
     C                   EndIf
     **
     c                   Eval      pQryTpl  = setsppo( pQryTpl: x'01BC' )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     c                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiPagTrl )
     C                                   : pQryTpl
     C                                   : %Size( QiPagTrl )
     C                                   )
     C                   EndIf
     **
     C                   Eval      pQryTpl  = setsppo( pQryTpl: 558 )
     C                   CallP     MemCpy( %Addr( IfNbrFil )
     C                                   : pQryTpl
     C                                   : %Size( IfNbrFil )
     C                                   )
     **
     C                   Eval      pQryTpl  = setsppo( pQryTpl: 560 )
     **
     C                   For       Idx = 1 To IfNbrFil
     C                   CallP     MemCpy( %Addr( IfFilInf( Idx ))
     C                                   : pQryTpl
     C                                   : %Size( IfFilInf )
     C                                   )
     **
     C                   Eval      pQryTpl  = pQryTpl + %Size( IfFilInf )
     C                   EndFor
     **
     C                   Eval      pQryTpl  = setsppo( pQryTpl: x'5C' )
     C                   CallP     MemCpy( %Addr( Int )
     C                                   : pQryTpl
     C                                   : %Size( Int )
     C                                   )
     **
     C                   If        Int      > 0
     C                   Eval      pQryTpl  = setsppo( pQryTpl: Int )
     C                   CallP     MemCpy( %Addr( QiSelCriHdr )
     C                                   : pQryTpl
     C                                   : %Size( QiSelCriHdr )
     C                                   )
     **
     C                   Eval      pQryTpl  = pQryTpl + %Size( QiSelCriHdr )
     **
     C                   Eval      Lin      =  *Zero
     **
     C                   Do        ScNbrCri
     C                   CallP     MemCpy( %Addr( QiSelCriDtl )
     C                                   : pQryTpl
     C                                   : %Size( QiSelCriDtl )
     C                                   )
     **
     C                   Eval      pArg2    = %Addr( ScCriArg2Dta )
     C                   Eval      Lin      = Lin + 1
     **
     C                   If        ScCriRel = x'80'
     C                   Eval      SelRel(Lin)  = 'OR '
     C                   Else
     C                   Eval      SelRel(Lin)  = 'AND'
     C                   EndIf
     C                   Eval      SelArg1(Lin) = ScCriArg1
     C                   Eval      SelOpr(Lin)  = ScCriOpr
     **
     C                   For       Idx = 1 To  ScCriArg2Lin
     C                   Eval      SelArg2(Lin) =  %SubSt( ScCriArg2
     C                                                   : 1
     C                                                   : ScCriArg2Len
     C                                                   )
     **
     C                   If        Idx      < ScCriArg2Lin
     C                   Eval      Lin      = Lin + 1
     C                   Eval      pArg2    = pArg2 + ScCriArg2Len + 2
     C                   EndIf
     C                   EndFor
     **
     C                   Eval      pQryTpl  = pQryTpl + ScCriLen
     C                   EndDo
     C                   EndIf
     **
     C                   Eval      *InLr       =  *On
     **
     C     *Pssr         BegSr
     **
     C                   Return
     **
     C                   EndSr

Same technique with enhancements @ Midrange.com

Thanks to Carsten Flensburg and others
Back

Transfer users from v5.2 to v5.1

Q: I'm working normaly in V5.2, but now I need to set up a V5.1 model 270 with the
same users.  I used the SAVSEC command, in the V5.2 I can display the directory of the
savefile, but in the V5.1 computer I only got "Invalid savefile" message.  I didn't find
a "*PRV" option in the SAVSEC, as there is in SAVOBJ.

Is there a way to transfer all my users, other than creating each profile in the 270?

A: Go into iSeries Navigator. Navigate to the Users and groups section for your 5.2 system. Ctrl+Click on those users that you want to send to the 5.1 system, then right click and select Send. Select the system you want to send them to, (your 5.1 model 270) and click OK. You could have a long wait, depending on how many users you want to send over - but they will get there. Thanks to Neil Clark

Back

Julian Date vs. Lilian Date

Q: How do I add 1 day to a date in a CL-program ??

A: You could use the CVTDAT command to convert the date to Julian format, add 1 then CVTDAT back to the original format

A: No.. no.. The reason I prefer Lilian to Julian is that Julian won't work properly across years. A Julian date consists of the year followed by the day number within the year. Since December 31 is the 365th day of the year, the last day of this year is 05365 in Julian format. If you add 1 to 05365, you get 05366 which isn't a valid Julian date. When you use Lilian dates you don't have this problem. CALLPRC PRC(CEEDAYS) PARM(&YYMD 'YYYYMMDD' &LILIAN *OMIT) CHGVAR VAR(%BIN(&LILIAN)) VALUE(%BIN(&LILIAN) + 1) CALLPRC PRC(CEEDATE) PARM(&LILIAN 'YYYYMMDD' &YYMD *OMIT) Thanks to Scott Klement

Back

Dynamically Increase an Array's Size

Q: In using VB and C I have the ability to dynamically increase an array's
size from say 50 to 100 without losing the existing data, is this possible in RPG?

A: Yes, you'll have to base you're array on a pointer. Then increase the allocation size. Take a look at the ALLOC, REALLOC, and DEALLOC op codes. Here's a quick example: * array definitions Darray S 10 DIM(20000) BASED(PTR) Dindex s 7 0 * memory allocation data items Dptr S * Dnbr_of_elems S 5 0 INZ(10) Dmem_size S 7 0 INZ Dx S 10i 0 * allocate the initial memory heap = * (initial # of elements * the size of the array) C EVAL mem_size = %size(array) * nbr_of_elems C ALLOC mem_size ptr C EVAL x = %elem(array) * loop to test C 1 DO 50 index * does the index exceed the current # of array elements? C IF index > nbr_of_elems * recalculate the memory heap size by adding 10 to the number of elements * and multiplying the size of the array by the new number of elements. C EVAL nbr_of_elems = nbr_of_elems + 10 C EVAL mem_size = %size(array) * nbr_of_elems * reallocate the memory heap and increase the size C REALLOC mem_size ptr C ENDIF * move data for test C MOVE index array(index) * C ENDDO * deallocate the memory utilized C DEALLOC ptr C EVAL *inlr = *on Thanks to Mark D. Walter

Back

Change FTP port - iSeries

Found this on Search400 …

… how to change your FTP server to use a port other than the default port of 21.
Ports in the range of 0-1023 are reserved and well-known ports, with port 21
being the established standard for FTP. The reason most people want to do this
is to make it harder for someone to gain unauthorized access to your FTP
server.

Although this may make it more difficult for someone to discover that you are
running an FTP server, this by itself will not prevent someone from being able
to discover and potentially hack into your FTP server. If you decide to use
this technique, keep in mind that this is no substitute for other types of
security and should be viewed as only a very small piece of your security
infrastructure. If you have existing FTP programs or scripts, you will need to
change them to access your new FTP port.

For anyone who has tried to do this, you may have noticed that the port can’t
be changed using the CHGFTPA command. Here is how to make the changes.

Enter the command WRKSRVTBLE and scroll down to the services that are labeled
ftp-control. Display and print these entries.

Use the command ADDSRVTBLE to duplicate these entries exactly as they appear,
with the exception that you will specify a new port number. To get lowercase
values to stay lowercase, make sure they are enclosed in single quotes. When
you specify your new FTP port, you should avoid using the reserved ports of
0-1023. You should also try to avoid using other ports that are already defined.

Compare your new entries to the existing entries that are on port 21 to ensure
that everything is an exact match.

Delete your existing entries for service ftp-control that is on port 21.

End and restart TCP/IP.

If you wish, entries labeled ftp-data can also be changed in a similar manner.
When you access FTP from the AS/400, you will now have to specify the port.

From the AS/400 the FTP command would look like this:
FTP RMTSYS ('10.10.10.10') PORT (21021)

From the DOS prompt, it would look like this:
C:WINDOWS>ftp
ftp> open 10.10.10.10 21021

Thanks to David Gibbs & Search400
Back

Date Handling i RPG IV

Found this article written by Joel Cochran for IT Jungle …

Thanks to Joel Cochran & IT Jungle
Back

Zip files on IFS

Q:
What is the best way to zip files on the ifs?  What tools are good or is
there a native way in os/400?
A:
Define "best."  Fastest? Cheapest? Has the most features? Has the best
support?

I know of 3 ways to make ZIP files that run on the iSeries:

a) The JAR utility that comes with Java.  Very slow, and has very few
features, but if all you need is a basic ZIP file, it works and there's a
good chance that it's already on your iSeries.

From a CL program, you can do:
    STRQSH CMD('jar cMf result.zip file1 file2 file3')

b) The InfoZIP program can be run in PASE. This has more features than
JAR, runs faster, and is free.  This is what I use.  There's an article
on the iSeries Network that explains how to set up and use it:
http://www.iseriesnetwork.com/article.cfm?id=17815

c) PKZIP from PKWare.  They make a native iSeries version. It costs money,
but then you get a commercially supported product. It's likely to be more
feature-rich than the other two methods (I know it has better encryption,
I don't know much else, though).  http://www.pkware.com

All of these solutions run on the iSeries, and all can be run
programmatically (with no user intervention)

A:
One more way to add to the three that Scott has listed is

gzip from http://www.gzip.org. You could download the executable from
http://www.gzip.org/gzip-as400.zip

You can use gzip to only compress/uncompress from files on the IFS.

Thanks to Scott Klement & Krish Thirumalai
Back

Clearing an iSeries

Q:
We have an old AS/400 (Model 170, V4R5M0) which we plan to use as kind of test-machine to
test instal-programs and other stuffs that are too risky or even impossible to do on our
development machine.

Now I want to completely "clear" the system and afterwards install V5R1M0. Is there a simple
way to do this ? In other words : do we have on our AS/400 something like "FORMAT C:" on PC ?

A: Document Title Initialize Disk Drives So That All Data Is Erased Off of a System Document Description In some cases, a customer may wish to erase all data off their system. They may want to do this because they are getting rid of it and do not want any of their data on it. No Partitions: The procedure for doing this follows: 1 Do a D Manual IPL using a SAVSYS, full system save, or LIC Install CD. 2 The first menu will give an Option 1 to Install LIC, and Option 2 to use DST. Select Option 1. 3 The Install LIC menu will provide 5 options. Select Option 2 to Install Licensed Internal Code and Initialize System. 4 After the install of LIC is complete, the system will IPL to the DST primary menu. 5 Configure all the disk drives by adding them into system ASP (ASP1).    This writes zeroes on the disk drives so only the LIC is loaded.    o Select Option 3 - Use DST.    o Work with Disk Units.    o Work with Disk Configuration.    o Work with ASP Configuration.    o Add units to ASPs.    o Type 1 in front of all the available units. 6 When that is complete, power off the system by pressing the power button two times. System is clean and ready to go. Partitioned System: (This will remove all partitions and erase all data on drives from all earlier partitions.) The procedure for doing this follows: 1 Do a D Manual IPL using a SAVSYS, full system save, or LIC Install CD of the primary partition. 2 The first menu will give an Option 1 to Install LIC, and Option 2 to use DST. Select Option 1. 3 The Install LIC menu will provide 5 options. Select Option 2 to Install Licensed Internal Code and Initialize System. 4 After the install of LIC is complete, the system will IPL to the DST primary menu. 5 Take the option to Work with system partitions. 6 Take the option to Recover configuartion data. 7 Take the option to Clear non-configured disk unit configuration data. 8 Exit back to the DST primary menu. 9 Configure all the disk drives by adding them into system ASP (ASP1).    This writes zeroes on the disk drives so only the LIC is loaded.    o Select Option 3 - Use DST.    o Work with Disk Units.    o Work with Disk Configuration.    o Work with ASP Configuration.    o Add units to ASPs.    o Type 1 in front of all the available units. 10 When that is complete, power off the system by pressing the power button two times. System is clean and ready to go Thanks to George Nunn

Back

Retrieve ASP percentage

Example :
  RTVASPPERC ASP(2) PERCENTAGE(*USED)
  RTVASPPERC ASP(1) PERCENTAGE(*AVAILABLE)

 /*  Command :     RTVASPPERC                                       */
 /*  Version :     1.00                                             */
 /*  System  :     iSeries                                          */
 /*  Author :      Herman Van der Staey                             */
 /*                                                                 */
 /*  Description : Retrieve the percentage used/available in        */
 /*                an ASP.                                          */
 /*                                                                 */
 /*  To compile :                                                   */
 /*                                                                 */
 /*     CRTCMD     CMD(XXX/RTVASPPERC) PGM(XXX/RTVASPPERC) +        */
 /*                   SRCFILE(XXX/QCMDSRC)                          */
 /*                                                                 */

 RTVASPPERC: CMD        PROMPT('Retrieve ASP percentage')

             PARM       KWD(ASP) TYPE(*INT4) DFT(1) RANGE(1 32) +
                          PROMPT('ASP number')

             PARM       KWD(PERCENTAGE) TYPE(*CHAR) LEN(10) +
                          RSTD(*YES) DFT(*USED) VALUES(*USED +
                          *AVAILABLE) PROMPT('Percentage type')

  /*  Program : RTVASPPERC                                          */
  /*  Version : 1.00                                                */
  /*  System  : iSeries V5R1                                        */
  /*  Author :  Herman Van der Staey                                */
  /*                                                                */
  /*  Description : Retrieve ASP percentage (Used / Available)      */
  /*                                                                */

 RTVASPPERC: PGM        PARM(&ASP &PERCENTAGE)

             /*  ASP number (Binary)                                */
             DCL        VAR(&ASP)        TYPE(*CHAR) LEN(4)
             /*  Percentage type (*USED / *AVAILABLE)               */
             DCL        VAR(&PERCENTAGE) TYPE(*CHAR) LEN(10)
             /*  Percentage available (in Decimal)                  */
             DCL        VAR(&PERAVAIL)   TYPE(*DEC)  LEN(5 2)
             /*  Percentage used (in Decimal)                       */
             DCL        VAR(&PERUSED)    TYPE(*DEC)  LEN(5 2)
             /*  Percentage available (char)                        */
             DCL        VAR(&CPERAVAIL)  TYPE(*CHAR) LEN(6)
             /*  Percentage used (char)                             */
             DCL        VAR(&CPERUSED)   TYPE(*CHAR) LEN(6)
             /*  ASP number (Char)                                  */
             DCL        VAR(&CASP)       TYPE(*CHAR) LEN(2)
             /*  ASP number (Bin)                                   */
             DCL        VAR(&APIASPNBR)  TYPE(*CHAR) LEN(4)
             /*  Number of disks                                    */
             DCL        VAR(&APINBRDSK)  TYPE(*DEC)  LEN(7 0)
             /*  Total capacity                                     */
             DCL        VAR(&APITOTCAP)  TYPE(*DEC)  LEN(11 0)
             /*  Availble capacity                                  */
             DCL        VAR(&APIAVACAP)  TYPE(*DEC)  LEN(11 0)
             /*  Variable that receives information                 */
             DCL        VAR(&RECEIVER)  TYPE(*CHAR)  LEN(150)
             /*  Length of the receiver variable                    */
             DCL        VAR(&RCV_LEN)   TYPE(*CHAR)  LEN(4)
             /*  Status information about the list of opened ASP's  */
             DCL        VAR(&LISTINFO)  TYPE(*CHAR)  LEN(80)
             /*  Number of records to return                        */
             DCL        VAR(&NBRRECRTN) TYPE(*CHAR)  LEN(4)
             /*  Number of filters                                  */
             DCL        VAR(&NBRFILTER) TYPE(*CHAR)  LEN(4)
             /*  Filter information                                 */
             DCL        VAR(&FILTER)    TYPE(*CHAR)  LEN(16)
             /*  Size of filter entry                               */
             DCL        VAR(&FILTENTR)  TYPE(*CHAR)  LEN(4)
             /*  Filter key                                         */
             DCL        VAR(&FILTKEY)   TYPE(*CHAR)  LEN(4)
             /*  Filter data length                                 */
             DCL        VAR(&FILTSIZE)  TYPE(*CHAR)  LEN(4)
             /*  Filter data                                        */
             DCL        VAR(&FILTDATA)  TYPE(*CHAR)  LEN(4) /* When +
                          the filter key = 1  the filter data is an +
                          ASP number */

             /*  Put the ASP number in the filter data field        */
             CHGVAR     VAR(&FILTDATA) VALUE(&ASP)

             CHGVAR     VAR(%BIN(&FILTENTR)) VALUE(16) /* The +
                          combined size of all fields in the filter +
                          entry (size, key and data) */
             CHGVAR     VAR(%BIN(&FILTKEY))  VALUE(1)
             CHGVAR     VAR(%BIN(&FILTSIZE)) VALUE(4)

             CHGVAR     VAR(%BIN(&RCV_LEN)) VALUE(150)
             CHGVAR     VAR(%BIN(&NBRRECRTN 1 4)) VALUE(1)
             CHGVAR     VAR(%BIN(&NBRFILTER 1 4)) VALUE(1)

             CHGVAR     VAR(&FILTER) VALUE(&FILTENTR *CAT &FILTKEY +
                          *CAT &FILTSIZE *CAT &FILTDATA)

             /*  Execute API                                        */
             CALL       PGM(QGY/QYASPOL) PARM(&RECEIVER &RCV_LEN +
                          &LISTINFO &NBRRECRTN &NBRFILTER &FILTER +
                          'YASP0200' X'00000000')

             /*  extract ASP number                                 */
             CHGVAR     VAR(&APIASPNBR) VALUE(%SST(&RECEIVER 1 4))
             IF         COND(&APIASPNBR *NE &ASP) THEN(DO)
               SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Error +
                          occurred') MSGTYPE(*ESCAPE)
               RETURN
             ENDDO

             CHGVAR     VAR(&CASP) VALUE(%BIN(&APIASPNBR))
             /*  extract number of disk units                       */
             CHGVAR     VAR(&APINBRDSK) VALUE(%BIN(&RECEIVER 5 4))
             /*  extract total ASP capacity                         */
             CHGVAR     VAR(&APITOTCAP) VALUE(%BIN(&RECEIVER 9 4))
             /*  extract available ASP capacity                     */
             CHGVAR     VAR(&APIAVACAP) VALUE(%BIN(&RECEIVER 13 4))
             /*  calculate percentage available                     */
             CHGVAR     VAR(&PERAVAIL) VALUE((&APIAVACAP / +
                          &APITOTCAP) * 100)
             /*  calculate percentage used                          */
             CHGVAR     VAR(&PERUSED) VALUE(100 - ((&APIAVACAP / +
                          &APITOTCAP) * 100))
             /*  convert decimal values to character format         */
             CHGVAR     VAR(&CPERAVAIL) VALUE(&PERAVAIL)
             CHGVAR     VAR(&CPERUSED)  VALUE(&PERUSED)

             /*  Display percentage in Character format             */
             IF (&PERCENTAGE *EQ *USED) THEN(DO)
             SNDPGMMSG  MSG('ASP ' *CAT &CASP *BCAT 'percentage used +
                          = ' *CAT &CPERUSED) MSGTYPE(*COMP)
                          ENDDO
             ELSE       CMD(DO)
             SNDPGMMSG  MSG('ASP ' *CAT &CASP *BCAT 'percentage +
                          available  = ' *CAT &CPERAVAIL) +
                          MSGTYPE(*COMP)
             ENDDO

 END:        ENDPGM

Thanks to Herman Van der Staey
Back

Copy DB file to Excel format

 /*                                                               */
 /*                             \\\\\\\                           */
 /*                            ( o   o )                          */
 /*------------------------oOO----(_)----OOo----------------------*/
 /*                                                               */
 /*  Command : CPYTOXLS     version 2.00                          */
 /*  System :  iSeries                                            */
 /*  Author :  Herman Van der Staey          August 12, 2002      */
 /*                                                               */
 /*  Copy database file to EXCEL format                           */
 /*  and include (ALIAS) field names.                             */
 /*                                                               */
 /*                     ooooO              Ooooo                  */
 /*                     (    )             (    )                 */
 /*----------------------(   )-------------(   )------------------*/
 /*                       (_)               (_)                   */
 /*                                                               */
 /*  To compile :                                                 */
 /*                                                               */
 /*        CRTCMD     CMD(XXX/CPYTOXLS) PGM(XXX/CPYTOXLS) +       */
 /*                      SRCFILE(XXX/QCMDSRC)                     */
 /*                                                               */

 CPYTOXLS:   CMD        PROMPT('Copy to EXCEL format')

             PARM       KWD(FILE) TYPE(FILENAME) PROMPT('File name')

             PARM       KWD(MBR) TYPE(*NAME) LEN(10) DFT(*FIRST) +
                          SPCVAL((*FIRST)) PROMPT('Member name')

             PARM       KWD(TOFILE) TYPE(*CHAR) LEN(64) +
                          DFT(MYFILE.CSV) MIN(0) EXPR(*YES) +
                          CASE(*MIXED) PROMPT('IFS filename + +
                          extension CSV')

             PARM       KWD(TODIR) TYPE(*PNAME) LEN(128) +
                          DFT('/mydir') CASE(*MIXED) PROMPT('To IFS +
                          directory')

             PARM       KWD(FIELDNAMES) TYPE(*LGL) DFT(*YES) +
                          SPCVAL((*YES '1') (*NO '0')) MIN(0) +
                          EXPR(*YES) CHOICE('*YES, *NO') +
                          PROMPT('Include Fieldnames')

             PARM       KWD(ALIAS) TYPE(*LGL) DFT(*YES) SPCVAL((*YES +
                          '1') (*NO '0')) MIN(0) EXPR(*YES) +
                          CHOICE('*YES, *NO') PROMPT('Use ALIAS +
                          fieldnames')

 FILENAME:   QUAL       TYPE(*NAME) LEN(10) MIN(1)
             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
                          SPCVAL((*CURLIB) (*LIBL)) PROMPT('Library')


/*   Program :  CPYTOXLS    version 2.00                          */
/*   System  :  iSeries     V5Rx                                  */
/*   Author  :  Herman Van der Staey        August 12, 2002       */
/*                                                                */
/*   Copy database file to EXCEL format                           */
/*   and include (ALIAS) field names.                             */
/*                                                                */
/*   The file will be copied to CSV format (comma separated       */
/*   values), which can directly be imported in EXCEL if          */
/*   you give the filename the extension ".CSV"                   */
/*                                                                */
/*   To compile :                                                 */
/*                                                                */
/*           CRTCLPGM   PGM(XXX/CPYTOXLS) SRCFILE(XXX/QCLSRC)     */

 CPYTOXLS:   PGM        PARM(&FILE &FROMMBR &TOFILE &TODIR +
                          &FIELDNAMES &ALIAS)

             DCLF       FILE(QSYS/QADSPFFD) /* File field reference +
                          file */
             DCL        VAR(&FILE)       TYPE(*CHAR) LEN(20)
             DCL        VAR(&FROMFILE)   TYPE(*CHAR) LEN(10)
             DCL        VAR(&FROMLIB)    TYPE(*CHAR) LEN(10)
             DCL        VAR(&FROMMBR)    TYPE(*CHAR) LEN(10)
             DCL        VAR(&TOFILE)     TYPE(*CHAR) LEN(64)
             DCL        VAR(&TODIR)      TYPE(*CHAR) LEN(128)
             DCL        VAR(&TOSTMF)     TYPE(*CHAR) LEN(193)
             DCL        VAR(&MBROPT)     TYPE(*CHAR) LEN(10)
             DCL        VAR(&NOT_FIRST)  TYPE(*LGL) LEN(1) VALUE('0')
             DCL        VAR(&FIELDNAMES) TYPE(*LGL)
             DCL        VAR(&ALIAS)      TYPE(*LGL)
             DCL        VAR(&ST)         TYPE(*CHAR) LEN(1024)
             DCL        VAR(&COMMA)      TYPE(*CHAR) LEN(1) VALUE(',')
             DCL        VAR(&DBLQUOTE)  TYPE(*CHAR) LEN(1) VALUE('"') +
                          /* Double quote */

             CHGVAR     VAR(&FROMFILE) VALUE(%SST(&FILE 1 10))
             CHGVAR     VAR(&FROMLIB)  VALUE(%SST(&FILE 11 10))
             CHGVAR     VAR(&TOSTMF) VALUE(&TODIR *TCAT '/' *CAT +
                          &TOFILE)

             IF         COND(&FIELDNAMES) THEN(CHGVAR VAR(&MBROPT) +
                          VALUE(*ADD))
             ELSE       CMD(CHGVAR VAR(&MBROPT) VALUE(*REPLACE))


       IF         COND(&FIELDNAMES) THEN(DO) /* Fieldnames */

             DSPFFD     FILE(&FROMLIB/&FROMFILE) OUTPUT(*OUTFILE) +
                          OUTFILE(QTEMP/FIELDNAMES)

             OVRDBF     FILE(QADSPFFD) TOFILE(QTEMP/FIELDNAMES)

 NEXT:       RCVF
             MONMSG     MSGID(CPF0864) EXEC(GOTO CMDLBL(EOF))

             IF         COND(&NOT_FIRST) THEN(CHGVAR VAR(&ST) +
                          VALUE(&ST *TCAT &COMMA))
             CHGVAR     VAR(&NOT_FIRST) VALUE('1')

             IF         COND(&WHALIS *NE ' ' *AND &ALIAS) THEN(DO)
             CHGVAR     VAR(&ST) VALUE(&ST *TCAT &DBLQUOTE *CAT +
                          &WHALIS *TCAT &DBLQUOTE)

             ENDDO
             ELSE       CMD(DO)
             CHGVAR     VAR(&ST) VALUE(&ST *TCAT &DBLQUOTE *CAT +
                          &WHFLDI *TCAT &DBLQUOTE)
             ENDDO

             GOTO       CMDLBL(NEXT)

 EOF:        DLTF       FILE(QTEMP/FIELDNAMES)

             CRTPF      FILE(QTEMP/PF1024) RCDLEN(1024)
             OVRDBF     FILE(PF1024) TOFILE(QTEMP/PF1024)
             CALL       PGM(WRTPF1024) PARM(&ST) /* Call the RPG +
                          program */

             CPYTOSTMF  +
                          FROMMBR('/qsys.lib/qtemp.lib/pf1024.file/pf+
                          1024.mbr') TOSTMF(&TOSTMF) +
                          STMFOPT(*REPLACE) STMFCODPAG(*PCASCII) +
                          ENDLINFMT(*CRLF)

             DLTF       FILE(QTEMP/PF1024)

       ENDDO      /* Field names */

             CPYTOIMPF  FROMFILE(&FROMLIB/&FROMFILE &FROMMBR) +
                          TOSTMF(&TOSTMF) MBROPT(&MBROPT) +
                          STMFCODPAG(*PCASCII) RCDDLM(*CRLF) +
                          DTAFMT(*DLM) STRDLM(&DBLQUOTE) +
                          FLDDLM(&COMMA) DECPNT(*PERIOD)

 END:        ENDPGM

   /*   The parameter  STMFCODPAG(*PCASCII)  can be added          */
   /*   on the CPYTOIMPF command starting from release V5R1.       */
   /*   The file is useless for EXCEL if not in ASCII format.      */
   /*   The FLDDLM (field delimiter) and DECPNT (decimal point)    */
   /*   parameters must correspond with the settings on your PC.   */
   /*   Check via :                                                */
   /*      Start, Control Panel, Regional Settings, Number         */
   /*      and verify the "decimal symbol" and "list separator"    */
   /*      settings.                                               */
   /*      f.e. in Belgium you must code :                         */
   /*                     FLDDLM(';') DECPNT(*COMMA)               */


   /*   To make the EXCEL file available to your PC :              */
   /*                                                              */
   /*   1)  You can FTP the file in the IFS to your PC             */
   /*                                                              */
   /*   2)  You can  share the directory in the IFS via            */
   /*       Operations Navigator.                                  */
   /*       (Check that the Netserver is started and configured.)  */
   /*       On the PC you can map the shared directory to a drive  */
   /*       letter. Example :                                      */
   /*       net use  x:  \\as400netservername\sharename            */


     H*****************************************************************
     H*
     H*  Program :   WRTPF1024
     H*
     H*  Add a record to file PF1024
     H*
     H*
     H*  To compile :
     H*
     H*        CRTRPGPGM  PGM(XXX/WRTPF1024) SRCFILE(XXX/QRPGSRC)
     H*
     H*****************************************************************
     FPF1024  O   F    1024            DISK                      A
     IOUTREC      DS
     I                                        1 256 PART1
     I                                      257 512 PART2
     I                                      513 768 PART3
     I                                      7691024 PART4
     C           *ENTRY    PLIST
     C                     PARM           OUTREC
     C                     WRITEPF1024    OUTREC
     C                     MOVE *ON       *INLR


Thanks to Herman Van der Staey
Back

Cleanup IFS

Q:
I have a TEMP folder on the IFS that is used by various utilities to create
extracts/reports in various formats (PDF, CSV, TXT, etc), these files are
usually downloaded right away or at the very least within 24 hours via a
user submitting a job to send them. I want to delete (almost) everything in
the TEMP folder that is older than a week. Is there a command or utility
that I can use to do this?

A: Use QShell's find command. QShell is a unix-like shell that's included on your OS/400 CDs, and costs nothing if you already have OS/400. In QShell the FIND utility is used to locate files with certain attributes in the directory structure. So the following would find all of the files that haven't been accessed in 7 days in the /tmp/reports directory (or any of it's subdirectories): find /tmp/reports -atime +7 -print The output of one QShell command can be converted to parameters that are added on to the end of another command. This is done by piping the output to the xargs program. find /tmp/reports -atime +7 -print | xargs rm -rf So, if find woud list "file1.pdf" "file2.pdf" "file3.pdf" then xargs would build & run a command string that says: rm -rf file1.pdf file2.pdf file3.pdf The "rm" command is the Unix command for deleting (removing) a file. every parameter you pass to it will be deleted. The only problem with this code is that there's a limit to the size of a single command-line in QShell. In V5R3 they expanded that limit dramatically, but it was a sharp limitation in older releases. If instead of using XARGS, you can have the FIND utility delete each file individually: find /tmp/reports -atime +7 -exec rm -rf {} \; FIND will take everything between the "-exec" and the "\;" and it'll use it as a command. It'll replace {} with the name of the file, and it'll run the command. So, in this case, it'll run "rm -rf file1.pdf" then, it'll run "rm -rf file2.pdf" and so on for every file that it finds. This solution is MUCH slower than the XARGS one because it has to submit a new job to run a new command for every single filename, whereas XARGS ran all of the filenames in one job. But XARGS had that sharp limitation for the size of a single command line. Note that any of these commands can be run from a CL program. For example: STRQSH CMD('find /tmp/reports -atime +7 -exec rm -rf {} \;') In fact, if you're more comfortable with CL (as I suspect most iSeries people are) it might make sense to use QShell to write the filenames to a file, then you can process that file from CL. CRTPF MYLIB/MYFILE RCDLEN(1000) STRQSH CMD('find /tmp/reports -atime +7 -print > + /QSYS.LIB/MYLIB.LIB/MYFILE.FILE/MYFILE.MBR') Now you have a file called MYFILE that contains the list of files. You can delete them: LOOP: RCVF MONMSG CPF0864 EXEC(CHGVAR &DONE VALUE('1')) IF (&DONE *NE '1') DO RMVLNK OBJLNK(&MYFILE) GOTO LOOP ENDDO I'm pretty sure that I've explained all of this on this list several times, so please check the mailing list archives for more info. http://archive.midrange.com Thanks to Scott Klement

Back

SNADS over TCP/IP

Pam Phillips has written this nice document:

A Quick Guide to Setting up SNADS on the AS/400
It's a PDF document - click here to download (revised 2005-10-11).
Thanks to Pam Phillips
Back

Quick intro to ILE

A statement after a question:
The only thing I'm worried about is binding and subprocedures, never used them.

The introduction:
For me, the most difficult part about ILE (not RPG IV) was getting over my fear of the
unknown and working with it. Here is a suggestion for a possible self-education on ILE:

1) Write a program that contains a subprocedure and code to test that subprocedure. Use
a simple subprocedure - say one that takes 2 numbers as input, adds them and returns the
result. The one change from OPM you'll need to make is to tell the compiler to use an
activation group. I use an H spec so I don't have to fiddle with the compile options every time.
H dftactgrp(*no) actgrp('QILE')

2) Test the procedure with several test cases. Use the test cases in the main line code
to exercise the procedure and compare the results to what you expected to get.
Something like:
eval first = 2
eval second = 10
if addNum(first: second) <> 12
  'not 12' dsply
endif

3) Create a source file to hold your prototypes. I call mine QPROTOSRC. RECL=112. Copy
the PI specs from your program to QPROTOSRC. This is the genesis of your service program.
Since your service program will be something dealing with math, let's call it MATH.
The result will be a single member called MATH in QPROTOSRC that will have the D specs
forming the PI part of your addNum procedure

4) Edit the program (or make a new version) that omits the PI part. Instead, substitute
/copy qprotosrc,math. Compile and test. Your test cases should work as before.

5) Create a new source member in QRPGLESRC called MATH. This is the step where we'll
create a service program. Copy all of the PR code (from P...b to P...e specs) from the
main line of the program. You'll need a prototype, so don't forget the /copy qprotosrc,
math at the top, above the PR. One other thing. Put in H nomain and leave out the bit
about the activation group.

6) Create an RPG module out of MATH. CRTRPGMOD. If you want to be able to debug this,
don't forget DBGVIEW(*LIST).

7) Create binder source. Source PF QSRVSRC, recl=92. Add a member called MATH (same as
the service program). Create the initial binder language by using RTVBNDSRC. Fill in
the module name but not the service program (it hasn't been created yet!) Edit QSRVSRC
member MATH,  I like to use my own signature in the form of:
STRPGMEXP PGMLVL(*CURRENT) SIGNATURE('1.00 15 Aug 03')
Try that. You may prefer a simpler scheme using just a single signature like your company
name.

8) Create a service program out of the MATH module. CRTSRVPGM. This is important: don't
use EXPORT(*ALL) Use *SRCFILE! The idea is to use our binder language and not let the
system generate a signature on its own.

9) Create a binding directory. CRTBNDDIR. I use a single BNDDIR for the whole company.
It's as good a place to start as any. Let's call it BUCK for this example (it's unique
enough...)  Add a binding directory entry for your service program. I have a strong
tendency to use *LIBL.

10) Edit the program (or create a new member). Delete all of the PR specs and add an
H spec for the binding directory. H bnddir('BUCK') Compile your program. The compiler
will search the library list for binding directory BUCK. When it finds BUCK, it will
look inside each of the service programs in there (only one now) to find PR specs for
addNum (not true, but close enough description for now.)

11) Run your program. The test cases should work as before. Now, all your mainline code
has is a /copy and the code that uses addNum! Your very first service program.

That should get you started. The next steps (no time to post now) involve changing addNum
and adding a new procedure (subNum?) to the MATH service program. I'll try to post the
next steps soon.

Thanks to Buck Calabro
Back

What is the HEX key for ??

Al Macintyre sent me this:

Notice the HEX key ... Alt Help on my keyboard ... varies other.

What this can be used for is to get at neat combinations not on our keyboards ... what characters are available ... well remembering that the hexadecimal number system is base 16 so the "digits" of that system 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 are 0 1 2 3 4 5 6 7 8 9 A B C D E F and that a letter is identified as combination of 2 consecutive "digits" of the system, with some limitations. We can create a chart of what is available as a reference of what we might like to use in some circumstances.

¿ = Alt Hex then upper case A B Careful - when using upper row digits - lower case there £ = Alt Hex then upper case B lower case 1 ¥ = what John Young would call a "bug"

Down the side will be the first "digit" used in the hexadecimal system and along the top will be the second "digit" used & in the coordinates will be the character that we get using the Alt Hex system, then subsequently I could cut & paste the resulting character into some other location such as a program, without having to go through these steps to extract the neat stuff. This chart will also be shared with folks who might like to incorporate some of these characters other places like in messages for starters.

0 1 2 3 4 5 6 7 8 9 A B C D E F 0 0 is not valid as starting point 1 1 is not valid as starting point 2 2 is not valid as starting point 3 3 is not valid as starting point 0 1 2 3 4 5 6 7 8 9 A B C D E F 4   â ä à á ã å ç ñ ¢ . < à D + | 5 & é ê ë è í î ï ì ß ! $ * ) ; ¬ 6 - / Â Ä À Á Ã Å Ç Ñ ¦ , % _ > ? 7 ø É Ê Ë È Í Î Ï Ì i : # @ ' = " 8 Ø a b c d e f g h i « » ð ý þ ± 9 ° j k l m n o p q r ª º æ ¸ Æ ¤ A µ ~ s t u v w x y z ¡ ¿ Ð Ý Þ ® B ^ £ ¥ · © § ¶ ¼ ½ ¾ [ ] ¯ ¨ ´ × C { B A B C D F G H I ­ ô ö ò ó õ D } J K L M N O P Q R ¹ û ü ù ú ÿ E \ ÷ S T U V W X Y Z ² Ô Ö Ò Ó Õ F 0 1 2 3 4 5 6 7 8 9 ³ Û Ü Ù Ú FF is not a valid Alt Hex combination 0 1 2 3 4 5 6 7 8 9 A B C D E F Editor's note: Tried some of the x'values' on my system. Used to send E-mail from my terminal, before I got an PC. Remembered the @-sign was x'80'. In the above codes it's x'7C', so dont depend your work on these codes. Could be the CCSID code.
Btw: I made a program to show the values, get the SAVF here.

If you are the owner of a very very ol' terminal, you can get them this way: Stay on the Sign On screen Use Alt + Play Select option 1, then Select option 2, and voila.... here they are :-)


Brian Johnson came up with another solution Here's a REXX program that displays a character chart... /* Write a character chart to STDOUT */ line = ' ' line2 = ' ' do col = x2d(0) to x2d(F) by x2d(1) line = line '-'d2x(col) line2 = line2'---' end say line say line2 do row = x2d(40) to x2d(f0) by x2d(10) line = d2x(row/x2d(10))'-:' do col = 0 to x2d(F) line = line d2c(row+col)' ' end say line end /* End */ Paste this little program into a source file member, then whenever you need to copy an off-keyboard character run... STRREXPRC SRCMBR(mbr-name) SRCFILE(src-lib/src-file)

Thanks to Al Macintyre and Brian Johnson

Back

Difference between CPF0000 and CPF9999

Q:
Can anybody explain the difference between CPF0000 and CPF9999 error handling.
Both are used for default error handling....Is there any difference between these two?

A: First, you can monitor for a specific message, e.g.: MONMSG MSGID(CPF9801) Or you can monitor for a list of specific messages, e.g.: MONMSG MSGID(CPF9801 CPF9802 CPF9810) Next, you can monitor for a whole group of related messages, using a "generic" designation such as: MONMSG MSGID(CPF9800) -- this will trap any message that begins with CPF98xx. Next, you can monitor for a truly generic message, such as: MONMSG MSGID(CPF0000) -- this will trap any message that begins with CPFxxxx. -- typically this is used in a "global message monitor" statement at the start of the program, e.g.: MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO ERROR) For these message IDs to be considered a "generic pattern" it must end in "00" or "0000". Finally, it is my understanding that, if a CPF message occurs and is not "handled" in the CL program, in other words, there was no active MONMSG that matched the message ID either exactly or as a generic pattern, then it is converted into a CPF9999 and that exception is raised ... so you can also monitor for CPF9999. But, due to this extra processing that occurs before it is converted to CPF9999, you may get additional messages, such as the one that tells you there was an unhandled exception and asks if you want a "dump" etc. At least, that's my understanding or interpretation of "how it all works"

Thanks to Mark S. Waterbury

Back

V5R4 - "patched" or "system state" programs

I thought this last paragraph was very interesting.
.....
Finally, if you are running so-called "patched" or "system state" programs,
like the old Fast400 governor buster, V5R4 is not going to let you do this
any more. As part of the security enhancements in i5/OS, the software will
not let programs go down into the microcode layer anymore. By letting
independent software vendors do this, IBM left itself open to the whole
Fast400 debacle and also left open a potential security risk on its AS/400,
iSeries, and i5 servers. Now, that hole is plugged. Jarman was kind in
describing why this was happening, and he didn't bring up Fast400, which
has gone out of business after its founder settled a lawsuit with IBM late
last year. "There were some ISVs who wrote in microcode for good reasons,
and we have been helping them with APIs so they are not disrupted by this
change."
http://www.itjungle.com/fhs/fhs013106-story02.html
.....

I have worked up a quick program that should be run before upgrading to
v5r4 to recognize these programs.

      *===============================================================
      * To compile:
      *
      *      CRTBNDRPG  PGM(XXX/CHKPGMST) SRCFILE(XXX/QRPGLESRC)
      *
      * Most all code borrowed from
      * http://www.mcpressonline.com/mc?1@167.ti8lcaLfqR2.0@.214a28e3
      *
      *     This is needed to see if programs will work on V5R4
      *
      *       to run call with library name or *ALL or *LIBL or *ALLUSR
      *===============================================================
     h  dftactgrp(*no) actgrp('QILE')

     fQsysprt   o    f  132        printer oflind(*inof)

     d CrtUsrSpc       PR              *
     d  CrtSpcName                   20

     d GetPgmInf       PR              *
     d  InLib                        10    const
     d  InPgm                        10    const

     d ActionCode      S              1
     d InLib           S             10
     d ListFormat      S              8
     d No              C                   '0'
     d ObjNamLIb       S             20    inz('*ALL      *LIBL    ')
     d ObjType         S             10
     d TotOut          S              7  0
     d UserSpace       S             20    inz('PGMSTATE  QTEMP')
     d x               S              1  0

     d PgmData         DS           502    based(pPgmData)
     d  PgmOwner              29     38
     D  PgmAtr                39     48
     D  PgmObsrv             105    105
     d  PgmText              111    160
     D  PgmType              161    161
     d  PgmState             253    253
      *          PgmState   I= inherits  S= System State U= User State
     d  EarliestRel          268    273
     d  PgmDomain            304    304
      *          PgmDomain   S= System  U= User
     d  ActGroup             473    502

     d QusH0300        DS                  Based(pGeneralDs)
     d  QusIS00              104    104
     d  QusOlD00             125    128B 0
     d  QusNbrLE00           133    136B 0
     d  QusSEE00             137    140B 0

     d QusL010003      DS                  based(p100)
     d  QusObjNU               1     10
     d  QusOLNU               11     20

     d QusEC           DS           116
     d  QusBPrv                1      4B 0          inz(116)
     d  QusBAvl                5      8B 0

     c     *entry        Plist
     c                   Parm                    InLib
     c                   move      InLib         ObjNamLib
      *  Create user space for object list information
     c                   Eval      pGeneralDs = CrtUsrSpc(UserSpace)
      *  List programs to user space
     c                   Call      'QUSLOBJ'
     c                   Parm                    UserSpace
     c                   Parm      'OBJL0100'    ListFormat
     c                   Parm                    ObjNamLib
     c                   Parm      '*PGM'        ObjType
     c                   Parm                    QusEc
      *  If the list API was complete or partially complete
     c                   if        QuSIS00 = 'C' OR QuSIS00 = 'P'
      *  Load the list data structure
     c                   Eval      p100 = pGeneralDs + QusOLD00
      * Print heading
     c                   except    Headng
     c                   Do        QusNbrLE00
     c                   eval      pPgmData = GetPgmInf(QusOlNu:QusObjNu)
      *  Determine whether or not to print
     c                   if        PgmState =  'S'
     c                   except    Detail
     c                   eval      TotOut = TotOut + 1
     c                   endif
     c                   Eval      p100 = p100 + QusSEE00
     c                   enddo
     c                   endif
     c                   except    Total
     c                   eval      *inlr = *on

     oQsysprt   e            Headng         2 02
     o         or    of
     o                                            5 'DATE:'
     o                       Udate         y     14
     o                                           64 'List System State Programs'
     o                                          121 'Page:'
     o                       Page          z    127
     oQsysprt   e            Headng         1
     o         or    of
     o                                           22 'Program   Library'
     o                                           30 'Release'
     o                                           60 'State-Domain-Obsv-Attrib'
     o                                           70 '      '
     o                                           85 'Owner      Text'
     oQsysprt   ef           Detail         1
     o                       QusObjNu            10
     o                       QusOLNu             22
     o                       EarliestRel         30
     o                       PgmState            39
     o                       PgmDomain           45
     o                       PgmObsrv            52
     o                       PgmAtr              65
     o                       PgmOwner            80
     o                       PgmText            131
     oQsysprt   ef           Total       2  2
     o                                           24 'Total Programs..........'
     o                       Totout        1     44
      *
      *  Procedure to create user space, return pointer to it.
      *
     P  CrtUsrSpc      B                   export
     d  CrtUsrSpc      PI              *
     d   PasSpcName                  20

     d ListPtr         S               *
     d SpaceAttr       S             10    inz
     d SpaceAuth       S             10    INZ('*CHANGE')
     d SpaceLen        S              9B 0 INZ(2048)
     d SpaceReplc      S             10    INZ('*YES')
     d SpaceText       S             50
     d SpaceValue      S              1

      * Create the user space
     c                   call      'QUSCRTUS'
     c                   parm                    PasSpcName
     c                   parm                    SpaceAttr
     c                   parm                    SpaceLen
     c                   parm                    SpaceValue
     c                   parm                    SpaceAuth
     c                   parm                    SpaceText
     c                   parm      '*YES'        SpaceReplc
     c                   parm                    QusEc
      * Get pointer to user space
     c                   call      'QUSPTRUS'
     c                   parm                    PasSpcName
     c                   parm                    ListPtr
     c                   return    ListPtr
     P  CrtUsrSpc      E
      *
      *  Procedure to retrieve activation group of the program
      *
     P GetPgmInf       B                   export
     d GetPgmInf       PI              *
     d  InLib                        10    const
     d  InPgm                        10    const
     d PgmReceive      DS           502
     d FormatName      s              8
     d PgmAndLib       s             20
     d ReceiveLen      S             10i 0

     c                   Eval      PgmAndLib = InPgm + InLib
     c                   Call      'QCLRPGMI'
     c                   Parm                    PgmReceive
     c                   Parm      502           ReceiveLen
     c                   Parm      'PGMI0200'    FormatName
     c                   Parm                    PgmAndLib
     c                   Parm                    QusEc
     c                   return    %addr(PgmReceive)
     P GetPgmInf       E

Thanks to Bryan Dietz

Comments from us.ibm.com:
IBM does not support the ability to enter system state from an application
program.  System state programs are patched (or altered) programs.  IBM
has long advised customers to not use patched programs as they can cause
unintended results including system crashes, data reliability issues and
other problems.  Indeed, IBM is aware of a number of customers that have
used patched programs (whether system state or not) that resulted in a
system crash, sometimes at critical times for the customer.

IBM believes patched programs may perform functions reserved for LIC and
i5/OS.  This interaction requires an intimate knowledge of LIC and i5/OS
by the developer of the product - information that includes trade secrets
of IBM and is not published by IBM.  IBM believes developers of such
patched programs may not fully understand all these interactions and
consequences of such a patched program nor the implications of how such
patched programs may affect the license agreements IBM has with its
customers.

Having said that, you are correct.  The specific changes that I was
referring to are not in V5R4.  However, there were a number of changes in
V5R4 that improved protection of LIC and i5/OS.  And while many companies
were involved in the early program offerings for V5R4, none has reported
problems (that I'm aware of) related to these V5R4 changes.

Thanks to Bruce Vining
Back

Page #3     Page #5

Back