|
iSeries Access - Block Cursor in .ws File
| |
Q: Anyone know the stanza and parameter for specifying a block cursor in a
Client Access .ws file?
A: Hope this is what you want:
In the .ws look for the [Window] section. If it's not there simply add it.
Add one of the following under this section depending on the need:
For a cursor line not blinking insert this: SessFlags=38C4A
For a cursor line blinking insert this: SessFlags=3884A
For a cursor block not blinking insert this: SessFlags=38C42
For a cursor block blinking insert this: SessFlags=38842
Thanks to Pat Landrum
|
|
Back
|
International Support with UTF-8
| |
Setting up your environment for UTF-8
-------------------------------------
I write this because I have been working a lot with UTF-8 during the years and because
the CCSID problem seems pop-up rather frequently in some groups.
The world is moving towards UTF-8 and ... if you don't believe me just take a look at
this google graph:
http://www.w3.org/QA/2008/05/utf8-web-growth.html
The obvious reason for that is that the world is more global than ever and webpages and
software should be able to run in many languages and not only in languages supported by
Latin-1(iso-8859-1 or 1252).
When running CGIDEV2 it's rater simple to set the apache server up to translate from
EBCDIC and respond correctly in UTF-8.
There are two server directives:
CGIConvMode %%EBCDIC/EBCDIC%%
DefaultNetCCSID 1208
The first tells the Apache that it has to communicate with the CGI program in EBCDIC in
the CCSID the program is running under (job CCSID).
The second tells the Apache to always translate the EBCDIC to UTF-8 when it sends out
anything from the CGI programs.
However there is a problem. In all our communication in CGI HTTP we have to tell in the
first line what is comming so the client knows what to do:
Content-type: text/html
What actual happens is that the Apache will append the encoding, so what is send is:
Content-type: text/html; charset=UTF-8
If you already has appended the charset attribute in your code things will go wrong if
the charset specified isn't corresponding to the server setting !
So don't put charset attributes in your CGI html documents content-type header.
Another thing is that many tends to think that iso-8859-1 (that are the apache default CCSID)
is the same as CCSID 1252.
It's NOT ! This is a table of unsupported char's in iso-8859-1 vs. 1252:
Windows Unicode Char.
char. HTML code test Description of Character
----- ----- --- ------------------------
ALT-0128 € € euro
ALT-0130 ‚ ‚ Single Low-9 Quotation Mark
ALT-0131 ƒ ƒ Latin Small Letter F With Hook
ALT-0132 „ „ Double Low-9 Quotation Mark
ALT-0133 … … Horizontal Ellipsis
ALT-0134 † † Dagger
ALT-0135 ‡ ‡ Double Dagger
ALT-0136 ˆ ˆ Modifier Letter Circumflex Accent
ALT-0137 ‰ ‰ Per Mille Sign
ALT-0138 Š Š Latin Capital Letter S With Caron
ALT-0139 ‹ ‹ Single Left-Pointing Angle Quotation Mark
ALT-0140 ΠΠLatin Capital Ligature OE
ALT-0145 ‘ ‘ Left Single Quotation Mark
ALT-0146 ’ ’ Right Single Quotation Mark
ALT-0147 “ “ Left Double Quotation Mark
ALT-0148 ” ” Right Double Quotation Mark
ALT-0149 • • Bullet
ALT-0150 – – En Dash
ALT-0151 — — Em Dash
ALT-0152 ˜ ˜ Small Tilde
ALT-0153 ™ ™ Trade Mark Sign
ALT-0154 š š Latin Small Letter S With Caron
ALT-0155 › › Single Right-Pointing Angle Quotation Mark
ALT-0156 œ œ Latin Small Ligature OE
ALT-0159 Ÿ Ÿ Latin Capital Letter Y With Diaeresis
Other text types of IFS files that is simply referred to in the IFS will be added a
content-type according to the filetype and for some a charset according to the IFS file's CCSID.
When a client recieves the header, the characterset specified there is the one that is used and
you can write whatever you want in meta tags, it is ignorred by most.
What do you achive by shifting to UTF-8, well, several things:
1. Any EBCDIC (also ccsid 37) will always be encoded correctly in the browser, no more work arounds
to try to fit something into latin-1. Hebrew and arabic char's is also supported.
2. More and more pages is served out with javascript included in the CGI script. Javascript must
have UTF-8 encoding in any constant strings that are passed, this means that any special characters
that dosn't have the same binary value in iso-8859-1 and UTF-8 has to be encoded in \u0000 sequences.
By chosing UTF-8 this encoding problem will go away.
3. Forms submitted back is encoded in UTF-8, so there will be no problem of translating a form to
the corresponding EBCDIC code page.
But here is also a little problem .... AJAX !!!
AJAX works differently not only from browser to browser, but also from version to version.
If you set the Content-type in the request header, there is no way to know what charset that is
appended, if any.
Sometimes the charset=UTF-8 is forced and sometimes the charset=iso-8859-1/1252 is forced and
sometimes the charset is taken from the pages content-type statement.
But you have always to make the encoding to what is send:
If you want to send iso-8859-1 the best way to ensure the the content-type header correspond to
what is actual send is to encode your URL with the encode instruction:
... var poststr = '?strXML=' + escape(xmlStr);
... poststr = poststr.replace(/\+/g,"%2B"); // Regex that handles char'+' in strings
and then set the charset in the ajax request
http_request.setRequestHeader("Content-type",
"application/x-www-form-urlencoded"; charset="iso-8859-1");
If you want to send UTF-8, you use an URI instead of an URL (an URL is actual an URI that is
escaped (latin1) in stead of UTF-8 that is the standard for URI's.
... var poststr = '?strXML=' + encodeURIComponent(xmlStr);
http_request.setRequestHeader("Content-type", "application/x-www-form-urlencoded"; charset="UTF-8");
Some other considerations in international development:
-------------------------------------------------------
EBCDIC is the worst character set in the world. While ASCII, ANSI and UTF-8 shares binaries on the
first 128 characters, you can only be sure that EBCDIC shares binary representation on a-z A-Z 0-9
and a couple of others (blank x'40') etc. and that only refferes to SBCS not DBCS.
So a test in a program for constant "@" will not work if it is done in a program compiled with
CCSID 277 (danish) and run on a database with CCSID 37 (us), because they have two different binary
representations.
And because the program's CCSID is set by the CCSID of the sourcefile it isn't just enough to
recompile.
Fortunately a CCSID translation is done when a sourcemember is copied from one source file to
another and most packages (CGIDEV2 etc.) does this copying in the installation procedure.
But it's always a good thing to check that the source file has the CCSID that corresponds to the
database and other programs it has to run with.
Dragging and dropping text files from your PC to the IFS with Windows XP and Client Access.
Many international javascript (like Ext JS) comes with some language specific files. Files that are
created by many users all over the world.
Some of these files are in CCSID 1252 and some are in CCSID 1208.
By dragging them from your PC to the IFS they will all become CCSID 1252 but UTF-8 files will still
have the binary UTF-8 encoding inside them.
When such a file is send from the IFS and recieved by the browser, apache has added a content-type
with the file CCSID and that gives unpredicteble results because the CCSID don't correspond to the
actual encoding of the content.
The way to correct this is NOT to copy the file in the IFS but just to change the CCSID:
CHGATR OBJ('/test.js') ATR(*CCSID) VALUE(1208)
The same goes for files created by ex. Notepad++ in UTF-8 (that should be without BOM (Byte Order
Mark)) on the PC and draged and dropped to the IFS.
New format's in web developing:
-------------------------------
At one time or antother the "new" format, JSON will appear in CGIDEV2 development, and that's another
reason to shift to UTF-8, for there is no such thing as iso-8859-1 or 1252 support in JSON.
JSON goes untranslated into javascript objects and javascript object run's not by default but
always in UTF-8, and this cannot be changed by any settings.
I hope with this - I have given your an idear of how easy it is to change to UTF-8 and where some of
the problems may be.
Thanks to Henrik Rützou
|
|
Back
> A single hard coded signature works just as well for backward
> compatibility as long as you don't mess with the procedure sequence.
Just to add to that (because I think this is a common point of confusion) *CURRENT/*PRV _also_
requires that you don't mess with procedure sequence.
If you make a mistake with your procedure sequence with _either_ a hard-coded signature _or_
*CURRENT/*PRV the ILE environment won't catch it.
I'm sure you already know how this works, but I suspect there are others that do not,so I'm
going to give a more detailed example:
STRPGMEXP PGMLVL(*CURRENT)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
ENDPGM
The important thing to understand is that ILE calls things by NUMBER. It looks at the above set
of procedures, and assigns a number to each (based on the order they are listed in the binder
source). So startSomething=1, doSoemthing=2, finishSomething=3. Under the covers, your programs
will be calling them by number... call export#1, call export#2, etc.
As a side note: The sequence of the procedures in your RPG source member doesn't matter AT ALL.
The export numbers are calculated purely from the binder source (above), not from the source member.
Now you decide to add a new procedure, and WHOOPS, you add it in the middle instead of the end:
STRPGMEXP PGMLVL(*CURRENT)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(doSomethingMore) <--- WHOOPS! it's in the middle.
EXPORT SYMBOL(finishSomething)
ENDPGM
STRPGMEXP PGMLVL(*PRV)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
ENDPGM
IMHO, if ILE were designed correctly, the CRTSRVPGM command would detect that finishSomething
has changed from position #4 to position #3 and would warn you. But it doesn't. Existing
programs that previously called finishSomething were doing "call export#3". And unless you run
UPDPGM or UPDSRVPGM or recreate them completely, they will continue to do "call export#3" --
the problem is, export#3 is no longer the "finishSomething" routine, now it's "doSomethingMore"
and you're calling it by mistake! WHOOPS!
You're probably thinking "shouldn't I get a signature violation error?" no. you won't, because
of the *PRV group. The *PRV group will have the signature you were previously using... so it
will let you call it without error. However, *only* the *CURRENT group is used to determine
the export numbers. So the fact that finishSomething *used* to be #3 doesn't matter, the system
won't detect that it has changed, and it'll let you keep calling #3.
So using *CURRENT/*PRV didn't protect you. I'm still wondering under what situation using
*CURRENT/*PRV *would* protect you? I haven't found any situation where it would.
The *ONLY* way for this to work properly is to do this:
STRPGMEXP PGMLVL(*CURRENT)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
EXPORT SYMBOL(doSomethingMore) <--- HURRAY! it's on the end.
ENDPGM
STRPGMEXP PGMLVL(*PRV)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
ENDPGM
This way, your existing exports aren't renumbered, finishSomething is still export#3. As long as
you know this and do it consistently, this will give you backward compatibility. But if you mess
it up, it won't catch it. So you're doing the (admittedly minor) work of copying the signature
block, and getting no protection for your efforts.
My problem is that after I've done this 500 or so times (I'm not exaggerating -- I really do this
500+ times in some srvpgms) you end up with a large, unwieldy source member. That is the part that
"drives me crazy." That's perhaps too strong of a term -- but it was deterring me from adding more
subprocedures. It didn't make sense to "add just one more procedure" because I'd have to copy the
block, so I'd end up putting it off until I had lots of them to add so I could do it all at once
and have fewer signature blocks. This wasn't good because it was holding me back.
Let's look at a hard-coded signature (my recommendation):
Back to the original example, before the change you have the following, the only difference now is
that I've added a hard-coded signature:
STRPGMEXP SIGNATURE('SRVPGM SIG 1.0 ')
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
ENDPGM
(I'm careful to make my signature 16 chars long, otherwise I get annoying warning messages when I
build my srvpgm. It's not required -- I just do it to avoid the extra warning messages.
If, WHOOPS, I make a mistake (just as I did with *CURRENT/*PRV) and put it in the middle, I still
have the same problem
STRPGMEXP SIGNATURE('SRVPGM SIG 1.0 ')
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(doSomethingMore) <--- WHOOPS! it's in the middle.
EXPORT SYMBOL(finishSomething)
ENDPGM
This creates the exact same problem it did with *CURRENT/*PRV, and exactly like *CURRENT/*PRV
the system won't detect it. So I haven't lost anything by switching to a hard coded signature.
The only thing I've gained is that I don't have to copy/paste my signature block.
Just as with the *CURRENT/*PRV method, if I want to do it correctly, I have to put it on the end:
STRPGMEXP SIGNATURE('SRVPGM SIG 1.0 ')
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(finishSomething)
EXPORT SYMBOL(doSomethingMore) <--- HURRAY! it's on the end.
ENDPGM
Now i've achieved compatibility. My existing callers will work. I don't have to run UPDSRVPGM or
UPDPGM, since the export numbers didn't change, and the signature didn't change. Complete backward
compatibility. Exactly the same as the *CURRENT/*PRV solution, except that I don't have to copy the
signature block.
Now what happens if I *want* to break compatibility? Let's say I'm making a change to my service
program that I know won't be compatible, and I want make sure that every caller gets recreated.
If it doesn't get recreated, I *want* it to fail with a signature error.
With *CURRENT/*PRV, you'd do that by deleting all of the *PRV blocks. Simply eliminate every single
*PRV block so all you have is a *CURRENT block.
STRPGMEXP PGMLVL(*CURRENT)
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(doSomethingMore)
EXPORT SYMBOL(finishSomething)
ENDPGM
Now it doesn't matter that I put doSomethingMore in the middle, because all callers are going to
be rebuilt anyway. Again, the system didn't *detect* this for me, I had to TELL IT that I wanted
to break compatibility by deleting the *PRV blocks. IMHO, that's not a very intuitive way of
telling the system I want to force callers to re-bind -- but it does work.
To do the same thing with a hard-coded signature, I just change the version number in the signature.
STRPGMEXP SIGNATURE('SRVPGM SIG 1.0a ')
EXPORT SYMBOL(startSomething)
EXPORT SYMBOL(doSomething)
EXPORT SYMBOL(doSomethingMore)
EXPORT SYMBOL(finishSomething)
ENDPGM
That's (very slightly) simpler than deleting all of the *PRV blocks, and achieves the same thing.
But to me, changing a version number is more intuitive... I'm not sure it would've occurred to me
to delete all of the *PRV blocks if someone hadn't told me -- but changing the version I might've
thought of on my own. Also, when you use DSPPGM or DSPSRVPGM on the caller, you'll be able to see
exactly which version it's using in a human-readable string.
Ugh.. I've turned this e-mail into an article. Sorry for the length.
> Does anyone have any suggested added benefits to the *CURRENT/*PRV
> technique that would suggest that we would be better to stick with it?
I've had many discussions online about this topic, and I've asked the same question that you're
asking, Kevin. "Anyone know any advantages to *CURRENT/*PRV." I've received many responses --
unfortunately, all but one of them were based on a misconception of the protection *CURRENT/*PRV
provides.
The one that did make sense pointed out something you already mentioned: you can see a history in
your source member. There's at least one shop out there that uses this for documentation purposes.
("This program program requires version 1.4 of product XYZ or later." "I know that because it's
calling procedure ABC that was added in the 6th signature block")
But, as far as compatibility or protection against mistakes, *CURRENT/*PRV doesn't provide any.
(Though, *CURRENT by itself does...)
Another point: If you look at all of the IBM srvpgms, you'll see that they hard-code all of their
signatures. (I don't know if that means it's a good thing or a bad thing... heh)
Thanks to Scott Klement
|
|
Back
|
Files used and/or created by queries
| |
Q: Is there any QSYS database or tool to help me find out files used or output within
a *QRYDFN object?
A: I used this program to extract what you want.
By this method, it can't change the used date of the query so if you want to know when a query
is effectively used it's always possible to know.
**-----------------------------------------------------------------------**
* AUTHOR: Credit for this tool should be given to
* - Gary Guthrie, author of the MI version of the retrieval itself
* - Carsten Flensburg, who wrote the RPG IV version of the tool
* and me, - Antonio Fernandez-Vicenti, that only "dressed" the RPG version
* to read from a list of Object descriptions, extract the info
* and write to an output file.
* Good luck to all users !
**-----------------------------------------------------------------------**
*
* QRYOBJD, the input file, can be built using
* DSPOBJD /*ALL *QRYDFN to a file, e.g. QTEMP/QRYOBJD
*
* QRYDFNF, the output file, should have the following external definition:
*
* R REG
* QRYNAM 10
* QRYLIB 10
* TEXTO 50
* TIP1 1
* TIP2 1
* OUTFIL 10
* OUTLIB 10
* REC 2562
*
* The program will read QRYOBJD file.
* For each record, it will search the Query definition,
* and write a REG record with the following data:
*
* QRYNAM : Query's Name
* QRYLIB : Library where the Query is
* TEXTO : Text of the Query...
* ...(it is taken from the QRYOBJD record, not from the Query itself)
* TIP1 : stands for type of output:
* 1=Display 2=Printer 3=File
* TIP2 : stands for type of Query:
* 1=Detail 2=Summary
* OUTFIL : Name of Output File (or blank)
* OUTLIB : Name of Library of the Output file
* REC : its 2562 bytes have the following structure:
*
* pos. 1-2 : a binary field which tells how many
* Input files come after
* pos. 3-2562 : an array of 32x80 bytes (32 is the
* maximum number of input files)
* For each possible input file, 80 bytes
* are provided.
* They include the file's Name, Library,
* Member and record, and some more data
*
* Note: If you built a Query to output to a file, and give it a name and
* library, and later on you change your mind and change the Query
* to output to Display or Print, the output's file and library are
* still present, and it will show in OUTFIL, OUTLIB above, even
* though the Query is now instructed to output to Display/Printer.
*
* Field TIP1 above should help to "disregard" the unwanted file.
*
*
* COMPILATION:
* When compiling the program you should provide
* the following parameters
*
* DFTACTGRP(*NO)
* BNDDIR(QC2LE)
*
* which were present in the original program as keywords in the H spec
* but I had to eliminate (we are stil at rel 4.1 ...)
* and give as parameters in the compilation.
*
**-- Header: -----------------------------------------------------------**
H
**-- File : -----------------------------------------------------------**
FQRYOBJD IP E DISK
FQRYDFNF O E DISK
**-- 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 3a
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 Ow1 5i 0
D Ow2 5i 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
D OutOut s 2a
*
**-- Parameters: -------------------------------------------------------**
D PxQryNam s 10a
D PxQryLib s 10a
**
**
**-- Mainline: ---------------------------------------------------------**
**
C move ODOBNM QRYNAM
C move ODOBNM PxQryNam
C move ODLBNM QRYLIB
C move ODLBNM PxQryLib
C move ODOBTX TEXTO
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( OutOut )
C : pQryTpl
C : %Size( OutOut )
C )
C movel outout outopt
C movel outout TIP1
C move outout TIP2
C move *blanks OUTFIL
C move *blanks OUTLIB
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 move OfFilNam OUTFIL
c move OfLibNam OUTLIB
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 1 do 32 Idx
C move *blanks IfFilInf(Idx)
C Enddo
C 1 do IfNbrFil Idx
C CallP MemCpy( %Addr( IfFilInf( Idx ))
C : pQryTpl
C : %Size( IfFilInf )
C )
**
C Eval pQryTpl = pQryTpl + %Size( IfFilInf )
C Enddo
c move *blanks rec
c Eval rec = QiInpFil
**
C WRITE REG
**
Thanks to Yannick Jacquelin
|
|
Back
|
Deleting client access 'auto-created' display devices
| |
Q: When our sys admin does the following command WRKCFGSTS *DEV IS*
she sees a bunch of devices and she would like to delete the ones with a status of 'VARIED OFF'.
In order to keep things cleaned up.
Is there an easy way to do this?
(other than by hand, ie taking option 8 then option 4)
A: Yes ... And it will speed up the process involved in starting up subsystem QINTER too !
Here is what I use ....
SOURCE FILE . . . . . . . SYSADMSRC/QPGMSRC
MEMBER . . . . . . . . . DLTVD
SEQNBR*...+... 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+...
100 /* ************************************************************** */
200 /* PROGRAM DESCRIPTION : */
300 /* */
400 /* THIS PROGRAM DELETES UNUSED VIRTUAL DEVICES */
500 /* */
600 /* SPECIAL COMPILE OPTIONS: */
700 /* */
800 /* WRITTEN BY: KEN GRAAP 08/28/98 */
900 /* UPDATED BY: 01/26/01 ADD QPACTL03 */
1000 /* UPDATED BY: KENNETH 07/18/06 ADD ADDITIONAL DSPOBJD*/
1100 /* COMMANDS */
1200 /* */
1300 /* ************************************************************** */
1400 PGM
1500 /* ************************************************************** */
1600 /* */
1700 /* DECLARE PROGRAM VARIABLES */
1800 /* */
1900 /* ************************************************************** */
2000 DCL &ERRORSW *LGL /* Std err */
2100 DCL &MSGID *CHAR LEN(7) /* Std err */
2200 DCL &MSGDTA *CHAR LEN(100) /* Std err */
2300 DCL &MSGF *CHAR LEN(10) /* Std err */
2400 DCL &MSGFLIB *CHAR LEN(10) /* Std err */
2500 DCLF FILE(KENNETH/DSPOBJWRKF) RCDFMT(QLIDOBJD)
2600 /* ************************************************************** */
2700 /* */
2800 /* GLOBAL MESSAGE MONITOR */
2900 /* */
3000 /* ************************************************************** */
3100 MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(STDERR1))
3200 /* ************************************************************** */
3300 /* */
3400 /* VARY OFF ANY VRT *DEVD'S NOT IN USE */
3500 /* GET NAMES OF ALL THE QPADEV* *DEVD'S */
3600 /* DELETE THE QPADEV* *DEVD'S THAT CAN BE DELETED. */
3700 /* */
3800 /* ************************************************************** */
3900
4000 VRYCFG CFGOBJ(QPACTL01) CFGTYPE(*CTL) STATUS(*OFF) +
4100 RANGE(*NET) ASCVRYOFF(*YES)
4200 MONMSG MSGID(CPF2659) /* Ignore "Incomplete" +
4300 message */
4400 VRYCFG CFGOBJ(QPACTL02) CFGTYPE(*CTL) STATUS(*OFF) +
4500 RANGE(*NET) ASCVRYOFF(*YES)
4600 MONMSG MSGID(CPF2659) /* Ignore "Incomplete" +
4700 message */
4800 VRYCFG CFGOBJ(QPACTL03) CFGTYPE(*CTL) STATUS(*OFF) +
4900 RANGE(*NET) ASCVRYOFF(*YES)
5000 MONMSG MSGID(CPF2659) /* Ignore "Incomplete" +
5100 message */
5200
5300 OVRDBF FILE(DSPOBJWRKF) TOFILE(QTEMP/DSPOBJWRKF) +
5400 MBR(DSPOBJWRKF)
5500
5600 DSPOBJD OBJ(QSYS/QPADEV*) OBJTYPE(*DEVD) +
5700 OUTPUT(*OUTFILE) +
5800 OUTFILE(QTEMP/DSPOBJWRKF) OUTMBR(*FIRST +
5900 *REPLACE)
6000 MONMSG MSGID(CPF0000)
6100 DSPOBJD OBJ(QSYS/PC1*) OBJTYPE(*DEVD) +
6200 OUTPUT(*OUTFILE) +
6300 OUTFILE(QTEMP/DSPOBJWRKF) OUTMBR(*FIRST *ADD)
6400 MONMSG MSGID(CPF0000)
6500 DSPOBJD OBJ(QSYS/HHC*) OBJTYPE(*DEVD) +
6600 OUTPUT(*OUTFILE) +
6700 OUTFILE(QTEMP/DSPOBJWRKF) OUTMBR(*FIRST *ADD)
6800 MONMSG MSGID(CPF0000)
6900
7000 READ: RCVF
7100 MONMSG MSGID(CPF0864) EXEC(GOTO CMDLBL(END))
7200 DLTDEVD DEVD(&ODOBNM)
7300 MONMSG MSGID(CPF2615 CPF2616) /* Ignore "In Use" & +
7400 "Last Dev" messages */
7500 GOTO CMDLBL(READ)
7600 /* ************************************************************** */
7700 /* */
7800 /* NORMAL END OF PROGRAM */
7900 /* */
8000 /* ************************************************************** */
8100 END: RETURN
8200 /* ************************************************************** */
8300 /* */
8400 /* STANDARD ERROR PROCESSING */
8500 /* */
8600 /* ************************************************************** */
8700 STDERR1: /* Standard error handling routine */
8800 IF &ERRORSW SNDPGMMSG MSGID(CPF9999) +
8900 MSGF(QCPFMSG) MSGTYPE(*ESCAPE) /* Func chk */
9000 CHGVAR &ERRORSW '1' /* Set to fail ir error occurs */
9100 STDERR2: RCVMSG MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +
9200 MSGF(&MSGF) MSGFLIB(&MSGFLIB)
9300 IF (&MSGID *EQ ' ') GOTO STDERR3
9400 SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
9500 MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
9600 GOTO STDERR2 /* Loop back for addl diagnostics */
9700 STDERR3: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
9800 MSGF(&MSGF) MSGFLIB(&MSGFLIB)
9900 SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
10000 MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
10100 ENDPGM
Thanks to Kenneth Graap
|
|
Back
|
Permissions of IFS file created with QZRUCLSP
| |
Q: Folks, I have posted MI code at http://code.midrange.com/9176a9360c.html that:
- Deletes file mi-ifs-file.txt from the current directory
- Creates a new file by same name in the current directory
- Writes a line if all successful
- Closes that file
It creates the file just fine, except that there are no permissions
(flags ----------). I am absolutely convinced that this is my error
(I used the same concept in RPG and it worked great), but my eyes
don't see where I might have gone wrong. Would some kind soul mind
steering me in the right direction?
A: I created an equivalent CALL to the Call Service Program Procedure
(QZRUCLSP) API from a CLP to invoke the open procedure in QP0LLIB1
and I got what I infer are the same [at least similar] results
creating a file in my directory under /home; i.e. *NONE data
authority was the effect. When I changed the oflag mask to include
O_INHERITMODE I got the same authorities to both *PUBLIC and to my
user\owner as those which were set for my directory under /home.
However attempts at changing the permissions mask for the mode
parameter in that same CLP saw no change for any of the owner,
group, or public data authorities even when passing 0d511. :-(
A:
Not so much to prove that I could, but because just by looking at
both the MI source and the documentation for the API, it seemed a simple
match, but a different language from which to test; i.e. all of the
parameters passed by reference along with an "array" of data to suggest
that some parameters should be treated by the API as instead having been
passed by value when calling the procedure, each supported sufficiently
in the CL. It was easy to code the CL from the given MI, while
following along with the API docs [open() and call srvpgm proc]. The
source compiled and created a stream file on my first try! I was
actually surprised when I did not get an error on the API call, then
even more surprised when WRKLNK showed the file was there, and finally
bummed when DSPAUT showed *NONE.
I had no idea that API existed, but that might explain the [or was
that even also a] seven parameter limit on an integrated application
server and some other callable interfaces that I vaguely recall.? I am
confident the ILE RPG does not use that API to invoke procedures; both
exceeding that parameter limit and a trace should easily prove that. I
guess any OPM program[mer] like RPG or CLP could take advantage for a
program that for whatever reason should not move to ILE; for CL, that
could be for use of DDM files with ALCOBJ for example which can cause
problems since activation groups are implemented as separate jobs on the
target.
I did later break my program when I added both the RMVLNK [del
command] and DSPAUT to the CLP so as to avoid them every time I changed
and recompiled the CLP. I ended up just removing the failing DSPAUT
since I had earlier /corrupted/ the &filename with the null character,
so I chose to just leave out the display authority request rather than
have two versions of the file name :-) Notice in the source which I
included below, that I even had declared [and used] a two-byte binary
for the permissions at some point, thinking maybe that what was type
mode_t, could have been smallint versus int... but no joy of course;
eventually I found the definition where mode_t is declared as int. The
docs do suggest the mode must be "a valid value", but I do not recall
they mention the effect for having specified an invalid value; probably
just to ignore. So perhaps there is something not obvious about the
translation from the permission octal values to the integer value, or as
alluded, that the API is just not doing the right thing with the
parameter being passed to the open(). At this point I am leaning
slightly toward defect, but almost as strongly that something might not
be coded correctly just because it seems improbable the API is not also
implementing similar requests and working fine [e.g. more generically
making invocations for features like the IAS].
dcl &srvpgmnm *char 20 'QP0LLIB1 QSYS'
dcl &x00 *char 01 x'00'
dcl &procname *char 512 'open'
dcl &rtnvfmt *char 4 x'00000003'
dcl &openfmts *char 20 x'00000002000000010000000100000001'
dcl &nbrparms *char 4 x'00000004'
dcl &openflag *char 4 x'0100004A' /* text+creat+trunc+wronly */
/* &openflag *char 4 x'0900004A' /* inh+txt+crt+trun+wronly */
dcl &permiss *char 4 x'000001B6' /* 256 + 176 + 6 */
dcl &permissi *uint 4 438 /* 256 + 176 + 6 */
/*l &permiss *char 2 x'01FF' /* x'1C0' S_IRWXU owner aut? */
dcl &errcode *char 08 x'0000000000000000'
dcl &rtnval *char 2000
dcl &filename *char 20 'dltme.tst'
dcl &ccsid *char 4 x'00000025'
del &filename
monmsg CPFA0A9
chgvar &procname (&procname *tcat &x00 )
chgvar &filename (&filename *tcat &x00 )
call qzruclsp (&srvpgmnm &procname &rtnvfmt &openfmts +
&nbrparms &errcode &rtnval &filename +
&openflag &permissi &ccsid )
Thanks to Chuck R. Pence
|
|
Back
|
QDCRDEVD API Not Working as Advertised
| |
Q: I have been trying to use the QDCRDEVD API to get the IP address used by a
workstation. I took CL code samples posted here and a sample program from IBM. The
latter can be found at
http://www-01.ibm.com/support/docview.wss?uid=nas1ed43f4e3329a4a838625726c005d8be4
which I just copied and pasted, compiled and ran.
The issue that I am having is that no matter what device id (job) I pass to
the CL I always get 10.1.10.11. Doesn't matter if it is a dynamic device
created by Client Access, such as QPADEV0004, or a static device name, such
as D2 [me].
A: It's not just you; I just downloaded that example, compiled it, and it
does not work as expected for me, either. *:-o*
Not sure what's wrong with that example ... but here's a version that works ...
PGM PARM(&DEV &ADR)
DCL VAR(&DEV) TYPE(*CHAR) LEN(10)
DCL VAR(&ADR) TYPE(*CHAR) LEN(15)
DCL VAR(&RCV) TYPE(*CHAR) LEN(1024)
DCL VAR(&LEN) TYPE(*CHAR) LEN(4) VALUE(X'00000400')
DCL VAR(&ERR) TYPE(*CHAR) LEN(96) VALUE(X'00000060')
DCL VAR(&FMT) TYPE(*CHAR) LEN(8) VALUE('DEVD0600')
DCL VAR(&ZERO) TYPE(*CHAR) LEN(4) VALUE(X'00000000')
CALL PGM(QDCRDEVD) PARM(&RCV &LEN &FMT &DEV &ERR)
IF (%SST(&ERR 5 4) *NE &ZERO) +
CHGVAR VAR(&ADR) VALUE(%SST(&ERR 8 7))
ELSE +
CHGVAR VAR(&ADR) VALUE(%SST(&RCV 878 15))
RETURN
ENDPGM
Thanks to Mark S. Waterbury
|
|
Back
|
QDCRDEVD API Not Working as Advertised
| |
Q: ... the RPG programs i need to call are pre compiled ( no source code )
is there a way to generate the required PCML for *PGM ?
A: The compiler has the ability to generate the PCML. I don't think
there's a way to interrogate a *PGM object to find the parameter structure.
A: Hmmm ... although I've never tried this, you might want to look into the QBNRPII api.
http://urlq.us/j or http://publib.boulder.ibm.com/infocenter/iseries/v5r3/topic/apis/qbnrpii.htm
Looks like this might generate what you are looking for.
A: That would work to retrieve the PCML _if_ the compiler had generated
PCML into the module at compile time. For RPG it would have been
compiled with PGMINFO(*PCML:*MODULE) on the command or the H spec.
Here's the source for a command and its command-processing-program that
calls QBNRPII to display the PCML embedded in the program or srvpgm, if
any. The program could easily be modified to copy the PCML to a stream
file.
cmd ('Display the PCML in a module')
PARM KWD(OBJ) TYPE(QUALOBJ) PROMPT('Object +
containing module')
PARM KWD(MODULE) TYPE(QUALMOD) DFT(*ALLBNDMOD) +
SNGVAL((*ALLBNDMOD *ALLBNDMOD)) +
PROMPT('Module')
PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*PGM) VALUES(*PGM *SRVPGM) +
SPCVAL((*PGM *PGM) (*SRVPGM *SRVPGM)) +
PROMPT('Object type') CHOICE('*PGM *SRVPGM')
PARM KWD(STATSONLY) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*NO) VALUES(*NO *YES) +
SPCVAL((*NO *NO) (*YES *YES)) +
PROMPT('Show stats only') CHOICE('*NO *YES')
QUALOBJ: QUAL TYPE(*NAME) +
EXPR(*YES) +
LEN(10)
QUAL TYPE(*NAME) +
EXPR(*YES) +
LEN(10) +
DFT(*LIBL) +
SPCVAL((*CURLIB *CURLIB) +
(*LIBL *LIBL)) +
PROMPT('Library')
QUALMOD: QUAL TYPE(*NAME) +
EXPR(*YES) +
LEN(10)
QUAL TYPE(*NAME) +
EXPR(*YES) +
LEN(10) +
DFT(*ANY) +
SPCVAL((*ANY *ANY)) +
PROMPT('Library')
----------------------------------------------------------------------------------------------
/if defined(*crtbndrpg)
H dftactgrp(*No) actgrp(*NEW)
/endif
H bnddir('QC2LE')
D psds sds
D errmsg 7a overlay(psds:40)
D qualname ds qualified based(template)
D obj 10a
D lib 10a
* Prints the value of the module's PCML, or "***NOTFOUND***" if
* the PCML was not in the module.
D dspPcmlFromModule...
D pr extpgm('DSPPCMLMD')
D objQual likeds(qualname) const
D modQual likeds(qualname) const
D objType 10a const
D statsOnly 10a const
D dspPcmlFromModule...
D pi
D objQual likeds(qualname) const
D modQual likeds(qualname) const
D objType 10a const
D statsOnly 10a const
D buffer s 65535a based(bufPtr)
D Qbn_Interface_Entry_t...
D ds qualified based(template)
* Offset from start of receiver
D Offset_Next_Entry...
D 10i 0
D Module_Name...
D 10a
D Module_Library...
D 10a
D Interface_Info_CCSID...
D 10i 0
D Interface_Info_Type...
D 10i 0
* Offset from start of receiver
D Offset_Interface_Info...
D 10i 0
D Interface_Info_Length_Ret...
D 10i 0
D Interface_Info_Length_Avail...
D 10i 0
D Qbn_PGII0100_t ds qualified based(template)
D Bytes_Returned...
D 10i 0
D Bytes_Available...
D 10i 0
D Obj_Name...
D 10a
D Obj_Lib_Name...
D 10a
D Obj_Type...
D 10a
D Reserved3...
D 2a
D Offset_First_Entry...
D 10i 0
D Number_Entries...
D 10i 0
D errcode ds qualified
D bytesprov 10i 0 inz(0)
D bytesavail 10i 0
* Define the initial storage for the first call to the API
D tempRcvr ds likeds(Qbn_PGII0100_t)
D rcvr ds likeds(Qbn_PGII0100_t)
D based(pRcvr)
D pRcvr s * inz(*null)
D entry ds likeds(Qbn_Interface_Entry_t)
D based(pEntry)
D pEntryData s *
D data s 50a based(pData)
D line s 80a varying
D off s 6p 0
D lenRemaining s 10i 0
D len s 10i 0
D memcpy pr * extproc('__memcpy')
D rcvr * value
D src * value
D len 10u 0 value
D print pr
D msg * value options(*string)
* Prototype for QBNRPII (Retrieve Program Interface Information)
* The receiver might be larger than the RPG limit of 64K
* so we'll just define it as the structure header, but actually
* pass a larger receiver
D QBNRPII pr extpgm('QBNRPII')
D Receiver_variable...
D likeds(Qbn_PGII0100_t)
D Length_of_receiver_variable...
D 10i 0 const
D Format_name...
D 8a const
D Qualified_object_name...
D likeds(qualname) const
D Object_Type...
D 10a const
D Qualified_bound_module_name...
D likeds(qualname) const
D Error_code...
D likeds(errcode)
/free
// print parms
print ('Printing PCML info');
print (' Object: ' + %trim(objQual.lib) + '/' + objQual.obj
+ objType);
if (modQual.lib = *blank);
print (' Module: ' + modQual.obj);
else;
print (' Module: ' + %trim(modQual.lib) + '/' + modQual.obj);
endif;
// call the API once, to see how much storage to allocate
callp(e) QBNRPII (tempRcvr : %size(tempRcvr) : 'RPII0100'
: objQual : objType : modQual : errcode);
if %error;
print (' Error ' + errmsg + ' retrieving info');
exsr cleanup;
return;
endif;
print (' Length of information: '
+ %char(tempRcvr.Bytes_Available));
if statsOnly = '*YES';
exsr cleanup;
return;
endif;
if tempRcvr.Bytes_Available <= tempRcvr.Bytes_Returned;
pRcvr = %addr(tempRcvr);
else;
pRcvr = %alloc(tempRcvr.Bytes_Available);
callp(e) QBNRPII (rcvr : tempRcvr.Bytes_Available : 'RPII0100'
: objQual : objType : modQual : errcode);
endif;
if %error
or rcvr.Number_Entries = 0;
print (' Information not found');
exsr cleanup;
return;
endif;
pEntry = pRcvr + rcvr.offset_First_Entry;
pEntryData = pRcvr + entry.Offset_Interface_Info;
lenremaining = entry.Interface_Info_Length_Ret;
print (' Length of data: '
+ %char(entry.Interface_Info_Length_Ret));
if lenRemaining = 0;
exsr cleanup;
return;
endif;
off = 0;
dow lenRemaining > 0;
len = lenRemaining;
if len > %size(data);
len = %size(data);
endif;
pData = pEntryData + off;
line = %editc(off:'N') + ': ' + %subst(data : 1: len);
print (line);
off = off + len;
lenRemaining = lenRemaining - len;
enddo;
exsr cleanup;
return;
//---------------------------------------
// S U B R O U T I N E S
//---------------------------------------
begsr cleanup;
if pRcvr <> *null
and pRcvr <> %addr(tempRcvr);
dealloc(n) pRcvr;
endif;
endsr;
/end-free
P print b
D print pi
D msg * value options(*string)
D printf pr extproc('printf')
D template * value options(*string)
D msg * value options(*string : *nopass)
D newline c x'15'
/free
printf ('%' + newline : msg);
/end-free
P print e
Thanks to Barbara Morris
|
|
Back
|
Clear ARP Cashe on Ethernet line passed as parm
| |
Here is a small CLP that will clear based on your Ethernet line
/******************************************************************************/
/* Clear ARP Cashe on Ethernet line passed as parm */
/* CRTBNDCL PGM(your-lib/CLRARPCSH) + */
/* SRCFILE(your-lib/QCLSRC) + */
/* SRCMBR(CLRARP) */
/******************************************************************************/
PGM PARM(&LINE)
DCL VAR(&LINE) TYPE(*CHAR) LEN(10)
CALLPRC PRC('QtocRmvARPTblE') PARM(&LINE 0 '*ALL ' +
X'00000000')
ENDPGM
Thanks to Chris Bipes
|
|
Back
|
How to find damaged objects
| |
I agree that a save is a good way to find damaged objects but I do have a
program that runs daily to identify damaged objects. First, this command
is executed, which generates an outfile of all object descriptions. One
of the fields that is output is a damaged flag.
DSPOBJD OBJ(*ALL/*ALL) OBJTYPE(*ALL) DETAIL(*FULL) OUTPUT(*OUTFILE)
OUTFILE(QGPL/DSPOBJD)
Next, this program is run which generates a report of the objects flagged
as damaged and e-mails it to me:
H
**************************************************************************
H* DAMRPT -- Report of Damaged Objects
H
**************************************************************************
H* Program ID -- DAMRPT
H* Author -- Dave Parnin
H* Date -- 07-14-10
**************************************************************************
H Option(*SrcStmt:*NoDebugIO)
**************************************************************************
FDSPOBJDL1 IF E K DISK
FDAMRPTO O E PRINTER
**************************************************************************
D* Definition Specifications
D
**************************************************************************
D* *ENTRY PLIST
DDAMRPT PR ExtPgm('NSCRDESW')
D XXJOBNAME 10A
D
DDAMRPT PI
D XJOBNAME 10A
D
DFAC S 2A
DXUSER S 10A
DPRINTED S 1A
DREPORTIT S 1A
DCOMMAND S 200A
DXLEN S 15 5
DQUOTE S 1A INZ('''')
DWKDATE S D DATFMT(*ISO)
DOUTDT S 8 0
D
D SDS SDS
D JOBNAME 244 253 * Job name
D USER 254 263
D JOBNUM 264 269S 0 * Job number
D
DJOBDS DS
D NUMJOBNUM 6S 0
D CHARJOBNUM 6A Overlay(NUMJOBNUM)
**************************************************************************
D* Prototypes
**************************************************************************
DCMD PR ExtPgm('QCMDEXC')
D Command 200A Const
D LENGTH 15P 5
D
DNSCREMAIL PR ExtPgm('NSCREMAIL')
D JobName 10A
D JobUser 10A
D JobNum 6A
D ToAdd 80A
**************************************************************************
C* Mainline Routine
**************************************************************************
C/Free
// Main flow of the program
ExSr INIT;
// Generate report
ExSr GENREPORT;
// That's All Folks!
Eval *INLR = '1';
//**************************************************************************
// GENREPORT--Generate Report
//**************************************************************************
BegSR GENREPORT;
// Get first record
Read QLIDOBJD;
// Loop through the file of system objects
DoW Not %Eof(DSPOBJDL1);
// If object damaged then report it (1=Full, 2=Partial)
If ODOBDM = '1' or ODOBDM = '2';
ExSr PRINTLN;
EndIf;
Read QLIDOBJD;
EndDo;
EndSr;
//**************************************************************************
// PRINTLN--Print Report Line
//**************************************************************************
BegSR PRINTLN;
If *INOF = *on;
WRITE HEADER;
*inof = *off;
EndIf;
Write DETAIL;
PRINTED = 'Y';
EndSr;
//**************************************************************************
// EMAIL--E-Mail Report
//**************************************************************************
BegSR EMAIL;
// NUMJOBNUM = JOBNUM;
// NSCREMAIL(JOBNAME:XUSER:CHARJOBNUM:NAEMAIL);
EndSr;
//**************************************************************************
// INIT--Initialize Stuff
//**************************************************************************
BegSR INIT;
XUSER = USER;
PRINTED = 'N';
*inof = *on;
EndSr;
/End-Free
DAMRPTO Printer file:
A R HEADER
A SKIPB(1)
A 1DATE
A EDTCDE(Y)
A 57'AS30 Damaged Objects'
A 11TIME
A 123'PAGE'
A 128PAGNBR
A SPACEA(2)
A EDTCDE(Z)
A 2'Library'
A UNDERLINE
A 23'Object'
A UNDERLINE
A 40'Object Type'
A HIGHLIGHT
A UNDERLINE
A R HEADER
A SKIPB(1)
A 1DATE
A EDTCDE(Y)
A 57'AS30 Damaged Objects'
A 11TIME
A 123'PAGE'
A 128PAGNBR
A SPACEA(2)
A EDTCDE(Z)
A 2'Library'
A UNDERLINE
A 23'Object'
A UNDERLINE
A 40'Object Type'
A HIGHLIGHT
A UNDERLINE
A 65'Description'
A HIGHLIGHT
A UNDERLINE
A 119'Creation Date'
A SPACEA(1)
A HIGHLIGHT
A UNDERLINE
A ODCDAT 6 O 122TEXT('Creation Date')
A
A R DETAIL
A ODOBNM 10 O 23TEXT('Object')
A ODOBTP 8 O +7TEXT('Object Type')
A ODOBTX 50 O 65TEXT('Description')
A ODLBNM 10 O 2TEXT('Library')
A SPACEA(1)
Thanks to Dave Parnin
|
|
Back
