|
midrange.com
h
To All,
I found some old notes of mine regarding these programs so I thought I would
incorporate them in the documentation I sent earlier. The updates incorporate
the supported special values and Gene's comment regarding LVLCHK(*NO). At the
end you will find CMD and CL source for using them which I wrote years ago,
hence the code to cope with S/38 -- remember that :)
QSCMATPG
1 Program name Input CHAR(10)
2 Library name Input CHAR(10)
3 File name Input CHAR(10)
4 File library Input CHAR(10)
5 Member name Input CHAR(10)
6 Member option Input CHAR(8)
The Materialize Program (QSCMATPG) API retrieves the program template for an
OPM
program and places it in the specified file member.
Program name: The name of the program to materalize.
Library name: The name of the library containing the program. *LIBL is
supported.
File name: The name of the output file. This is a physical file with a
record length of 80 bytes and LVLCHK(*NO). The file must exist before the API
is called.
File library: The name of the library containing the output file. *LIBL is
supported.
Member name: The name of the member to receive the program template. *PGM
causes the program template to be stored in a member with the same name as the
program.
Member option: *ADD or *REPLACE
QSCCRTPG
1 Program name Input CHAR(10)
2 Library name Input CHAR(10)
3 File name Input CHAR(10)
4 File library Input CHAR(10)
5 Member name Input CHAR(10)
The Create Program (QSCCRTPG) API creates a program from the program template
retrieved by the Materialise Program (QSCMATPG) API.
Program name: The name of the program to create.
Library name: The name of the library to contain the program. Special values
are
not supported.
File name: The name of the file containing the program template. This is a
physical file with a record length of 80 bytes. The file must exist before the
API is called.
File library: The name of the library containing the file. *LIBL is supported.
Member name: The name of the member containing the program template. *PGM
uses
a member with the same name as the program.
Example code:
MATPG: CMD PROMPT('Materialise Program Template')
PARM KWD(PGM) TYPE(Q1) MIN(1) PROMPT('Program')
PARM KWD(FILE) TYPE(Q2) MIN(1) PROMPT('File')
PARM KWD(MBR) TYPE(*NAME) DFT(*PGM) SPCVAL((*PGM) +
(*FILE)) EXPR(*YES) PROMPT('Member')
PARM KWD(MBROPT) TYPE(*CHAR) LEN(8) RSTD(*YES) +
DFT(*REPLACE) VALUES(*REPLACE *ADD) +
PROMPT('Replace or add records')
Q1: QUAL TYPE(*NAME) MIN(1) EXPR(*YES)
hUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
EXPR(*YES) PROMPT('Library')
Q2: QUAL TYPE(*NAME) MIN(1) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*CURLIB) SPCVAL((*CURLIB +
*CURLIB) (*LIBL)) EXPR(*YES) +
PROMPT('Library')
MATPGC: PGM PARM(&QUALPGM &QUALFILE &MBR &MBROPT)
/* */
/*----------------- Input Parameter Declarations ------------------*/
/* */
DCL VAR(&QUALPGM) TYPE(*CHAR) LEN(20)
/* NameLibrary */
DCL VAR(&QUALFILE) TYPE(*CHAR) LEN(20)
/* NameLibrary */
DCL VAR(&MBR) TYPE(*CHAR) LEN(10)
/* Work file member */
DCL VAR(&MBROPT) TYPE(*CHAR) LEN(8)
/* *ADD or *REPLACE */
/* */
/*-------------------- Program Declarations -----------------------*/
/* */
DCL VAR(&PGM) TYPE(*CHAR) LEN(10)
DCL VAR(&PLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&FILE) TYPE(*CHAR) LEN(10)
/* Program template work file */
DCL VAR(&FLIB) TYPE(*CHAR) LEN(10)
/* Work file library */
DCL VAR(&REALLIB) TYPE(*CHAR) LEN(10) /* Actual +
library containing program (for *LIBL +
search) */
DCL VAR(&MSGTYPE) TYPE(*CHAR) LEN(5)
DCL VAR(&IGC) TYPE(*CHAR) LEN(1)
/* */
/*----------------- Mnemonic Value Declarations -------------------*/
/* */
DCL VAR(&BLANK) TYPE(*CHAR) LEN(1) VALUE(X'40')
/* Mnemonic for 'blank' */
DCL VAR(&TRUE) TYPE(*LGL) LEN(1) VALUE('1')
/* Mnemonic for 'true' */
DCL VAR(&FALSE) TYPE(*LGL) LEN(1) VALUE('0')
/* Mnemonic for 'false' */
DCL VAR(&ERROR) TYPE(*LGL) LEN(1)
/* Mnemonic for 'error' */
/* */
/*-------------- Global Message Monitor Declarations --------------*/
/* */
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(40)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
/* */ h
/*--------------- Global Message Monitor Intercept ----------------*/
/* */
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Substring out the program and library names */
CHGVAR VAR(&PGM) VALUE(%SST(&QUALPGM 1 10))
CHGVAR VAR(&PLIB) VALUE(%SST(&QUALPGM 11 10))
CHGVAR VAR(&REALLIB) VALUE(&PLIB)
CHGVAR VAR(&FILE) VALUE(%SST(&QUALFILE 1 10))
CHGVAR VAR(&FLIB) VALUE(%SST(&QUALFILE 11 10))
/* Handle special values from command definition */
IF COND(&MBR *EQ '*PGM') THEN(DO)
CHGVAR VAR(&MBR) VALUE(&PGM)
ENDDO
IF COND(&MBR *EQ '*FILE') THEN(DO)
CHGVAR VAR(&MBR) VALUE(&FILE)
ENDDO
/* ********************************************************** */
/* If '*LIBL' was passed in for library, get the name of the */
/* actual library containing the program. */
/* */
/* The trick to determining the library of an existing object */
/* is as follows: */
/* */
/* 1. Rename the object to itself */
/* 2. CPF returns a message informing that the object was */
/* not renamed. */
/* On the AS/400, an escape message is sent. */
/* On the S/38, an informational message is sent */
/* This code section works on either machine. */
/* 3. The library of the object is in positions 11 - 20 */
/* of the message data associated with the message. */
/* ********************************************************** */
IF COND(&REALLIB *EQ '*LIBL') THEN(DO)
CHGVAR VAR(&MSGTYPE) VALUE('*INFO')
RNMOBJ OBJ(&PGM) OBJTYPE(*PGM) NEWOBJ(&PGM)
MONMSG MSGID(CPF2132) EXEC(DO)
CHGVAR VAR(&MSGTYPE) VALUE('*EXCP')
ENDDO
RCVMSG MSGTYPE(&MSGTYPE) MSGDTA(&MSGDTA) MSGID(&MSGID)
CHGVAR VAR(&REALLIB) VALUE(%SST(&MSGDTA 11 10))
ENDDO /* RealLib */
/* Allocate the program */
ALCOBJ OBJ((&REALLIB/&PGM *PGM *EXCL))
/* Ensure work file and member exist */
CHKOBJ OBJ(&FLIB/&FILE) OBJTYPE(*FILE)
MONMSG MSGID(CPF9801) EXEC(DO)
RCVMSG MSGTYPE(*LAST)
RTVSYSVAL SYSVAL(QIGC) RTNVAR(&IGC)
IF COND(&IGC *EQ '1') THEN(DO)
CRTPF FILE(&FLIB/&FILE) RCDLEN(80) MBR(&MBR) +
TEXT('Work file for MATPG/CRTPG command.'h +
OPTION(*NOLIST *NOSOURCE) MAXMBRS(*NOMAX) +
SIZE(*NOMAX) LVLCHK(*NO) IGCDTA(*YES)
ENDDO
ELSE CMD(DO)
CRTPF FILE(&FLIB/&FILE) RCDLEN(80) MBR(&MBR) +
TEXT('Work file for MATPG/CRTPG command.') +
OPTION(*NOLIST *NOSOURCE) MAXMBRS(*NOMAX) +
SIZE(*NOMAX) LVLCHK(*NO)
ENDDO
ENDDO
CLRPFM FILE(&FLIB/&FILE) MBR(&MBR)
MONMSG MSGID(CPF3141) EXEC(DO)
RCVMSG MSGTYPE(*LAST)
ADDPFM FILE(&FLIB/&FILE) MBR(&MBR)
ENDDO
/* ************************************************************ */
/* Call the CPF module to materialise the program. */
/* This will convert the internal representation of the program */
/* into an external form we can modify. */
/* The materialised information is placed in the work file. */
/* Note:- this interface is not supported after V2R1.1. */
/* ************************************************************ */
CALL PGM(QSCMATPG) PARM(&PGM &REALLIB &FILE +
&FLIB &MBR &MBROPT)
/* */
/*--------------------- Send User a Message -----------------------*/
/* */
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Program' *BCAT &PGM *BCAT 'in' +
*BCAT &REALLIB *BCAT 'materialised in +
member' *BCAT &MBR *BCAT 'in file' *BCAT +
&FILE *BCAT 'in' *BCAT &FLIB) MSGTYPE(*COMP)
EXIT: RETURN /* Normal end of program */
/* */
/*---------------------- Exception Routine ------------------------*/
/* */
ERROR: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) MSGFLIB(&MSGFLIB)
MONMSG MSGID(CPF0000 MCH0000) EXEC(RETURN)
/* Just in case */
IF COND(&MSGID *NE &BLANK) THEN(DO)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000 MCH0000) EXEC(RETURN)
/* Just in case */
ENDDO
MATPGX: ENDPGM
CRTPG: CMD PROMPT('Create Program from Template')
h PARM KWD(PGM) TYPE(Q1) MIN(1) PROMPT('Program')
PARM KWD(FILE) TYPE(Q2) MIN(1) PROMPT('File')
PARM KWD(MBR) TYPE(*NAME) DFT(*PGM) SPCVAL((*PGM) +
(*FILE)) EXPR(*YES) PROMPT('Member')
Q1: QUAL TYPE(*NAME) MIN(1) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*CURLIB) SPCVAL((*CURLIB +
*CURLIB)) EXPR(*YES) PROMPT('Library')
Q2: QUAL TYPE(*NAME) MIN(1) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL) +
(*CURLIB *CURLIB)) EXPR(*YES) +
PROMPT('Library')
CRTPGC: PGM PARM(&QUALPGM &QUALFILE &MBR)
/* */
/*----------------- Input Parameter Declarations ------------------*/
/* */
DCL VAR(&QUALPGM) TYPE(*CHAR) LEN(20)
/* NameLibrary */
DCL VAR(&QUALFILE) TYPE(*CHAR) LEN(20)
/* NameLibrary */
DCL VAR(&MBR) TYPE(*CHAR) LEN(10)
/* Work file member */
/* */
/*-------------------- Program Declarations -----------------------*/
/* */
DCL VAR(&PGM) TYPE(*CHAR) LEN(10)
DCL VAR(&PLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&FILE) TYPE(*CHAR) LEN(10)
/* Program template work file */
DCL VAR(&FLIB) TYPE(*CHAR) LEN(10)
/* Work file library */
DCL VAR(&REALLIB) TYPE(*CHAR) LEN(10) /* Actual +
library containing file (for *LIBL +
search) */
DCL VAR(&MSGTYPE) TYPE(*CHAR) LEN(5)
DCLF FILE(QADSPOBJ)
/* */
/*----------------- Mnemonic Value Declarations -------------------*/
/* */
DCL VAR(&BLANK) TYPE(*CHAR) LEN(1) VALUE(X'40')
/* Mnemonic for 'blank' */
DCL VAR(&TRUE) TYPE(*LGL) LEN(1) VALUE('1')
/* Mnemonic for 'true' */
DCL VAR(&FALSE) TYPE(*LGL) LEN(1) VALUE('0')
/* Mnemonic for 'false' */
DCL VAR(&ERROR) TYPE(*LGL) LEN(1)
/* Mnemonic for 'error' */
/* */
/*-------------- Global Message Monithr Declarations --------------*/
/* */
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(40)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
/* */
/*--------------- Global Message Monitor Intercept ----------------*/
/* */
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Substring out the program and library names */
CHGVAR VAR(&PGM) VALUE(%SST(&QUALPGM 1 10))
CHGVAR VAR(&PLIB) VALUE(%SST(&QUALPGM 11 10))
CHGVAR VAR(&FILE) VALUE(%SST(&QUALFILE 1 10))
CHGVAR VAR(&FLIB) VALUE(%SST(&QUALFILE 11 10))
CHGVAR VAR(&REALLIB) VALUE(&FLIB)
/* Handle special values from command definition */
IF COND(&MBR *EQ '*PGM') THEN(DO)
CHGVAR VAR(&MBR) VALUE(&PGM)
ENDDO
IF COND(&MBR *EQ '*FILE') THEN(DO)
CHGVAR VAR(&MBR) VALUE(&FILE)
ENDDO
/* ********************************************************** */
/* If '*LIBL' was passed in for library, get the name of the */
/* actual library containing the file. */
/* */
/* The trick to determining the library of an existing object */
/* is as follows: */
/* */
/* 1. Rename the object to itself */
/* 2. CPF returns a message informing that the object was */
/* not renamed. */
/* On the AS/400, an escape message is sent. */
/* On the S/38, an informational message is sent */
/* This code section works on either machine. */
/* 3. The library of the object is in positions 11 - 20 */
/* of the message data associated with the message. */
/* ********************************************************** */
IF COND(&REALLIB *EQ '*LIBL') THEN(DO)
CHGVAR VAR(&MSGTYPE) VALUE('*INFO')
RNMOBJ OBJ(&FILE) OBJTYPE(*FILE) NEWOBJ(&FILE)
MONMSG MSGID(CPF2132) EXEC(DO)
CHGVAR VAR(&MSGTYPE) VALUE('*EXCP')
ENDDO
RCVMSG MSGTYPE(&MSGTYPE) MSGDTA(&MSGDTA) MSGID(&MSGID)
CHGVAR VAR(&REALLIB) VALUE(%SST(&MSGDTA 11 10))
ENDDO /* RealLib */
/* Allocate the program */
ALCOBJ OBJ((&PLIB/&PGM *PGM *EXCL))
MONMSG MSGID(CPF1085) EXEC(DO)
RCVMSG MSGTYPE(*EXCP) h
GOTO CMDLBL(CREATE) /* Not found */
ENDDO
/* Ensure work file and member exist */
CHKOBJ OBJ(&REALLIB/&FILE) OBJTYPE(*FILE) MBR(&MBR)
/* Find out the current owner of the object */
DSPOBJD OBJ(&PLIB/&PGM) OBJTYPE(*PGM) +
DETAIL(*SERVICE) OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/@RTVPGMOWN)
OVRDBF FILE(QADSPOBJ) TOFILE(QTEMP/@RTVPGMOWN)
RCVF
/* Delete the existing program */
DLTPGM PGM(&PLIB/&PGM)
/* ************************************************************ */
/* Call the CPF module to recreate the program from the update */
/* program template. */
/* Note:- this interface is not supported after V2R1.1. */
/* ************************************************************ */
CREATE: CALL PGM(QSCCRTPG) PARM(&PGM &PLIB &FILE +
&REALLIB &MBR)
/* Ensure the original owner still owns the program */
/* Note:- Need to adopt GOD to ensure this works */
IF COND(&ODOBOW *NE &BLANK) THEN(DO)
CHGOBJOWN OBJ(&REALLIB/&PGM) OBJTYPE(*PGM) +
NEWOWN(&ODOBOW)
ENDDO
/* */
/*--------------------- Send User a Message -----------------------*/
/* */
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Program' *BCAT &PGM *BCAT 'in' +
*BCAT &REALLIB *BCAT 'created from +
member' *BCAT &MBR *BCAT 'in file' *BCAT +
&FILE *BCAT 'in' *BCAT &FLIB) MSGTYPE(*COMP)
EXIT: RETURN /* Normal end of program */
ERROR: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) MSGFLIB(&MSGFLIB)
MONMSG MSGID(CPF0000 MCH0000) EXEC(RETURN)
/* Just in case */
IF COND(&MSGID *NE &BLANK) THEN(DO)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000 MCH0000) EXEC(RETURN)
/* Just in case */
ENDDO
CRTPGX: ENDPGM
Regards,
Simon Coulter.
FlyByNight Software AS/400 Technical Specialists
Eclipse
the competition - run your business on an IBM AS/400.
Phone: +61 3 9419 0175 Mobile: +61 0411 091 400 /"\
Fax: +61 3 9419 0175 mailto: shc@flybynight.com.au \ /
X
ASCII Ribbon campaign against HTML E-Mail / \
+---
| 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-2025 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.
