|
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
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
Found this article written by Joel Cochran for IT Jungle …
Thanks to Joel Cochran & IT Jungle
|
|
Back
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
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
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
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
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
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
