|
midrange.com
> Anyone have a running doc on the SEPT, Pointers to jobs and job objects?
> The theory is that I should be able to view ANY QTEMP library and
> underlying objects. Yes, this means pointers out of my immediate space,
> but if it's there it should be addressable...
>
> Anyone play with this yet?
>
[Leif Svalgaard] Don, here is a starting point:
Here is first a C/400 program to print the System Entry Point Table
(SEPT).
/* Test program to display System Entry Point Table */
#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
/* qsysinc: */
#include <pointer.h>
#include <mimchobs.h>
#include <mispcobj.h>
#include <miptrnam.h>
#include <qliept.h>
static _MPTR_Template_T *mptr_area;
void main(void){
int i;
_OPENPTR *inv_sys;
i = sizeof(_MPTR_Template_T);
mptr_area = malloc(i);
mptr_area->Obj_Ptr.Template_Size = i;
for(i=0; i<WLISRHNMTBL_DIM; i++)
{
inv_sys = (((_SYSPTR **)_SYSEPT()) + i);
if (*inv_sys != NULL)
{
matptr(mptr_area, *inv_sys);
printf("Entry %d is %10.10s %10.10s\n", i,
mptr_area->Obj_Ptr.Library_ID.Name,
mptr_area->Obj_Ptr.Object_ID.Name);
}
else
{
printf("Entry %d is **null**\n", i);
}
}
free(mptr_area);
}
When run under Security Level 30, the program prints out 6245
entries. When run under level 40, the program bombs right away with a
'security violation'. The program uses the MATPTR API, which is documented
in the usual AS/400 manuals.
Under any Security Level you can always dump the SEPT using the
DUMPSYSOBJ command:
DMPSYSOBJ OBJ(QINSEPT) CONTEXT(QSYS)
When you do that and select the QPSRVDMP spool file with WRKSPLF you
see something like the following; find the POINTERS section:
Display Spooled File
File . . . . . : QPSRVDMP Page/Line
54/47
Control . . . . . Columns 1
- 78
Find . . . . . . POINTERS
*...+....1....+....2....+....3....+....4....+....5....+....6....+....7..
.POINTERS-
000000 SYP 02 01 QT3REQIO 04 01 QSYS
000010 SYP 02 01 QWSCLOSE 04 01 QSYS
000020 SYP 02 01 QSFGET 04 01 QSYS
000030 SYP 02 01 QWSOPEN 04 01 QSYS
000040 SYP 02 01 QWSPBDVR 04 01 QSYS
000050 SYP 02 01 QWSRST 04 01 QSYS
000060 SYP 02 01 QWSRTSFL 04 01 QSYS
000070 SYP 02 01 QSFCRT 04 01 QSYS
000080 SYP 02 01 QWSSPEND 04 01 QSYS
000090 SYP 02 01 QDCVRX 04 01 QSYS
0000A0 SYP 02 01 QDMCLOSE 04 01 QSYS
0000B0 SYP 02 01 QDMCOPEN 04 01 QSYS
0000C0 SYP 02 01 QDBCLOSE 04 01 QSYS
0000D0 SYP 02 01 QDBGETDR 04 01 QSYS
0000E0 SYP 02 01 QDBGETKY 04 01 QSYS
0000F0 SYP 02 01 QDBGETSQ 04 01 QSYS
000100 SYP 02 01 QDBOPEN 04 01 QSYS
000110 SYP 02 01 QDBPUT 04 01 QSYS
000120 SYP 02 01 QDBUDR 04 01 QSYS
000130 SYP 02 01 QSPBPPRT 04 01 QSYS
000140 SYP 02 01 QOESETEX 04 01 QSYS
000150 SYP 02 01 QWSPUT 04 01 QSYS
000160 SYP 02 01 QWSMEEH 04 01 QSYS
000170 SYP 02 01 QWSMSG 04 01 QSYS
000180 SYP 02 01 QWSPTMSG 04 01 QSYS
000190 SYP 02 01 QLPCTLIN 04 01 QSYS
0001A0 SYP 02 01 QLPTRANS 04 01 QSYS
0001B0 SYP 02 01 QWCITUNR 04 01 QSYS
0001C0 SYP 02 01 QTIMAIN1 04 01 QSYS
. . . etc
It takes 144 seconds to produce the dump. The dump shows programs in
their context (QSYS). One could capture this output in a file and work on
each entry.
MI Program DSPSEPT to Materialize the SEPT.
For simplicity in experimentation the program sends its resulting
output for each entry to the job's message queue. Stop it with the System
Request key, then answer '2'. Don't worry about the details, go straight to
the discussion after the listing.
DCL SPC * BASPCO;
DCL SPCPTR .SEPT_PCO DIR; /* 1ST ENTRY */
DCL SYSPTR .SEPT(6440) BAS(.SEPT_PCO);
DCL CON MAX_SEPT BIN(2) INIT(6440); /* VERSION DEPENDENT */
DCL DD ENTRY_NBR BIN(2);
DCL DD INFO CHAR(77) BDRY(16);
DCL DD INFO_PRV BIN ( 4) DEF(INFO) POS( 1) INIT(77);
DCL DD INFO_AVL BIN ( 4) DEF(INFO) POS( 5);
DCL DD INFO_PTR_TYPE CHAR( 1) DEF(INFO) POS( 9);
DCL DD INFO_LIB_ID CHAR(32) DEF(INFO) POS(10);
DCL DD INFO_LIB_TYPES CHAR( 2) DEF(INFO_LIB_ID) POS(1);
DCL DD INFO_LIB_NAME CHAR(30) DEF(INFO_LIB_ID) POS(3);
DCL DD INFO_OBJ_ID CHAR(32) DEF(INFO) POS(42);
DCL DD INFO_OBJ_TYPES CHAR( 2) DEF(INFO_OBJ_ID) POS(1);
DCL DD INFO_OBJ_NAME CHAR(30) DEF(INFO_OBJ_ID) POS(3);
DCL DD INFO_BITS CHAR( 4) DEF(INFO) POS(74);
DCL SPCPTR .INFO INIT(INFO);
DCL SYSPTR .FORGED; /* SYSTEM POINTER TO FORGE */
DCL INSPTR RETURN; /* RETURN PTR FOR CALLI */
ENTRY * EXT;
CPYNV ENTRY_NBR, 0;
NEXT_ENTRY:
ADDN(S) ENTRY_NBR, 1;
SETSPFP .FORGED, .SEPT(ENTRY_NBR); /* FORGE POINTER */
MATPTR .INFO, .FORGED; BRK "1";
CALLI SHOW_OBJECT, *, RETURN; /* SHOW RESULT TO MSGQ */
TEST_ENTRY:
CMPNV(B) ENTRY_NBR, MAX_SEPT /LO(NEXT_ENTRY);
RTX *;
/******* SEND MESSAGE HANDLING ********/
DCL DD MSG_ID CHAR (7) INIT(" ");
DCL SPCPTR .MSG_ID INIT(MSG_ID);
DCL DD MSG_FILE CHAR(20) INIT(" ");
DCL SPCPTR .MSG_FILE INIT(MSG_FILE);
DCL DD MSG_TEXT CHAR(74);
DCL DD MSG_ENTRY_NBR ZND(4,0) DEF(MSG_TEXT) POS( 1);
DCL DD * CHAR( 1) DEF(MSG_TEXT) POS( 5) INIT(":");
DCL DD MSG_OBJ_OBJ CHAR(30) DEF(MSG_TEXT) POS( 6);
DCL DD MSG_OBJ_LIB CHAR(30) DEF(MSG_TEXT) POS(36);
DCL DD * CHAR( 1) DEF(MSG_TEXT) POS(66) INIT(" ");
DCL DD MSG_OBJ_BITS CHAR( 8) DEF(MSG_TEXT) POS(67);
DCL SPCPTR .MSG_TEXT INIT(MSG_TEXT);
DCL DD MSG_SIZE BIN( 4) INIT(74);
DCL SPCPTR .MSG_SIZE INIT(MSG_SIZE);
DCL DD MSG_TYPE CHAR(10) INIT("*INFO ");
DCL SPCPTR .MSG_TYPE INIT(MSG_TYPE);
DCL DD MSG_QS CHAR(20) INIT("*REQUESTER ");
DCL SPCPTR .MSG_QS INIT(MSG_QS);
DCL DD MSG_QSN BIN( 4) INIT(1);
DCL SPCPTR .MSG_QSN INIT(MSG_QSN);
DCL DD REPLY_Q CHAR(20) INIT(" ");
DCL SPCPTR .REPLY_Q INIT(REPLY_Q);
DCL DD MSG_KEY CHAR( 4);
DCL SPCPTR .MSG_KEY INIT(MSG_KEY);
DCL DD ERR_CODE BIN( 4) INIT(0);
DCL SPCPTR .ERR_CODE INIT(ERR_CODE);
DCL OL QMHSNDMOL (.MSG_ID, .MSG_FILE, .MSG_TEXT, .MSG_SIZE,
.MSG_TYPE, .MSG_QS, .MSG_QSN, .REPLY_Q,
.MSG_KEY, .ERR_CODE) ARG;
ENTRY SHOW_OBJECT INT; /* SHOW OBJECT INFO */
CPYNV MSG_ENTRY_NBR, ENTRY_NBR;
CPYBLA MSG_OBJ_OBJ, INFO_OBJ_NAME;
CPYBLA MSG_OBJ_LIB, INFO_LIB_NAME;
CVTHC MSG_OBJ_BITS, INFO_BITS; /* HEX TO CHAR */
CALLX .SEPT(4268), QMHSNDMOL, *; /* SEND MSG TO MSGQ */
B RETURN;
/******* EXCEPTION HANDLING ********/
DCL EXCM EXCEPTION_MONITOR EXCID(H'0000') /* ALL */
BP(ERROR_DETECTED) IMD;
ERROR_DETECTED:
CPYBLAP INFO_OBJ_NAME, "*PROTECTED", " ";
CPYBLAP INFO_LIB_NAME, "QSYS", " ";
CPYBLA INFO_BITS, X'00000000';
CALLI SHOW_OBJECT, *, RETURN;
B TEST_ENTRY;
PEND;
The crucial instructions are:
SETSPFP .FORGED, .SEPT(ENTRY_NBR); /* FORGE POINTER */
MATPTR .INFO, .FORGED;
If you simply try to materialize the entry point, that is:
MATPTR .INFO, .SEPT(ENTRY_NBR);
you get an exception ('Object domain or hardware storage protection
violation'). By setting another system pointer, .FORGED, from the entry
point (the SETSPFP instruction) you essentially forge a new pointer from the
old. This new pointer can be materialized in some cases, bypassing the
security integrity check for the SEPT object itself. I've marked (with OK)
the entries that can be materialized in the following table:
000000 SYP 02 01 QT3REQIO 04 01 QSYS
000010 SYP 02 01 QWSCLOSE 04 01 QSYS
000020 SYP 02 01 QSFGET 04 01 QSYS
000030 SYP 02 01 QWSOPEN 04 01 QSYS
000040 SYP 02 01 QWSPBDVR 04 01 QSYS
000050 SYP 02 01 QWSRST 04 01 QSYS
000060 SYP 02 01 QWSRTSFL 04 01 QSYS
000070 SYP 02 01 QSFCRT 04 01 QSYS
000080 SYP 02 01 QWSSPEND 04 01 QSYS
000090 SYP 02 01 QDCVRX 04 01 QSYS
0000A0 SYP 02 01 QDMCLOSE OK 04 01 QSYS
0000B0 SYP 02 01 QDMCOPEN OK 04 01 QSYS
0000C0 SYP 02 01 QDBCLOSE 04 01 QSYS
0000D0 SYP 02 01 QDBGETDR OK 04 01 QSYS
0000E0 SYP 02 01 QDBGETKY OK 04 01 QSYS
0000F0 SYP 02 01 QDBGETSQ OK 04 01 QSYS
000100 SYP 02 01 QDBOPEN 04 01 QSYS
000110 SYP 02 01 QDBPUT OK 04 01 QSYS
000120 SYP 02 01 QDBUDR OK 04 01 QSYS
000130 SYP 02 01 QSPBPPRT 04 01 QSYS
000140 SYP 02 01 QOESETEX 04 01 QSYS
000150 SYP 02 01 QWSPUT OK 04 01 QSYS
000160 SYP 02 01 QWSMEEH 04 01 QSYS
. . .
If you display the program information (DSPPGM PGM(QSYS/QDMCLOSE)
for two entries (one that can be materialized and one that cannot) you see
something like this:
Program . . . . . .. . . . . .: QDMCLOSE
QDBCLOSE
Program creation date/time .. .. : 03/18/98 15:36:56
05/18/98 23:04:18
Type of program . . . . . . . . : OPM OPM
Source file . . . . . . . . . . :
Library . . . . . . . . . . . :
Source member . . . . . . . . . :
Source file change date/time . . :
Observable information . . . . . : *NONE
*NONE
User profile . . . . . . . . . . : *USER
*USER
Use adopted authority . . . . . : *YES
*YES
Fix decimal data . . . . . . . . : *NO *NO
Text description . . . . . . . . :
Program size (bytes) . . . . . . : 49152
32768
Associated space size (bytes) . : 0 0
Static storage size (bytes) . . : 0 0
Automatic storage size (bytes) . : 2208
1488
Program state . . . . . . . . . : *SYSTEM
*SYSTEM
Program domain . . . . . . . . . : *USER
*SYSTEM
Compiler . . . . . . . . . . . . : V4R3M0
V4R3M0
Earliest release for running. .. : V4R3M0
V4R3M0
Conversion required . . . . . . : *NO *NO
Sort sequence . . . . . . . . . : *HEX *HEX
Language identifier . . . . . . : *JOBRUN
*JOBRUN
Optimization . . . . . . . . . . : *OPTIMIZE
*OPTIMIZE
Paging pool . . . . . . . . . . : *USER
*USER
Update PASA . . . . . . . . . . : *UPDPASA
*NOUPDPASA
Clear PASA . . . . . . . . . . . : *CLRPASA
*NOCLRPASA
Paging amount . . . . . . . . . : *BLOCK
*BLOCK
The only real difference is that QDMCLOSE is in the *USER domain and
QDBCLOSE is in the *SYSTEM domain. To put it differently: QDMCLOSE is for
general use (this does not necessarily mean that it is a documented API;
e.g. QDBPUT is not) and QDBCLOSE is for system use only.
With the MATPTR MI-instruction you had to forge the pointer to
access an entry in the SEPT. There is another instruction, Materialize
System Object - MATSOBJ, that can materialize a system object; e.g.:
MATSOBJ .INFO, .SEPT(ENTRY_NBR);
This works directly without using a forged pointer. However, you
still cannot materialize objects in the system domain (in spite of the name
of the MI-instruction).
Why Are We Doing This
The System Entry Point Table (SEPT) is important, because the
programs in it are before any programs in the library list and are the basic
operating system calls (e.g. to open files, read records, etc). If you could
place one of your own programs here in lieu of a standard entry point, you
could act as a Trojan Horse and essentially bypass most security. A minimum
defense against this would be to print a listing of all the programs
including their properties.
If you are running under at least Security Level 40, you are
supposedly protected against tampering with the SEPT so you need only to
worry about the entries you can have access to. The problem here is that you
want to be *sure* that it has not been tampered with.
Using the Standard Tools to Examine the SEPT
We shall develop a program (RTVSEPT) to produce a report that shows
the content of the SEPT using only standard OS/400 tools and calls and which
will execute under any Security Level. The report should show for each entry
things like: program name, context (i.e. library), owner, creation
date/time, state, and domain.
Dumping the SEPT
We use the DUMPSYSOBJ command to dump the SEPT:
DMPSYSOBJ OBJ(QINSEPT) CONTEXT(QSYS) OUTPUT(*PRINT)
then copy the resulting spool file to a database file for
processing. The following CL program, GETSEPT, creates the database file and
copies the spool file (QPSRVDMP) to the SEPTDUMP file in the given library:
PGM PARM(&LIB)
DCL VAR(&LIB) TYPE(*CHAR) LEN(10)
DLTF FILE(&LIB/SEPTDUMP)
MONMSG MSGID(CPF2105) /* FILE NOT FOUND */
CRTPF FILE(&LIB/SEPTDUMP) RCDLEN(132) LVLCHK(*NO)
DMPSYSOBJ OBJ(QINSEPT) CONTEXT(QSYS)
CPYSPLF FILE(QPSRVDMP) TOFILE(&LIB/SEPTDUMP) +
SPLNBR(*LAST) MBROPT(*REPLACE)
DLTSPLF FILE(QPSRVDMP) SPLNBR(*LAST)
DLTF FILE(&LIB/SEPTLIST)
MONMSG MSGID(CPF2105) /* FILE NOT FOUND */
CRTPF FILE(&LIB/SEPTLIST) RCDLEN(132) LVLCHK(*NO)
ENDPGM
As a side effect it also prepares the SEPTLIST file which will hold
the resulting report. This program is called at the very start of RTVSEPT,
which then proceeds with processing each line and calling the CLRPGMI API
with the name of the program and the library to get detailed information for
that object.
The CLRPGMI API
This API actually returns the information needed for our report. The
API is called with a format (PGMI0100) specifying 'basic' program
information.
The RTVSEPT Program
DCL SPCPTR .PARM1 PARM;
DCL DD PARM-LIB CHAR(10) BAS(.PARM1);
DCL OL PARAMETERS(.PARM1) EXT PARM MIN(0);
DCL DD NBR-OF-PARMS BIN(2);
DCL SPCPTR .NULL;
DCL CON CLOSE-ENTRY BIN(2) INIT(11);
DCL CON OPEN-ENTRY BIN(2) INIT(12);
DCL CON *LIBL BIN(2) INIT(-75); /* S/38: -72 */
DCL CON *FIRST BIN(2) INIT(-71); /* S/38: -73 */
DCL CON THE-LIB BIN(2) INIT(72);
DCL CON THE-MBR BIN(2) INIT(73);
DCL DD BINARY-CHARS CHAR(4);
DCL DD BINARY-VALUE BIN(4) DEF(BINARY-CHARS) POS(1);
DCL DD ENTRY-NBR BIN(2);
DCL SPCPTR .ODP-ROOT;
DCL SPC ODP-ROOT BAS(.ODP-ROOT);
DCL DD ODP-STATUS CHAR(4) DIR;
DCL DD ODP-DEV-LENGTH BIN(4) DIR;
DCL DD ODP-OPEN-SIZE BIN(4) DIR;
DCL DD ODP.OPEN-FEEDBCK BIN(4) DIR;
DCL DD ODP.DEV-NAMELIST BIN(4) DIR;
DCL DD ODP.IO-FEEDBACK BIN(4) DIR;
DCL DD ODP.LOCK-LIST BIN(4) DIR;
DCL DD ODP.SPOOL-OUTPUT BIN(4) DIR;
DCL DD ODP.MBR-DESCR BIN(4) DIR;
DCL DD ODP.CUR-IN-REC BIN(4) DIR;
DCL DD ODP.CUR-OUT-REC BIN(4) DIR;
DCL DD ODP.OPEN-DMCQ BIN(4) DIR;
DCL DD ODP.OUTSTANDINGS BIN(4) DIR;
DCL DD * CHAR(12) DIR;
DCL SYSPTR .ODP-CURSOR DIR;
DCL SPCPTR * DIR;
DCL SPCPTR .ODP-CDM-ERROR DIR;
DCL SPCPTR .ODP-INPUT-BUFFER DIR;
DCL SPCPTR .ODP-OUTPUT-BUFFER DIR;
DCL DD ODP.CDM-CLOSING BIN(2) DIR;
DCL DD ODP-DEV-NAME-IDX BIN(2) DIR;
DCL DD ODP-NBR-OF-DEVS BIN(2) DIR;
DCL DD ODP-SEQUENCE-NBR BIN(4) DIR;
DCL DD ODP-REC-LENGTH BIN(2) DIR;
DCL DD ODP-REC-LENGTH2 BIN(2) DIR;
DCL DD ODP-NBR-OF-*RDS BIN(2) DIR;
DCL DD ODP-RELEASE-NBR BIN(2) DIR;
DCL DD ODP-OPEN-POSN CHAR(1) DIR;
DCL DD ODP-OVR-REC-LEN BIN(2) DIR;
DCL DD ODP-COM-DEV-CNT BIN(2) DIR;
DCL DD ODP.INPUT-BPCA BIN(4) DIR;
DCL DD ODP.OUTPUT-BPCA BIN(4) DIR;
DCL DD ODP............ CHAR(1) DIR;
DCL SPCPTR .DEV-CONTROL-BLOCK;
DCL SPC DEV-CONTROL-BLOCK BAS(.DEV-CONTROL-BLOCK);
DCL DD DCB-MAX-NBR-OF-DEVICES BIN( 2) DIR;
DCL DD DCB-DEVICES-IN-THE-ODP BIN( 2) DIR;
DCL DD DCB-DEVICE-NAME CHAR(10) DIR;
DCL DD DCB-OFFSET-TO-FM-WORK BIN( 4) DIR;
DCL DD DCB-LENGTH-OF-FM-WORK BIN( 4) DIR;
DCL DD DCB-INDEX-FOR-LUD-PTR BIN( 2) DIR;
DCL DD DCB-GET BIN( 2) DIR;
DCL DD DCB-GET-BY-RRN BIN( 2) DIR;
DCL DD DCB-GET-BY-KEY BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD DCB-PUT BIN( 2) DIR;
DCL DD DCB-PUT-GET BIN( 2) DIR;
DCL DD DCB-UPDATE BIN( 2) DIR;
DCL DD DCB-DELETE BIN( 2) DIR;
DCL DD DCB-FORCE-EOD BIN( 2) DIR;
DCL DD DCB-FORCE-EOV BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD DCB-FREE-REC-LOCK BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD * BIN( 2) DIR;
DCL DD DCB-CLOSE BIN( 2) DIR;
DCL DD DCB-OPEN BIN( 2) DIR;
DCL DD DCB-SPTB BIN( 2) DIR;
/* THE I/O IS DONE BY USING THE CALLX INSTRUCTION REFERENCING */
/* A SYSTEM POINTER THAT IS OBTAINED FROM THE ENTRY POINT */
/* TABLE. THE ENTRY POINT TABLE CONTAINS PRE-RESOLVED SYSTEM */
/* POINTERS (THOUSANDS...). THE SYSTEM ENTRY POINT TABLE */
/* IS ADDRESSED BY THE POINTER BASED ON THE PROCESS COMMUNI- */
/* CATION OBJECT (PCO): */
/* PCO POINTER --> POINTER TO SEPT --> PTR TO OS FUNCTION 1 */
/* PTR TO OS FUNCTION 2 */
/* ... */
/* THE SIZE OF THE SEPT (6440) IS VERSION DEPENDENT. IT KEEPS */
/* GOING UP... */
DCL SPC PROCESS-COMM-AREA BASPCO;
DCL SPCPTR PCO-POINTER DIR;
DCL SYSPTR .SEPT(6440) BAS(PCO-POINTER);
/* THE USER FILE CONTROL BLOCK (UFCB) DEFINES THE FILE NAME, */
/* BUFFER SPACES AND ALL NECESSARY CONTROL INFORMATION NEEDED */
/* TO MANAGE THE FILE. IT ALSO PROVIDES THE FEEDBACKS NEEDED */
/* TO ACCESS VARIOUS STRUCTURES, SUCH AS THE ODP (THE OPEN */
/* DATA PATH). */
/* DUMP FILE PARAMETERS */
DCL SPCPTR .DFCB INIT(DFCB);
DCL DD DFCB CHAR(214) BDRY(16);
DCL SPCPTR .DFCB-ODP DEF(DFCB) POS( 1);
DCL SPCPTR .DFCB-INBUF DEF(DFCB) POS( 17);
DCL SPCPTR .DFCB-OUTBUF DEF(DFCB) POS( 33);
DCL SPCPTR .DFCB-OPEN-FEEDBACK DEF(DFCB) POS( 49);
DCL SPCPTR .DFCB-IO-FEEDBACK DEF(DFCB) POS( 65);
DCL SPCPTR .DFCB-NEXT-UFCB DEF(DFCB) POS( 81);
DCL DD * CHAR(32) DEF(DFCB) POS( 97);
DCL DD DFCB-FILE CHAR(10) DEF(DFCB) POS(129);
DCL DD DFCB-LIB-ID BIN(2) DEF(DFCB) POS(139);
DCL DD DFCB-LIBRARY CHAR(10) DEF(DFCB) POS(141);
DCL DD DFCB-MBR-ID BIN(2) DEF(DFCB) POS(151);
DCL DD DFCB-MEMBER CHAR(10) DEF(DFCB) POS(153);
DCL DD DFCB-DEVICE-NAME CHAR(10) DEF(DFCB) POS(163);
DCL DD DFCB-DEVICE-INDEX BIN(2) DEF(DFCB) POS(173);
DCL DD DFCB-FLAGS-1 CHAR(1) DEF(DFCB) POS(175)
INIT(X'80');
DCL DD DFCB-FLAGS-2 CHAR(1) DEF(DFCB) POS(176)
INIT(X'20');
DCL DD DFCB-REL-VERSION CHAR(4) DEF(DFCB) POS(177);
DCL DD DFCB-INV-MK-COUNT BIN (4) DEF(DFCB) POS(181);
DCL DD DFCB-MORE-FLAGS CHAR(1) DEF(DFCB) POS(185);
DCL DD * CHAR(23) DEF(DFCB) POS(186);
DCL DD DFCB-RECORD-ID BIN (2) DEF(DFCB) POS(209) INIT(1);
DCL DD DFCB-RECORD-LENGTH BIN (2) DEF(DFCB) POS(211) INIT(132);
DCL DD DFCB-NO-MORE-PARMS BIN (2) DEF(DFCB) POS(213)
INIT(32767);
DCL OL OPEN-D(.DFCB);
DCL OL CLOSE-D(.DFCB);
DCL SPCPTR .DBUF;
DCL DD DBUF CHAR(132) BAS(.DBUF);
DCL DD DBUF-MARKER CHAR(10) DEF(DBUF) POS( 1);
DCL DD DBUF-ENTRY CHAR(132) DEF(DBUF) POS( 1);
DCL DD DBUF-OFFSET CHAR( 6) DEF(DBUF-ENTRY) POS( 3);
DCL DD DBUF-OBJ CHAR(10) DEF(DBUF-ENTRY) POS( 22);
DCL DD DBUF-CTX CHAR(10) DEF(DBUF-ENTRY) POS( 60);
DCL DD DBUF-TYPE CHAR( 3) DEF(DBUF-ENTRY) POS(104);
DCL DD D-GET BIN(2);
DCL SPCPTR .GET-OPT-D INIT(GET-OPT-D);
DCL DD GET-OPT-D BIN(4) INIT(H'03000001');
DCL OL GET-D(.DFCB, .GET-OPT-D, .NULL);
DCL SPCPTR .FORMAT-NAME INIT(FORMAT-NAME);
DCL DD FORMAT-NAME CHAR(8) INIT("PGMI0100");
/* FORMAT FOR PGM INFORMATION 'PGMI0100' */
DCL SPCPTR .PGMI0100-LENGTH INIT(PGMI0100-LENGTH);
DCL DD PGMI0100-LENGTH BIN(4) INIT(435);
DCL SPCPTR .PGMI0100 INIT(PGMI0100);
DCL DD PGMI0100 CHAR(435) BDRY(16);
DCL DD FMT-BYTES-RETURNED BIN(4) DEF(PGMI0100) POS(
1);
DCL DD FMT-BYTES-AVAILABLE BIN(4) DEF(PGMI0100) POS(
5);
DCL DD FMT-PGM-NAME CHAR(10) DEF(PGMI0100) POS(
9);
DCL DD FMT-PGM-LIB CHAR(10) DEF(PGMI0100) POS(
19);
DCL DD FMT-OWNER CHAR(10) DEF(PGMI0100) POS(
29);
DCL DD FMT-PGM-ATTR CHAR(10) DEF(PGMI0100) POS(
39);
DCL DD FMT-PGM-DATE-TIME CHAR(13) DEF(PGMI0100) POS(
49);
DCL DD FMT-SRC-FILE CHAR(10) DEF(PGMI0100) POS(
62);
DCL DD FMT-SRC-LIB CHAR(10) DEF(PGMI0100) POS(
72);
DCL DD FMT-SRC-MBR CHAR(10) DEF(PGMI0100) POS(
82);
DCL DD FMT-SRC-DATE-TIME CHAR(13) DEF(PGMI0100) POS(
92);
DCL DD FMT-OBS-INFO CHAR( 1) DEF(PGMI0100)
POS(105);
DCL DD FMT-USR-PROFILE CHAR( 1) DEF(PGMI0100)
POS(106);
DCL DD FMT-USE-ADOPTED-AUTH CHAR( 1) DEF(PGMI0100)
POS(107);
DCL DD FMT-LOG-COMMANDS CHAR( 1) DEF(PGMI0100)
POS(108);
DCL DD FMT-ALW-RTVCLSRC CHAR( 1) DEF(PGMI0100)
POS(109);
DCL DD FMT-FIC-DEC-DATA CHAR( 1) DEF(PGMI0100)
POS(110);
DCL DD FMT-TEXT-DESCR CHAR(50) DEF(PGMI0100)
POS(111);
DCL DD FMT-PGM-TYPE CHAR( 1) DEF(PGMI0100)
POS(161);
DCL DD FMT-RESERVED1 CHAR(59) DEF(PGMI0100)
POS(162);
DCL DD FMT-MIN-PARMS BIN(4) DEF(PGMI0100)
POS(221);
DCL DD FMT-MAX-PARMS BIN(4) DEF(PGMI0100)
POS(225);
DCL DD FMT-PGM-SIZE BIN(4) DEF(PGMI0100)
POS(229);
DCL DD FMT-ASC-SPACE-SIZE BIN(4) DEF(PGMI0100)
POS(233);
DCL DD FMT-STATIC-SIZE BIN(4) DEF(PGMI0100)
POS(237);
DCL DD FMT-AUTO-SIZE BIN(4) DEF(PGMI0100)
POS(241);
DCL DD FMT-NBR-MI-INST BIN(4) DEF(PGMI0100)
POS(245);
DCL DD FMT-NBR-ODT-ENTRIES BIN(4) DEF(PGMI0100)
POS(249);
DCL DD FMT-PGM-STATE CHAR( 1) DEF(PGMI0100)
POS(253);
DCL DD FMT-COMPILER-ID CHAR(14) DEF(PGMI0100)
POS(254);
DCL DD FMT-EARLIEST-REL CHAR( 6) DEF(PGMI0100)
POS(268);
DCL DD FMT-SORT-SEQ-TABLE-NAME CHAR(10) DEF(PGMI0100)
POS(274);
DCL DD FMT-SORT-SEQ-TABLE-LIB CHAR(10) DEF(PGMI0100)
POS(284);
DCL DD FMT-LANGUAGE-ID CHAR(10) DEF(PGMI0100)
POS(294);
DCL DD FMT-PGM-DOMAIN CHAR( 1) DEF(PGMI0100)
POS(304);
DCL DD FMT-RESERVED2 CHAR(21) DEF(PGMI0100)
POS(305);
DCL DD FMT-OPTIMIZATION CHAR( 1) DEF(PGMI0100)
POS(326);
DCL DD FMT-PAGING-POOL CHAR( 1) DEF(PGMI0100)
POS(327);
DCL DD FMT-UPDATE-PASA CHAR( 1) DEF(PGMI0100)
POS(328);
DCL DD FMT-CLEAR-PASA CHAR( 1) DEF(PGMI0100)
POS(329);
DCL DD FMT-PAGING-AMOUNT CHAR( 1) DEF(PGMI0100)
POS(330);
DCL DD FMT-RESERVED3 CHAR(18) DEF(PGMI0100)
POS(331);
DCL DD FMT-ILE-ENTRY-MODULE CHAR(10) DEF(PGMI0100)
POS(349);
DCL DD FMT-ILE-ENTRY-MOD-LIB CHAR(10) DEF(PGMI0100)
POS(359);
DCL DD FMT-ILE-ACT-GRP-ATTR CHAR(30) DEF(PGMI0100)
POS(369);
DCL DD FMT-ILE-OBS-COMPRESSED CHAR( 1) DEF(PGMI0100)
POS(399);
DCL DD FMT-ILE-RUN-COMPRESSED CHAR( 1) DEF(PGMI0100)
POS(400);
DCL DD FMT-ILE-RELEASE-ON CHAR( 6) DEF(PGMI0100)
POS(401);
DCL DD FMT-ILE-SHARED-ACT-GRP CHAR( 1) DEF(PGMI0100)
POS(407);
DCL DD FMT-ILE-ALLOW-UPD CHAR( 1) DEF(PGMI0100)
POS(408);
DCL DD FMT-ILE-PGM-CCSID BIN(4) DEF(PGMI0100)
POS(409);
DCL DD FMT-ILE-NBR-OF-MODULES BIN(4) DEF(PGMI0100)
POS(413);
DCL DD FMT-ILE-NBR-OF-SRV-PGMS BIN(4) DEF(PGMI0100)
POS(417);
DCL DD FMT-ILE-NBR-OF-COPYRIGHTS BIN(4) DEF(PGMI0100)
POS(421);
DCL DD FMT-ILE-NBR-OF-UNRESOLVED BIN(4) DEF(PGMI0100)
POS(425);
DCL DD FMT-ILE-RELEASE-FOR CHAR( 6) DEF(PGMI0100)
POS(429);
DCL DD FMT-ILE-ALW-STATIC-REINIT CHAR( 1) DEF(PGMI0100)
POS(435);
DCL SPCPTR .QUALIFIED-PGM-NAME INIT(QUALIFIED-PGM-NAME);
DCL DD QUALIFIED-PGM-NAME CHAR(20);
DCL DD PGM-OBJ CHAR(10) DEF(QUALIFIED-PGM-NAME) POS( 1);
DCL DD PGM-CTX CHAR(10) DEF(QUALIFIED-PGM-NAME) POS(11);
DCL SPCPTR .ERR-CODE INIT(ERR-CODE);
DCL DD ERR-CODE CHAR(32);
DCL DD ERR-CODE-BYTES-PRV BIN(4) POS( 1) INIT(0); /* 0 = IGN
*/
DCL DD ERR-CODE-BYTES-AVL BIN(4) POS( 5);
DCL DD ERR-CODE-EXCP-ID CHAR( 7) POS( 9);
DCL DD ERR-CODE-RESERVED CHAR( 1) POS(16);
DCL DD ERR-CODE-EXCP-DATA CHAR(16) POS(17);
DCL OL QCLRPGMI(.PGMI0100, .PGMI0100-LENGTH, .FORMAT-NAME,
.QUALIFIED-PGM-NAME, .ERR-CODE);
/* LIST FILE PARAMETERS */
DCL SPCPTR .LFCB INIT(LFCB);
DCL DD LFCB CHAR(214) BDRY(16);
DCL SPCPTR .LFCB-ODP DEF(LFCB) POS( 1);
DCL SPCPTR .LFCB-INBUF DEF(LFCB) POS( 17);
DCL SPCPTR .LFCB-OUTBUF DEF(LFCB) POS( 33);
DCL SPCPTR .LFCB-OPEN-FEEDBACK DEF(LFCB) POS( 49);
DCL SPCPTR .LFCB-IO-FEEDBACK DEF(LFCB) POS( 65);
DCL SPCPTR .LFCB-NEXT-UFCB DEF(LFCB) POS( 81);
DCL DD * CHAR(32) DEF(LFCB) POS( 97);
DCL DD LFCB-FILE CHAR(10) DEF(LFCB) POS(129);
DCL DD LFCB-LIB-ID BIN(2) DEF(LFCB) POS(139);
DCL DD LFCB-LIBRARY CHAR(10) DEF(LFCB) POS(141);
DCL DD LFCB-MBR-ID BIN(2) DEF(LFCB) POS(151);
DCL DD LFCB-MEMBER CHAR(10) DEF(LFCB) POS(153);
DCL DD LFCB-DEVICE-NAME CHAR(10) DEF(LFCB) POS(163);
DCL DD LFCB-DEVICE-INDEX BIN(2) DEF(LFCB) POS(173);
DCL DD LFCB-FLAGS-1 CHAR(1) DEF(LFCB) POS(175)
INIT(X'80');
DCL DD LFCB-FLAGS-2 CHAR(1) DEF(LFCB) POS(176)
INIT(X'10');
DCL DD LFCB-REL-VERSION CHAR(4) DEF(LFCB) POS(177);
DCL DD LFCB-INV-MK-COUNT BIN (4) DEF(LFCB) POS(181);
DCL DD LFCB-MORE-FLAGS CHAR(1) DEF(LFCB) POS(185);
DCL DD * CHAR(23) DEF(LFCB) POS(186);
DCL DD LFCB-RECORD-ID BIN (2) DEF(LFCB) POS(209) INIT(1);
DCL DD LFCB-RECORD-LENGTH BIN (2) DEF(LFCB) POS(211) INIT(92);
DCL DD LFCB-NO-MORE-PARMS BIN (2) DEF(LFCB) POS(213)
INIT(32767);
DCL OL OPEN-L(.LFCB);
DCL OL CLOSE-L(.LFCB);
DCL SPCPTR .LBUF;
DCL DD LBUF CHAR(132) BAS(.LBUF);
DCL DD LBUF-ENTRY-NBR ZND(4,0) DEF(LBUF) POS( 1);
DCL DD * CHAR( 1) DEF(LBUF) POS( 5);
DCL DD LBUF-PGM-NAME CHAR(10) DEF(LBUF) POS( 6);
DCL DD * CHAR( 1) DEF(LBUF) POS( 16);
DCL DD LBUF-PGM-LIB CHAR(10) DEF(LBUF) POS( 17);
DCL DD * CHAR( 1) DEF(LBUF) POS( 27);
DCL DD LBUF-PGM-DATE-TIME CHAR(19) DEF(LBUF) POS( 28);
DCL DD * CHAR( 1) DEF(LBUF) POS( 47);
DCL DD LBUF-PGM-TYPE CHAR( 3) DEF(LBUF) POS( 48);
DCL DD * CHAR( 1) DEF(LBUF) POS( 51);
DCL DD LBUF-USR-PROFILE CHAR( 5) DEF(LBUF) POS( 52);
DCL DD * CHAR( 1) DEF(LBUF) POS( 57);
DCL DD LBUF-ADOPT-AUTH CHAR( 4) DEF(LBUF) POS( 58);
DCL DD * CHAR( 1) DEF(LBUF) POS( 62);
DCL DD LBUF-PGM-SIZE CHAR( 8) DEF(LBUF) POS( 63);
DCL DD LBUF-PGM-STATE CHAR( 7) DEF(LBUF) POS( 71);
DCL DD * CHAR( 1) DEF(LBUF) POS( 78);
DCL DD LBUF-PGM-DOMAIN CHAR( 7) DEF(LBUF) POS( 79);
DCL DD * CHAR( 1) DEF(LBUF) POS( 86);
DCL DD LBUF-OWNER CHAR(10) DEF(LBUF) POS( 87);
DCL DD * CHAR( 1) DEF(LBUF) POS( 97);
DCL DD LBUF-PGM-ATTR CHAR( 3) DEF(LBUF) POS( 98);
DCL DD L-PUT BIN(2);
DCL DD PUT-OPT-L BIN(4) INIT(H'10000005');
DCL SPCPTR .PUT-OPT-L INIT(PUT-OPT-L);
DCL OL PUT-L(.LFCB, .PUT-OPT-L, .NULL);
DCL DD AS-400-DATE-TIME CHAR(13);
DCL DD AS-400-C CHAR( 1) DEF(AS-400-DATE-TIME) POS( 1);
DCL DD AS-400-YY CHAR( 2) DEF(AS-400-DATE-TIME) POS( 2);
DCL DD AS-400-MONTH CHAR( 2) DEF(AS-400-DATE-TIME) POS( 4);
DCL DD AS-400-DAY CHAR( 2) DEF(AS-400-DATE-TIME) POS( 6);
DCL DD AS-400-HOUR CHAR( 2) DEF(AS-400-DATE-TIME) POS( 8);
DCL DD AS-400-MIN CHAR( 2) DEF(AS-400-DATE-TIME) POS(10);
DCL DD AS-400-SEC CHAR( 2) DEF(AS-400-DATE-TIME) POS(12);
DCL DD DSP-DATE-TIME CHAR(19);
DCL DD DSP-CENTURY CHAR( 2) DEF(DSP-DATE-TIME) POS( 1);
DCL DD DSP-YY CHAR( 2) DEF(DSP-DATE-TIME) POS( 3);
DCL DD * CHAR( 1) DEF(DSP-DATE-TIME) POS( 5)
INIT("/");
DCL DD DSP-MONTH CHAR( 2) DEF(DSP-DATE-TIME) POS( 6);
DCL DD * CHAR( 1) DEF(DSP-DATE-TIME) POS( 8)
INIT("/");
DCL DD DSP-DAY CHAR( 2) DEF(DSP-DATE-TIME) POS( 9);
DCL DD * CHAR( 1) DEF(DSP-DATE-TIME) POS(11) INIT("
");
DCL DD DSP-HOUR CHAR( 2) DEF(DSP-DATE-TIME) POS(12);
DCL DD * CHAR( 1) DEF(DSP-DATE-TIME) POS(14)
INIT(":");
DCL DD DSP-MIN CHAR( 2) DEF(DSP-DATE-TIME) POS(15);
DCL DD * CHAR( 1) DEF(DSP-DATE-TIME) POS(17)
INIT(":");
DCL DD DSP-SEC CHAR( 2) DEF(DSP-DATE-TIME) POS(18);
DCL DD DATA-ATTR CHAR(7);
DCL DD TYPE CHAR(1) DEF(DATA-ATTR) POS(1) INIT(X'00');
DCL DD LENGTH BIN (2) DEF(DATA-ATTR) POS(2) INIT(4);
DCL DD * BIN (4) DEF(DATA-ATTR) POS(4) INIT(0);
DCL DD S CHAR(180);
DCL DD S-CENTURY-0 CHAR(15) DEF(S) POS( 1) INIT("01 0 19
");
DCL DD S-CENTURY-1 CHAR(15) DEF(S) POS( 16) INIT("01 1 20
");
DCL DD S-USR-PFL-U CHAR(15) DEF(S) POS( 31) INIT("02 U *USER
");
DCL DD S-USR-PFL-O CHAR(15) DEF(S) POS( 46) INIT("02 O *OWNER
");
DCL DD S-ADOPT-AUT-Y CHAR(15) DEF(S) POS( 61) INIT("03 Y *YES
");
DCL DD S-ADOPT-AUT-N CHAR(15) DEF(S) POS( 76) INIT("03 N *NO
");
DCL DD S-PGM-STATE-S CHAR(15) DEF(S) POS( 91) INIT("04 S *SYSTEM
");
DCL DD S-PGM-STATE-U CHAR(15) DEF(S) POS(106) INIT("04 U *USER
");
DCL DD S-PGM-STATE-I CHAR(15) DEF(S) POS(121) INIT("04 I *INHERITS
");
DCL DD S-PGM-DOMN-S CHAR(15) DEF(S) POS(136) INIT("05 S *SYSTEM
");
DCL DD S-PGM-DOMN-U CHAR(15) DEF(S) POS(151) INIT("05 U *USER
");
DCL DD S.END CHAR(15) DEF(S) POS(166) INIT("
");
DCL DD S.STOP CHAR( 4) DEF(S.END) POS(1);
DCL DD S.ENTRY( 12) CHAR(15) DEF(S) POS(1);
DCL DD @NBR BIN(2);
DCL INSPTR .RETURN;
DCL DD @FROM BIN(2);
DCL DD @TO BIN(2);
DCL DD @SIZE BIN(2);
DCL DD EDITED-NBR CHAR(10);
DCL DD NBR-TO-EDIT ZND(10,0) DEF(EDITED-NBR) POS(1);
DCL DD EDIT-CHAR(10) CHAR(1) DEF(EDITED-NBR) POS(1);
DCL DD S.VALUE CHAR(15) INIT(" ");
DCL DD S.MATCH CHAR( 4) DEF(S.VALUE) POS(1);
DCL DD S.TYPE CHAR( 2) DEF(S.MATCH) POS(1);
DCL DD * CHAR( 1) DEF(S.MATCH) POS(3);
DCL DD S.CHAR CHAR( 1) DEF(S.MATCH) POS(4);
DCL DD * CHAR( 1) DEF(S.VALUE) POS(5);
DCL DD S.WORD CHAR(10) DEF(S.VALUE) POS(6);
DCL EXCM * EXCID(H'5001') /* EOF */
BP(EOF-DETECTED) CV("CPF") IMD;
DCL DD GETSEPT-LIB CHAR(10);
DCL SPCPTR .GETSEPT-LIB INIT(GETSEPT-LIB);
DCL OL GETSEPT(.GETSEPT-LIB) ARG;
DCL SYSPTR .GETSEPT INIT("GETSEPT", TYPE(PGM));
/**************************************************************/
ENTRY * (PARAMETERS) EXT;
CPYBWP .NULL, *;
CPYBLAP DFCB-LIBRARY,"LSV", " ";
STPLLEN NBR-OF-PARMS;
CMPNV(B) NBR-OF-PARMS,1 /NEQ(SET-FILES);
CPYBLA DFCB-LIBRARY, PARM-LIB;
SET-FILES:
CPYBLAP DFCB-FILE, "SEPTDUMP", " ";
CPYNV DFCB-LIB-ID, THE-LIB;
CPYNV DFCB-MBR-ID, THE-MBR;
CPYBLA DFCB-MEMBER, DFCB-FILE;
CPYBLAP LFCB-FILE, "SEPTLIST", " ";
CPYNV LFCB-LIB-ID, THE-LIB;
CPYBLA LFCB-LIBRARY, DFCB-LIBRARY;
CPYNV LFCB-MBR-ID, THE-MBR;
CPYBLA LFCB-MEMBER, LFCB-FILE;
GET-DUMPED-SEPT:
CPYBLA GETSEPT-LIB, DFCB-LIBRARY;
CALLX .GETSEPT, GETSEPT, *;
OPEN-DUMP-FILE:
CALLX .SEPT(OPEN-ENTRY), OPEN-D, *;
CPYBWP .DBUF, .DFCB-INBUF;
CPYBWP .ODP-ROOT, .DFCB-ODP;
ADDSPP .DEV-CONTROL-BLOCK, .ODP-ROOT, ODP.DEV-NAMELIST;
CPYNV D-GET, DCB-GET;
OPEN-LIST-FILE:
CALLX .SEPT(OPEN-ENTRY), OPEN-L, *;
CPYBWP .LBUF, .LFCB-OUTBUF;
CPYBWP .ODP-ROOT, .LFCB-ODP;
ADDSPP .DEV-CONTROL-BLOCK, .ODP-ROOT, ODP.DEV-NAMELIST;
CPYNV L-PUT, DCB-PUT;
FIND-DUMP-MARKER:
CALLX .SEPT(D-GET), GET-D, *;
CMPBLA(B) DBUF-MARKER, ".POINTERS-"/NEQ(FIND-DUMP-MARKER);
READ-DUMP-RECORD:
CALLX .SEPT(D-GET), GET-D, *;
CMPBLA(B) DBUF-TYPE, "*PGM"/NEQ(READ-DUMP-RECORD);
GET-PGM-INFO:
CVTCH BINARY-CHARS, DBUF-OFFSET;
DIV ENTRY-NBR, BINARY-VALUE, H'1000';
ADDN(S) ENTRY-NBR, 1;
CPYBLA PGM-OBJ, DBUF-OBJ;
CPYBLA PGM-CTX, DBUF-CTX;
CALLX .SEPT(5088), QCLRPGMI, *; /* GET PGM INFO */
CPYBREP LBUF, " "; /* CLEAR LISTING FIRST */
CPYNV LBUF-ENTRY-NBR , ENTRY-NBR ;
CPYBLA LBUF-PGM-NAME , FMT-PGM-NAME ;
CPYBLA LBUF-PGM-LIB , FMT-PGM-LIB ;
CPYBLA LBUF-OWNER , FMT-OWNER ;
CPYBLA LBUF-PGM-ATTR , FMT-PGM-ATTR ;
CPYBLA AS-400-DATE-TIME , FMT-PGM-DATE-TIME ;
CPYBLA S.TYPE, "01";
CPYBLA S.CHAR, AS-400-C;
CALLI GET-DISPLAY-VALUE, *, .RETURN;
CPYBLA DSP-CENTURY, S.WORD; /* FORMAT DATE */
CPYBLA DSP-YY , AS-400-YY;
CPYBLA DSP-MONTH , AS-400-MONTH;
CPYBLA DSP-DAY , AS-400-DAY;
CPYBLA DSP-HOUR , AS-400-HOUR; /* FORMAT TIME */
CPYBLA DSP-MIN , AS-400-MIN;
CPYBLA DSP-SEC , AS-400-SEC;
CPYBLA LBUF-PGM-DATE-TIME, DSP-DATE-TIME;
CPYBLA S.TYPE, "02";
CPYBLA S.CHAR, FMT-USR-PROFILE;
CALLI GET-DISPLAY-VALUE, *, .RETURN;
CPYBLA LBUF-USR-PROFILE, S.WORD;
CPYBLA S.TYPE, "03";
CPYBLA S.CHAR, FMT-USE-ADOPTED-AUTH;
CALLI GET-DISPLAY-VALUE, *, .RETURN;
CPYBLA LBUF-ADOPT-AUTH, S.WORD;
CPYBLA S.TYPE, "04";
CPYBLA S.CHAR, FMT-PGM-STATE;
CALLI GET-DISPLAY-VALUE, *, .RETURN;
CPYBLA LBUF-PGM-STATE, S.WORD;
CPYBLA S.TYPE, "05";
CPYBLA S.CHAR, FMT-PGM-DOMAIN;
CALLI GET-DISPLAY-VALUE, *, .RETURN;
CPYBLA LBUF-PGM-DOMAIN, S.WORD;
CPYNV NBR-TO-EDIT, FMT-PGM-SIZE;
CALLI REMOVE-LEADING-ZEROES, *, .RETURN;
CPYBLA LBUF-PGM-SIZE, EDITED-NBR;
OUTPUT-EXTRACTED-INFO:
CALLX .SEPT(L-PUT), PUT-L, *;
B READ-DUMP-RECORD;
EOF-DETECTED:
CLOSE-ALL-FILES:
CALLX .SEPT(CLOSE-ENTRY), CLOSE-D, *;
CALLX .SEPT(CLOSE-ENTRY), CLOSE-L, *;
RTX *;
/* FIND A SUBSTITUTION VALUE IN A TABLE */
ENTRY GET-DISPLAY-VALUE INT;
CPYNV @NBR, 0;
CPYBLA S.STOP, S.MATCH; /* ENSURE ALWAYS MATCH */
NEXT-DISPLAY-ENTRY:
ADDN(S) @NBR, 1; /* CMPBLA BELOW USES SIZE OF SHORTEST OP
*/
CMPBLA(B) S.ENTRY (@NBR), S.MATCH/NEQ(NEXT-DISPLAY-ENTRY);
CPYBLA S.VALUE, S.ENTRY (@NBR);
B .RETURN;
/* REMOVE LEADING ZEROES FROM NUMERIC VALUE */
ENTRY REMOVE-LEADING-ZEROES INT;
CPYNV @SIZE, 10; /* MUST BE AT LEAST 2 */
FROM-BEGINNING-OF-NBR:
CPYNV @TO, 1;
CMPBLA(B) EDIT-CHAR(@TO), "0"/NEQ(.RETURN);
SHIFT-DIGITS-LEFT:
ADDN @FROM, @TO, 1;
CPYBLA EDIT-CHAR(@TO), EDIT-CHAR(@FROM);
CPYNV @TO, @FROM;
CMPNV(B) @TO, @SIZE/NEQ(SHIFT-DIGITS-LEFT);
CPYBLA EDIT-CHAR(@SIZE), " ";
SUBN(SB) @SIZE, 1/POS(FROM-BEGINNING-OF-NBR); /* ALWAYS */
PEND;
Compile the program with: CRTMIPGM RTVSEPT, then run it: CALL
RTVSEPT. It takes about 13 minutes to complete. Use WRKF FILE(LSV/SETLIST)
to display the result.
The Report
The resulting report looks like this:
0001 QT3REQIO QSYS 1998/05/05 10:08:37 *USER *YES 69632
*SYSTEM *SYSTEM QSYS
0002 QWSCLOSE QSYS 1998/03/18 02:06:25 *USER *YES 57344
*SYSTEM *SYSTEM QSYS
0003 QSFGET QSYS 1998/03/18 03:56:34 *USER *YES 32768
*SYSTEM *SYSTEM QSYS
0004 QWSOPEN QSYS 1998/03/18 19:35:14 *USER *YES 102400
*SYSTEM *SYSTEM QSYS
0005 QWSPBDVR QSYS 1998/03/18 01:05:05 *USER *YES 28672
*SYSTEM *SYSTEM QSYS
0006 QWSRST QSYS 1998/03/18 02:07:49 *USER *YES 40960
*SYSTEM *SYSTEM QSYS
0007 QWSRTSFL QSYS 1998/03/18 19:31:44 *USER *YES 180224
*SYSTEM *SYSTEM QSYS
0008 QSFCRT QSYS 1998/03/18 03:56:12 *USER *YES 36864
*SYSTEM *SYSTEM QSYS
0009 QWSSPEND QSYS 1998/03/18 01:07:59 *USER *YES 36864
*SYSTEM *SYSTEM QSYS
0010 QDCVRX QSYS 1998/03/17 23:33:48 *USER *YES 36864
*SYSTEM *SYSTEM QSYS
0011 QDMCLOSE QSYS 1998/03/18 15:36:56 *USER *YES 49152
*SYSTEM *USER QSYS
0012 QDMCOPEN QSYS 1998/06/25 08:15:21 *USER *YES 176128
*SYSTEM *USER QSYS
0013 QDBCLOSE QSYS 1998/05/18 23:04:18 *USER *YES 32768
*SYSTEM *SYSTEM QSYS
. . .
2899 QCLRDTAQ QSYS 1998/05/13 11:34:32 *USER *YES 40960
*SYSTEM *USER QSYS
2900 QCJASFVR QSYS 1998/03/17 15:58:22 *USER *YES 24576
*SYSTEM *SYSTEM QSYS
2901 QMHQCRTQ QSYS 1998/03/18 16:17:09 *USER *YES 24576
*SYSTEM *SYSTEM QSYS
2902 QMHQDLTQ QSYS 1998/03/17 23:44:01 *OWNE *YES 20480
*SYSTEM *SYSTEM QSYS
2903 QMHQREGQ QSYS 1998/03/17 23:44:04 *USER *YES 32768
*SYSTEM *SYSTEM QSYS
. . .
5087 QCLRPGAS QSYS 1998/03/17 18:10:33 *USER *YES 36864
*SYSTEM *USER QSYS
5088 QCLRPGMI QSYS 1998/03/18 15:16:52 *USER *YES 65536
*SYSTEM *USER QSYS
5089 QCLSPGAS QSYS 1998/03/17 18:10:38 *USER *YES 45056
*SYSTEM *USER QSYS
. . .
6243 QSOINST QSYS 1998/04/01 16:21:54 *USER *YES 45056
*SYSTEM *SYSTEM QSYS
6244 QTNXAEVT QSYS 1998/04/21 23:46:00 *USER *YES 32768
*SYSTEM *SYSTEM QSYS
6245 QTOFJRNL QSYS 1998/03/18 00:33:57 *OWNE *YES 20480
*SYSTEM *SYSTEM QSYS
This is all V4R3M0. Other releases will show different stuff for
objects in the
system domain.
+---
| This is the MI Programmers Mailing List!
| To submit a new message, send your mail to MI400@midrange.com.
| To subscribe to this list send email to MI400-SUB@midrange.com.
| To unsubscribe from this list send email to MI400-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: dr2@cssas400.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
