01e - Varie Programmazione IBM i04g - Varie sistemistica05a - Varie Web Service con IBM i

Come estrarre le informazioni sull’interfaccia programma (PCML) incorporate nei programmi o nei programmi di servizio

10 Marzo 2023

Cos’è il PCML?

Il Program Call Markup Language (PCML) è un linguaggio di tag basato sull’Extensible Markup Language (XML) che descrive i parametri di input e di output di un programma o le procedure esportate di un modulo che fa parte di un programma di servizio.

Sebbene il PCML sia stato progettato per gestire le chiamate a programmi server da parte di programmi ad oggetti di tipo distribuiti si solito da piattaforme Java client, è possibile utilizzarlo anche per effettuare chiamate a programmi server da parte di programmi client che risiedono sul medesimo ambiente di quelli server.

Chi lo utilizza?

IBM Toolbox for Java include un’interfaccia di programmazione delle applicazioni (API) che interpreta il PCML, chiama il programma e semplifica il recupero dei dati restituiti dal sistema IBM i.

Un enorme vantaggio di PCML è che ti consente di scrivere meno codice. Normalmente, è necessario codice aggiuntivo per connettere, richiamare e tradurre i dati tra un server e gli oggetti IBM Toolbox per Java. Tuttavia, utilizzando PCML, le chiamate al server con le classi IBM Toolbox per Java vengono gestite automaticamente. Gli oggetti di classe PCML vengono generati dai tag PCML e aiutano a ridurre al minimo la quantità di codice da scrivere per richiamare i programmi server dall’applicazione.

I Servizi Web Integrati (IWS) di IBM i possono utilizzare il PCML incorporato in un programma o in un programma di servizio per generare un servizio web.

Come viene creato?

I compilatori ILE COBOL e ILE RPG, durante la fase di creazione del modulo, possono generare il PCML in un file di flusso, utilizzando i parametri PGMINFO(*PCML *STMF) e INFOSTMF('mymodule.pcml'), oppure nel modulo stesso (e di conseguenza nel programma che lo includerà), utilizzando PGMINFO(*PCML *MODULE), o in entrambi, specificando i parametri PGMINFO(*PCML *ALL) e INFOSTMF('mymodule.pcml').

Nota. Le medesime direttive per il compilatore possono essere inserite nel codice sorgente (in Cobol si utilizza la dichiarazione PROCESS per indicare le opzioni di compilazione da utilizzare, quindi, ad esempio: PROCESS PGMINFO(PCML MODULE), mentre in RPG si utilizza il codice operativo Ctl-Opt, quindi, ad esempio: Ctl-Opt PgmInfo(*PCML: *MODULE)).

Ovviamente, quando il PCML viene incorporato in un modulo, esso diventa parte del programma o del programma di servizio in cui il modulo viene incluso.

Se i moduli ILE RPG o ILE COBOL incorporano il PCML allora è possibile estrarlo o anche solo verificarne l’esistenza. Questo può essere fatto utilizzando l’API QBNRPII (Retrieve Program Interface Information).

CPYPCMLSTM

Il programma CPYPCMLSTM è un’implementazione in linguaggio ILE CL dell’API QBNRPII. Le informazioni sull’interfaccia programma in formato PCML vengono estratte dai moduli compilati con i parametri PGMINFO(*PCML *MODULE) o PGMINFO(*PCML *ALL) inclusi in un programma o in un programma di servizio e copiate in uno spazio utente (in modo da poter allocare dinamicamente la memoria necessaria per contenere tali informazioni) quindi trasformate nel consueto formato per una maggior leggibilità (il PCML estratto dall’API è una stringa di caratteri senza formattazione) ed infine scritte in un file di flusso su IFS utilizzando il servizio SQL IFS_WRITE di IBM i.

Ecco come si presenta il comando:

                   Copy PCML from module to STMF (CPYPCMLSTM)

 Immettere le scelte e premere Invio.

 Object (containing module) . . .                 Nome
   Library  . . . . . . . . . . .     *LIBL       Nome, *CURLIB, *LIBL
 Object type  . . . . . . . . . .   *PGM          *PGM, *SRVPGM
 Module . . . . . . . . . . . . .   *ALLBNDMOD    Nome, *ALLBNDMOD
   Library  . . . . . . . . . . .                 Nome, *ANY
 Target directory . . . . . . . .                                               
      
 STMF CCSID . . . . . . . . . . .   *UTF8         1-65533, *UTF8, *PCASCII...   
 STMF EOL . . . . . . . . . . . .   *CRLF         *CRLF, *LF, *CR, *LFCR

Di seguito una breve descrizione dei parametri (gli stessi dell’API QBNRPII, ad eccezione dei parametri TODIR, STMFCCSID, STMFEOL che vengono utilizzati dal servizio SQL IFS_WRITE per scrivere il file di flusso):

  • OBJ: specifica il programma o il programma di servizio che include i moduli contenenti i PCML da estrarre;
  • OBJTYPE: specifica il tipo di oggetto da dove estrarre le informazioni le informazioni sull’interfaccia (*PGM, valore predefinito, o *SRVPGM);
  • MODULE: specifica il modulo dal quale estrarre il PCML (il valore predefinito è *ALLBNDMOD);
  • TODIR: specifica il percorso IFS dove scrivere il/i PCML (il/i file di flusso contenente/i il/i PCML saranno chiamati objectname_modulename.pcml);
  • STMFCCSID: specifica il CCSID utilizzato nella creazione del/i/ file di flusso di output (il valrore predefinito è *UTF8);
  • STMFEOL: specifica la sequenza di caratteri di fine riga da scrivere nel file di flusso di output (il valore predefinito è *CRLF).

Quindi, ad esempio, se si desidera recuperare tutti i moduli contenuti nel programma PGMX e scriverli nella directory /DIRZ utilizzando la codifica dei caratteri UTF-8 con ritorno a capo e avanzamento di riga (CRLF) come sequenza di terminazione della riga (valore predefinito), si deve immettere il seguente comando:

CPYPCMLSTM OBJ(PGMX) OBJTYPE(*PGM) MODULE(*ALLBNDMOD) TODIR('/DIRZ') STMFCCSID(*UTF8) STMFEOL(*CRLF)

L’esecuzione di questo comando genererà tanti file di output PCML quanti sono i moduli con PCML incluso contenuti nel programma.

Se, invece, si volesse estrarre nel percorso /DIRZ il PCML estratto dal modulo LIBY/MODY collegato al programma di servizio PGMX utilizzando l’identificatore 819 del set di caratteri codificati ed il line feed come sequenza di terminazione della riga, si dovrebbe digitare:

CPYPCMLSTM OBJ(PGMX) OBJTYPE(*SRVPGM) MODULE(LIBY/MODY) TODIR('/DIRZ') STMFCCSID(*UNIX) STMFEOL(*LF)

Qui sotto un esempio di output del comando e un esempio di file di output contenente un PCML estratto con il comando CPYPCMLSTM:

Program Call Markup Language (PCML) found: 2.
Program Call Markup Language (PCML) data for MOD(QTEMP/MODX) in
  PGM(QGPL/TESTPGM) copied to file
  '/DIRZ/TESTPGM_MODX.pcml'.
Program Call Markup Language (PCML) data for MOD(QTEMP/MODY) in
  PGM(QGPL/TESTPGM) copied to file
  '/DIRZ/TESTPGM_MODY.pcml'.
Program Call Markup Language (PCML) retrieved: 2.
<pcml version="4.0">
   <program name="MODY" entrypoint="MODY">
      <struct name="RMODY-PARM" usage="inputoutput">
         <struct name="RMODY-INPUT" usage="inherit">
            <data name="RMODY-CD-DFE" type="zoned" length="8" precision="0" usage="inherit" />
            <data name="RMODY-CD-VERSIONE-DFE" type="zoned" length="2" precision="0" usage="inherit" />
            <data name="RMODY-FL-BENEFICIARI" type="char" length="2" usage="inherit" />
            <data name="RMODY-RAGSOC-BEN1" type="char" length="55" usage="inherit" />
            <data name="RMODY-NOME-BEN1" type="char" length="55" usage="inherit" />
            <data name="RMODY-CF-PIVA-BEN1" type="char" length="16" usage="inherit" />
            <data name="RMODY-INDIR-BEN1" type="char" length="40" usage="inherit" />
            <data name="RMODY-LOCAL-BEN1" type="char" length="30" usage="inherit" />
            <data name="RMODY-CAP-BEN1" type="char" length="5" usage="inherit" />
            <data name="RMODY-PROV-BEN1" type="char" length="2" usage="inherit" />
            <data name="RMODY-TEL-BEN1" type="char" length="13" usage="inherit" />
            <data name="RMODY-EMAIL-BEN1" type="char" length="80" usage="inherit" />
            <data name="RMODY-RELAZIONE-BEN1" type="char" length="30" usage="inherit" />
            <data name="RMODY-FLINVIO-BEN1" type="char" length="2" usage="inherit" />
            <data name="RMODY-RAGSOC-BEN2" type="char" length="55" usage="inherit" />
            <data name="RMODY-NOME-BEN2" type="char" length="55" usage="inherit" />
            <data name="RMODY-CF-PIVA-BEN2" type="char" length="16" usage="inherit" />
            <data name="RMODY-INDIR-BEN2" type="char" length="40" usage="inherit" />
            <data name="RMODY-LOCAL-BEN2" type="char" length="30" usage="inherit" />
            <data name="RMODY-CAP-BEN2" type="char" length="5" usage="inherit" />
            <data name="RMODY-PROV-BEN2" type="char" length="2" usage="inherit" />
            <data name="RMODY-TEL-BEN2" type="char" length="13" usage="inherit" />
            <data name="RMODY-EMAIL-BEN2" type="char" length="80" usage="inherit" />
            <data name="RMODY-RELAZIONE-BEN2" type="char" length="30" usage="inherit" />
            <data name="RMODY-FLINVIO-BEN2" type="char" length="2" usage="inherit" />
            <data name="RMODY-RAGSOC-REF3" type="char" length="55" usage="inherit" />
            <data name="RMODY-NOME-REF3" type="char" length="55" usage="inherit" />
            <data name="RMODY-CF-PIVA-REF3" type="char" length="16" usage="inherit" />
            <data name="RMODY-INDIR-REF3" type="char" length="40" usage="inherit" />
            <data name="RMODY-LOCAL-REF3" type="char" length="30" usage="inherit" />
            <data name="RMODY-CAP-REF3" type="char" length="5" usage="inherit" />
            <data name="RMODY-PROV-REF3" type="char" length="2" usage="inherit" />
            <data name="RMODY-TEL-REF3" type="char" length="13" usage="inherit" />
            <data name="RMODY-EMAIL-REF3" type="char" length="80" usage="inherit" />
         </struct>
      </struct>
      <struct name="RMODY-RC" usage="inputoutput">
         <data name="RMODY-RETCOD" type="char" length="7" usage="inherit" />
      </struct>
   </program>
</pcml>

Di seguito i sorgenti del comando e del programma CLLE:

             CMD        PROMPT('Copy PCML from module to STMF')
             PARM       KWD(OBJ) TYPE(QOBJ) MIN(1) PROMPT('Object +
                          (containing module)' 1)
             PARM       KWD(TODIR) TYPE(*PNAME) LEN(128) MIN(1) EXPR(*YES) +
                          PROMPT('Target directory' 4)
             PARM       KWD(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
                          DFT(*PGM) SPCVAL((*PGM) (*SRVPGM)) EXPR(*YES) +
                          PROMPT('Object type' 2)
             PARM       KWD(MODULE) TYPE(QMOD) DFT(*ALLBNDMOD) +
                          SNGVAL((*ALLBNDMOD)) PROMPT('Module' 3)
             PARM       KWD(STMFCCSID) TYPE(*INT4) DFT(*UTF8) RANGE(1 +
                          65533) SPCVAL((*UTF8 1208) (*PCASCII 1252) +
                          (*STDASCII 850) (*UNIX 819)) EXPR(*YES) +
                          PROMPT('STMF CCSID' 5)
             PARM       KWD(STMFEOL) TYPE(*CHAR) LEN(5) RSTD(*YES) +
                          DFT(*CRLF) SPCVAL((*CRLF) (*LF) (*CR) (*LFCR)) +
                          EXPR(*YES) PROMPT('STMF EOL' 6)
 QOBJ:       QUAL       TYPE(*NAME) EXPR(*YES) LEN(10)
             QUAL       TYPE(*NAME) EXPR(*YES) LEN(10) DFT(*LIBL) +
                          SPCVAL((*CURLIB) (*LIBL)) PROMPT('Library')
 QMOD:       QUAL       TYPE(*NAME) EXPR(*YES) LEN(10)
             QUAL       TYPE(*NAME) EXPR(*YES) LEN(10) DFT(*ANY) +
                          SPCVAL((*ANY)) PROMPT('Library')
             PGM        PARM(&PQOBJ &PTODIR &POBJTYPE &PQMOD &PSTMFCCSID +
                          &PSTMFEOL)

/* Parameters */
             DCL        VAR(&PQOBJ) TYPE(*CHAR) LEN(20)
             DCL        VAR(&POBJ) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&PQOBJ 1)
             DCL        VAR(&POBJLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&PQOBJ 11)
             DCL        VAR(&PTODIR) TYPE(*CHAR) LEN(128)
             DCL        VAR(&POBJTYPE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&PQMOD) TYPE(*CHAR) LEN(20)
             DCL        VAR(&PMOD) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&PQMOD 1)
             DCL        VAR(&PMODLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&PQMOD 11)
             DCL        VAR(&PSTMFCCSID) TYPE(*INT) LEN(4)
             DCL        VAR(&PSTMFEOL) TYPE(*CHAR) LEN(5)

/* stat64 */
             DCL        VAR(&STATRTNVAL) TYPE(*INT) LEN(4)
             DCL        VAR(&STATPATH) TYPE(*CHAR) LEN(256)
             DCL        VAR(&STATBUFFER) TYPE(*CHAR) LEN(4096)
             DCL        VAR(&STATOBJTYP) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&STATBUFFER 61)
/*           DCL        VAR(&NULL) TYPE(*CHAR) LEN(1) VALUE(X'00') */

/* strlen */
             DCL        VAR(&STRTMP) TYPE(*CHAR) LEN(32767)
             DCL        VAR(&LENINT) TYPE(*UINT) LEN(4)
/*           DCL        VAR(&NULL) TYPE(*CHAR) LEN(1) VALUE(X'00') */

/* SUBR(RTVPGMINF): Start ********************************************/
             DCL        VAR(&RTVPGMINF) TYPE(*INT) LEN(4)

/* QCLRPGMI (Retrieve Program Information) */
             DCL        VAR(&PGMI0100V) TYPE(*CHAR) LEN(536)
             DCL        VAR(&PGMTYPE) TYPE(*CHAR) STG(*DEFINED) LEN(1) +
                          DEFVAR(&PGMI0100V 161) /* ' '=OPM, 'B'=ILE */
             DCL        VAR(&PGMI0100L) TYPE(*INT) LEN(4) VALUE(536)
             DCL        VAR(&PGMI0100QO) TYPE(*CHAR) LEN(20)
/* SUBR(RTVPGMINF): End **********************************************/

/* SUBR(RTVSRVPGMI): Start *******************************************/
             DCL        VAR(&RTVSRVPGMI) TYPE(*INT) LEN(4)

/* QBNRSPGM (Retrieve Service Program Information) */
             DCL        VAR(&SPGI0100V) TYPE(*CHAR) LEN(5444)
             DCL        VAR(&SPGI0100L) TYPE(*INT) LEN(4) VALUE(5444)
             DCL        VAR(&SPGI0100QO) TYPE(*CHAR) LEN(20)
/* SUBR(RTVSRVPGMI): End *********************************************/

/* SUBR(RTVPCML): Start **********************************************/
             DCL        VAR(&RTVPCML) TYPE(*INT) LEN(4)

/* DLTUSRSPC, QUSCRTUS, QUSPTRUS, QUSCUSAT */
             DCL        VAR(&QUSRSPC) TYPE(*CHAR) LEN(20)
             DCL        VAR(&USRSPC) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&QUSRSPC 1)
             DCL        VAR(&USRSPCLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&QUSRSPC 11)
             DCL        VAR(&USEXTATR) TYPE(*CHAR) LEN(10)
             DCL        VAR(&USINITSIZ) TYPE(*INT) LEN(4)
             DCL        VAR(&USINITVAL) TYPE(*CHAR) LEN(1)
             DCL        VAR(&USPUBAUT) TYPE(*CHAR) LEN(10)
             DCL        VAR(&USTEXT) TYPE(*CHAR) LEN(50)
             DCL        VAR(&USREPLACE) TYPE(*CHAR) LEN(10)
             DCL        VAR(&USRTNLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&USCHGATR) TYPE(*CHAR) LEN(25)
             DCL        VAR(&USATRREC) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 1)
             DCL        VAR(&USATRKEY1) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 5)
             DCL        VAR(&USATRLEN1) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 9)
             DCL        VAR(&USATRDTA1) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 13)
             DCL        VAR(&USATRKEY2) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 17)
             DCL        VAR(&USATRLEN2) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&USCHGATR 21)
             DCL        VAR(&USATRDTA2) TYPE(*CHAR) STG(*DEFINED) LEN(1) +
                          DEFVAR(&USCHGATR 25)

/* QBNRPII */
             DCL        VAR(&RPII0100V) TYPE(*CHAR) LEN(32767)
             DCL        VAR(&RPII0100L) TYPE(*INT) LEN(4)
             DCL        VAR(&RPII0100QO) TYPE(*CHAR) LEN(20)
             DCL        VAR(&RPII0100OT) TYPE(*CHAR) LEN(10)
             DCL        VAR(&RPII0100QM) TYPE(*CHAR) LEN(20)

             DCL        VAR(&USPTR) TYPE(*PTR) /* Pointer to user space */
             DCL        VAR(&USDTA) TYPE(*CHAR) STG(*BASED) LEN(32767) +
                          BASPTR(&USPTR)

             DCL        VAR(&HDPTR) TYPE(*PTR) /* Pointer to generic +
                          header information */
             DCL        VAR(&HDDTA) TYPE(*CHAR) STG(*BASED) LEN(48) +
                          BASPTR(&HDPTR) /* Generic header information */
             DCL        VAR(&HDBYTRTN) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&HDDTA 1) /* Bytes returned */
             DCL        VAR(&HDBYTAVL) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&HDDTA 5) /* Bytes availabled */
             DCL        VAR(&HDOBJNAM) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&HDDTA 9) /* Object name */
             DCL        VAR(&HDOBJLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&HDDTA 19) /* Object library */
             DCL        VAR(&HDFSTOFF) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&HDDTA 41) /* Offset to first interface +
                          entry */
             DCL        VAR(&HDNBRENT) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&HDDTA 45) /* Number of entries */

             DCL        VAR(&ENPTR) TYPE(*PTR) /* Pointer to list entry */
             DCL        VAR(&ENDTA) TYPE(*CHAR) STG(*BASED) LEN(44) +
                          BASPTR(&ENPTR) /* Offset to next interface entry */
             DCL        VAR(&ENOFFNXT) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 1) /* Offset to next interface entry */
             DCL        VAR(&ENMODNAM) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&ENDTA 5) /* Module name */
             DCL        VAR(&ENMODLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&ENDTA 15) /* Module library */
             DCL        VAR(&ENCCSID) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 25) /* CCSID of interface +
                          information */
             DCL        VAR(&ENTYP) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 29) /* Type of interface information */
             DCL        VAR(&ENOFFINF) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 33) /* Offset to interface +
                          information */
             DCL        VAR(&ENLENINF) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 37) /* Length of interface +
                          information returned */
             DCL        VAR(&ENLENAVL) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&ENDTA 41) /* Length of interface +
                          information available */

             DCL        VAR(&INPTR) TYPE(*PTR) /* Pointer to interface +
                          information */
             DCL        VAR(&INDTA) TYPE(*CHAR) STG(*BASED) LEN(32767) +
                          BASPTR(&INPTR) /* Interface information */

             DCL        VAR(&ENT_OFF) TYPE(*INT) LEN(4)
             DCL        VAR(&I) TYPE(*UINT) LEN(4)

             DCL        VAR(&PCMLROW) TYPE(*CHAR) LEN(1024)
             DCL        VAR(&PCMLROWLEN) TYPE(*INT) LEN(4)
             DCL        VAR(&PCMLROWLVL) TYPE(*INT) LEN(4)
             DCL        VAR(&PCMLLEN) TYPE(*INT) LEN(4)
             DCL        VAR(&PCMLDIR) TYPE(*CHAR) LEN(256)
             DCL        VAR(&PCMLSTMF) TYPE(*CHAR) LEN(256)

             DCL        VAR(&MODULE) TYPE(*CHAR) LEN(21)
/* SUBR(RTVPCML): End ************************************************/

/* RUNSQL */
             DCL        VAR(&SQL) TYPE(*CHAR) LEN(5000)

/* API Error */
             DCL        VAR(&APIERROR) TYPE(*CHAR) LEN(1040)
             DCL        VAR(&AEBYTPRO) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&APIERROR 1)
             DCL        VAR(&AEBYTAVL) TYPE(*INT) STG(*DEFINED) LEN(4) +
                          DEFVAR(&APIERROR 5)
             DCL        VAR(&AEEXCPID) TYPE(*CHAR) STG(*DEFINED) LEN(7) +
                          DEFVAR(&APIERROR 9)
             DCL        VAR(&AEEXCPDTA) TYPE(*CHAR) STG(*DEFINED) +
                          LEN(1024) DEFVAR(&APIERROR 17)

/* _MATPGMNM */
             DCL        VAR(&DATA) TYPE(*CHAR) LEN(80)
             DCL        VAR(&PGMNAME) TYPE(*CHAR) LEN(10)
             DCL        VAR(&PGMLIB) TYPE(*CHAR) LEN(10)

/* RTVJOBA */
             DCL        VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
             DCL        VAR(&JOBUSER) TYPE(*CHAR) LEN(10)
             DCL        VAR(&JOBNBR) TYPE(*CHAR) LEN(6)

/* RCVMSG & SNDPGMMSG */
             DCL        VAR(&PRCNAME) TYPE(*CHAR) LEN(256) /* CALLPRC */
             DCL        VAR(&CMDNAME) TYPE(*CHAR) LEN(10)
             DCL        VAR(&ERROR) TYPE(*LGL) VALUE('0')
             DCL        VAR(&PGMERROR) TYPE(*CHAR) VALUE('-')
             DCL        VAR(&DUMP) TYPE(*LGL) VALUE('0')
             DCL        VAR(&SUBRNAME) TYPE(*CHAR) LEN(10)
             DCL        VAR(&ERR_PGM) TYPE(*CHAR) LEN(10)
             DCL        VAR(&ERR_TEXT) TYPE(*CHAR) LEN(100) /* For handled +
                          errors only */
             DCL        VAR(&MSGID) TYPE(*CHAR) LEN(7)
             DCL        VAR(&MSGDTA) TYPE(*CHAR) LEN(512)
             DCL        VAR(&MSGDTALEN) TYPE(*DEC) LEN(5 0)
             DCL        VAR(&MSG) TYPE(*CHAR) LEN(1024)
             DCL        VAR(&MSGLEN) TYPE(*DEC) LEN(5 0)
             DCL        VAR(&SECLVL) TYPE(*CHAR) LEN(1024)
             DCL        VAR(&SECLVLLEN) TYPE(*DEC) LEN(5 0)
             DCL        VAR(&MSGF) TYPE(*CHAR) LEN(10)
             DCL        VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
             DCL        VAR(&MSGKEY) TYPE(*CHAR) LEN(4)
             DCL        VAR(&MSGKEYRQS) TYPE(*CHAR) LEN(4)
             DCL        VAR(&MSGTYPE) TYPE(*CHAR) LEN(7)
             DCL        VAR(&RTNTYPE) TYPE(*CHAR) LEN(2)
             DCL        VAR(&SENDER) TYPE(*CHAR) LEN(80)
             DCL        VAR(&SD_PGMSDR) TYPE(*CHAR) STG(*DEFINED) LEN(10) +
                          DEFVAR(&SENDER 27)
/*           DCL        VAR(&TOMSGQ) TYPE(*CHAR) LEN(10) */
/*           DCL        VAR(&TOMSGQLIB) TYPE(*CHAR) LEN(10) */

/* Constants */
             DCL        VAR(&LOOP) TYPE(*LGL) VALUE('1')
             DCL        VAR(&NULL) TYPE(*CHAR) LEN(1) VALUE(X'00')
             DCL        VAR(&QUOTE) TYPE(*CHAR) LEN(1) VALUE(X'7D')

/* Global monitor for error messages not handled */
             MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))

/* Retrieve program name & library */
             CHGVAR     VAR(%BIN(&DATA 1 4)) VALUE(80)
             CHGVAR     VAR(%BIN(&DATA 5 4)) VALUE(80)
             CHGVAR     VAR(%BIN(&DATA 9 4)) VALUE(0)
             CHGVAR     VAR(%BIN(&DATA 13 4)) VALUE(0)
             CALLPRC    PRC('_MATPGMNM') PARM((&DATA))
             CHGVAR     VAR(&PGMNAME) VALUE(%SST(&DATA 51 10))
             CHGVAR     VAR(&PGMLIB) VALUE(%SST(&DATA 19 10))

/* Retrieve job attributes */
             RTVJOBA    JOB(&JOBNAME) USER(&JOBUSER) NBR(&JOBNBR)

/* Check parameters */
             IF         COND((&PMOD *EQ ' ') *AND (&PMODLIB *NE ' ')) THEN(DO)
                CHGVAR     VAR(&MSGDTA) VALUE('No module name specified.')
                CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                GOTO       CMDLBL(DIAG)
             ENDDO      /* COND((&PMOD *EQ '*ALLBNDMOD') *AND (&PMODLIB +
                             *NE ' ')) */

/* Check program type */
             SELECT
                WHEN       COND(&POBJTYPE *EQ '*PGM') THEN(DO)
                   CHGVAR     VAR(&PGMI0100QO) VALUE(&PQOBJ)
                   CALLSUBR   SUBR(RTVPGMINF) RTNVAL(&RTVPGMINF)
                   SELECT
                      WHEN       COND(&RTVPGMINF *EQ -1) THEN(DO) /* API +
                                   error */
                         CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                         GOTO       CMDLBL(DIAG)
                      ENDDO      /* COND(&RTVPGMINF *EQ -1) */
                      WHEN       COND(&RTVPGMINF *EQ 0) THEN(DO) /* Ok */
                         IF         COND(&PGMTYPE *NE 'B') THEN(DO)
                            CHGVAR     VAR(&MSGDTA) VALUE('Program' *BCAT +
                                         &POBJ *BCAT 'in library' *BCAT +
                                         &POBJLIB *BCAT 'is not an ILE +
                                         program.')
                            CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                            GOTO       CMDLBL(DIAG)
                         ENDDO      /* COND(&PGMTYPE *NE 'B') */
                      ENDDO
                      OTHERWISE  CMD(DO)
                         CHGVAR     VAR(&MSGDTA) VALUE('Invalid return +
                                      code from subroutine' *BCAT +
                                      &SUBRNAME *TCAT '.')
                         CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                         CHGVAR     VAR(&DUMP) VALUE('1') /* Dump enabled */
                         GOTO       CMDLBL(DIAG)
                      ENDDO      /* OTHERWISE */
                   ENDSELECT
                ENDDO      /* COND(&POBJTYPE *EQ '*PGM') */
                WHEN       COND(&POBJTYPE *EQ '*SRVPGM') THEN(DO)
                   CHGVAR     VAR(&SPGI0100QO) VALUE(&PQOBJ)
                   CALLSUBR   SUBR(RTVSRVPGMI) RTNVAL(&RTVSRVPGMI)
                   SELECT
                      WHEN       COND(&RTVSRVPGMI *EQ -1) THEN(DO) /* API +
                                   error */
                         CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                         GOTO       CMDLBL(DIAG)
                      ENDDO      /* COND(&RTVSRVPGMI *EQ -1) */
                      WHEN       COND(&RTVPGMINF *EQ 0) THEN(DO) /* Ok */
                      ENDDO
                      OTHERWISE  CMD(DO)
                         CHGVAR     VAR(&MSGDTA) VALUE('Invalid return +
                                      code from subroutine' *BCAT +
                                      &SUBRNAME *TCAT '.')
                         CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                         CHGVAR     VAR(&DUMP) VALUE('1') /* Dump enabled */
                         GOTO       CMDLBL(DIAG)
                      ENDDO      /* OTHERWISE */
                   ENDSELECT
                ENDDO      /* COND(&POBJTYPE *EQ '*SRVPGM') */
                OTHERWISE  CMD(DO) /* ??? */
                   CHGVAR     VAR(&MSGDTA) VALUE('Program type ''' *CAT +
                                &POBJTYPE *TCAT ''' unknown.')
                   CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                   CHGVAR     VAR(&DUMP) VALUE('1') /* Dump enabled */
                   GOTO       CMDLBL(DIAG)
                ENDDO
             ENDSELECT

/* Check TODIR parameter */
             CHGVAR     VAR(&STATPATH) VALUE(&PTODIR *TCAT &NULL)
             CALLPRC    PRC('stat64') PARM((&STATPATH) (&STATBUFFER)) +
                          RTNVAL(&STATRTNVAL)
             IF         COND(&STATRTNVAL *NE 0) THEN(DO)
                CHGVAR     VAR(&MSGID) VALUE('CPFA0A9') /* Object not found */
                CALLPRC    PRC('strlen') PARM((&STATPATH)) RTNVAL(&LENINT)
                CHGVAR     VAR(%BIN(&MSGDTA 1 4)) VALUE(&LENINT)
                CHGVAR     VAR(%SST(&MSGDTA 5 &LENINT)) VALUE(%SST(&PTODIR +
                             1 &LENINT))
                CHGVAR     VAR(&ERR_PGM) VALUE('stat64')
                CHGVAR     VAR(&SUBRNAME) VALUE('MAIN')
                CHGVAR     VAR(&ERR_TEXT) VALUE('PROCEDURE(' *CAT &ERR_PGM +
                             *TCAT ')@SUBR(' *CAT &SUBRNAME *TCAT '):')
                CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                GOTO       CMDLBL(DIAG)
             ENDDO      /* COND(&STATRTNVAL *NE 0) */
             ELSE       CMD(DO)
                IF         COND(&STATOBJTYP *NE '*DIR') THEN(DO)
                   CHGVAR     VAR(&MSGDTA) VALUE('TODIR parameter must be +
                                a directory (' *CAT &QUOTE *CAT +
                                &STATOBJTYP *TCAT &QUOTE *CAT ').')
                   CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                   GOTO       CMDLBL(DIAG)
                ENDDO      /* COND(&STATOBJTYP *NE '*DIR') */
             ENDDO      /* COND(&STATRTNVAL *EQ 0) */

/* Check last &PTODIR char */
             CALLPRC    PRC('strlen') PARM((&STATPATH)) RTNVAL(&LENINT)
             IF         COND(%SST(&STATPATH &LENINT 1) *NE '/') THEN(DO)
                CHGVAR     VAR(&PCMLDIR) VALUE(&PTODIR *TCAT '/')
             ENDDO      /* COND(%SST(&STATPATH &LENINT 1) *NE '/') */
             ELSE       CMD(DO)
                CHGVAR     VAR(&PCMLDIR) VALUE(&PTODIR)
             ENDDO      /* COND(%SST(&STATPATH &LENINT 1) *EQ '/') */

/* Retrieve PCML */
             IF         COND(&PMOD *EQ '*ALLBNDMOD') THEN(DO)
                CHGVAR     VAR(&MODULE) VALUE(&PMOD)
             ENDDO      /* COND(&PMOD *EQ '*ALLBNDMOD') */
             ELSE       CMD(DO)
                CHGVAR     VAR(&MODULE) VALUE(&PMODLIB *TCAT '/' *CAT &PMOD)
             ENDDO      /* COND(&PMOD *NE '*ALLBNDMOD') */
             CHGVAR     VAR(&MSGID) VALUE('CPI8859')
             CHGVAR     VAR(&MSGDTA) VALUE('Retrieving Program Call Markup +
                          Language (PCML) data for MOD(' *CAT &MODULE +
                          *TCAT ') in' *BCAT %SST(&POBJTYPE 2 8) *TCAT '(' +
                          *CAT &POBJLIB *TCAT '/' *CAT &POBJ *TCAT ')...')
             SNDPGMMSG  MSGID(&MSGID) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
                          TOPGMQ(*PRV (*)) TOMSGQ(*TOPGMQ) MSGTYPE(*STATUS)
             CHGVAR     VAR(&RPII0100QO) VALUE(&PQOBJ)
             CHGVAR     VAR(&RPII0100OT) VALUE(&POBJTYPE)
             CHGVAR     VAR(&RPII0100QM) VALUE(&PQMOD)
             CALLSUBR   SUBR(RTVPCML) RTNVAL(&RTVPCML)
             SELECT
                WHEN       COND(&RTVPCML *EQ -1) THEN(DO) /* API error */
                   CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                   GOTO       CMDLBL(DIAG)
                ENDDO      /* COND(&RTVPCML *EQ -1) */
                WHEN       COND(&RTVPCML *EQ 0) THEN(DO)
                   CHGVAR     VAR(&MSGDTA) VALUE('Program Call Markup +
                                Language (PCML) not found for MOD(' *CAT +
                                &MODULE *TCAT ') in' *BCAT %SST(&POBJTYPE +
                                2 8) *TCAT '(' *CAT &POBJLIB *TCAT '/' +
                                *CAT &POBJ *TCAT ').')
                   CHGVAR     VAR(&PGMERROR) VALUE('1') /* *ESCAPE */
                   GOTO       CMDLBL(DIAG)
                ENDDO      /* COND(&RTVPCML *EQ 0) */
                OTHERWISE  CMD(DO)
                   CHGVAR     VAR(&MSGID) VALUE('CPI8859')
                   CHGVAR     VAR(&MSGDTA) VALUE('Program Call Markup +
                                Language (PCML) retrieved:' *BCAT +
                                %CHAR(&RTVPCML) *TCAT '.')
                   SNDPGMMSG  MSGID(&MSGID) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
                                TOPGMQ(*PRV (*)) TOMSGQ(*TOPGMQ) MSGTYPE(*COMP)
                ENDDO      /* OTHERWISE */
             ENDSELECT

             CALLSUBR   SUBR(CLEANUP)

             GOTO       CMDLBL(RETURN)

 DIAG:
             IF         COND(&ERR_TEXT *NE ' ') THEN(DO)
                SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&ERR_TEXT) +
                             TOPGMQ(*PRV (*)) TOMSGQ(*TOPGMQ) MSGTYPE(*DIAG)
             ENDDO      /* COND(&ERR_TEXT *NE ' ') */

             IF         COND(&MSGID *EQ ' ') THEN(DO)
                CHGVAR     VAR(&MSGID) VALUE('CPF9897')
             ENDDO      /* COND(&MSGID *EQ ' ') */

             SNDPGMMSG  MSGID(&MSGID) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
                          TOPGMQ(*SAME (*)) TOMSGQ(*TOPGMQ) MSGTYPE(*DIAG)

             IF         COND(&PGMERROR *EQ '-') THEN(DO)
                CHGVAR     VAR(&PGMERROR) VALUE('0') /* *DIAG */
             ENDDO      /* COND(&PGMERROR *EQ '-') */

 ERROR:
             IF         COND(&ERROR *EQ '1') THEN(RETURN)

             CHGVAR     VAR(&ERROR) VALUE('1')

             RCVMSG     PGMQ(*SAME) MSGTYPE(*LAST) RMV(*YES) MSG(&MSG) +
                          MSGLEN(&MSGLEN) SECLVL(&SECLVL) +
                          SECLVLLEN(&SECLVLLEN) MSGDTA(&MSGDTA) +
                          MSGDTALEN(&MSGDTALEN) MSGID(&MSGID) +
                          RTNTYPE(&RTNTYPE) MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)

             IF         COND((&PGMERROR *EQ '-') *OR (&DUMP)) THEN(DO) /* +
                          Global MONMSG or forced dump */
                CHGVAR     VAR(&ERR_TEXT) VALUE(' ') /* Handled errors only */
                OVRPRTF    FILE(QPPGMDMP) USRDTA(&PGMNAME) SPLFOWN(*JOB) +
                             OVRSCOPE(*CALLLVL)
                MONMSG     MSGID(CPF0000)
                DMPCLPGM
                MONMSG     MSGID(CPF0000)
                DLTOVR     FILE(QPPGMDMP) LVL(*)
                MONMSG     MSGID(CPF0000)
             ENDDO      /* COND(&PGMERROR *NE '0') */

             CALLSUBR   SUBR(CLEANUP)

/* 02: Diagnostic - 15: Escape (exception already handled at time of RCVMSG) +
                  - 17: Escape (exception not handled at time of RCVMSG) */
             IF         COND((&RTNTYPE *EQ '02') *OR (&RTNTYPE *EQ '15') +
                          *OR (&RTNTYPE *EQ '17')) THEN(DO)

                IF         COND(&PGMERROR *EQ '0') THEN(DO)
/* Set DIAGNOSTIC message */
                   CHGVAR     VAR(&MSGTYPE) VALUE('*DIAG')
                ENDDO      /* COND(&PGMERROR *EQ '0') */
                ELSE       CMD(DO)
/* Set ESCAPE message */
                   CHGVAR     VAR(&MSGTYPE) VALUE('*ESCAPE')
                ENDDO      /* COND(&PGMERROR *NE '0') */

                SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
                             MSGDTA(&MSGDTA) TOPGMQ(*PRV (*)) +
                             TOMSGQ(*TOPGMQ) MSGTYPE(&MSGTYPE)
                MONMSG     MSGID(CPF0000)

             ENDDO      /* COND((&RTNTYPE *EQ '02') *OR (&RTNTYPE *EQ +
                          '15') *OR (&RTNTYPE *EQ '17')) */

/* Normal exit */
 RETURN:
             RETURN

/* SUBR(RTVPGMINF): Start ********************************************/

 RTVPGMINF:  SUBR       SUBR(RTVPGMINF)

                CHGVAR     VAR(&SUBRNAME) VALUE('RTVPGMINF')
                CHGVAR     VAR(&RTVPGMINF) VALUE(0)

                CHGVAR     VAR(&AEBYTPRO) VALUE(1040) /* &APIERROR */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)

                CALL       PGM(QCLRPGMI) PARM(&PGMI0100V &PGMI0100L +
                             'PGMI0100' &PGMI0100QO &APIERROR)

                IF         COND(&AEBYTAVL *NE 0) THEN(DO)
                   CHGVAR     VAR(&MSGID) VALUE(&AEEXCPID)
                   CHGVAR     VAR(&MSGDTA) VALUE(&AEEXCPDTA)
                   CHGVAR     VAR(&ERR_PGM) VALUE('QCLRPGMI')
                   CHGVAR     VAR(&ERR_TEXT) VALUE('API(' *CAT &ERR_PGM +
                                *TCAT ')@SUBR(' *CAT &SUBRNAME *TCAT '):')
                   RTNSUBR    RTNVAL(-1)
                ENDDO      /* COND(&AEBYTAVL *NE 0) */

             ENDSUBR    RTNVAL(&RTVPGMINF)

/* SUBR(RTVPGMINF): End **********************************************/

/* SUBR(RTVSRVPGMI): Start *******************************************/

 RTVSRVPGMI: SUBR       SUBR(RTVSRVPGMI)

                CHGVAR     VAR(&SUBRNAME) VALUE('RTVSRVPGMI')
                CHGVAR     VAR(&RTVSRVPGMI) VALUE(0)

                CHGVAR     VAR(&AEBYTPRO) VALUE(1040) /* &APIERROR */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QBNRSPGM) PARM(&SPGI0100V &SPGI0100L +
                             'SPGI0100' &SPGI0100QO &APIERROR)

                IF         COND(&AEBYTAVL *NE 0) THEN(DO)
                   CHGVAR     VAR(&MSGID) VALUE(&AEEXCPID)
                   CHGVAR     VAR(&MSGDTA) VALUE(&AEEXCPDTA)
                   CHGVAR     VAR(&ERR_PGM) VALUE('QBNRSPGM')
                   CHGVAR     VAR(&ERR_TEXT) VALUE('API(' *CAT &ERR_PGM +
                                *TCAT ')@SUBR(' *CAT &SUBRNAME *TCAT '):')
                   RTNSUBR    RTNVAL(-1)
                ENDDO      /* COND(&AEBYTAVL *NE 0) */

             ENDSUBR    RTNVAL(&RTVSRVPGMI)

/* SUBR(RTVSRVPGMI): End *********************************************/

/* SUBR(RTVPCML): Start **********************************************/

 RTVPCML:    SUBR       SUBR(RTVPCML)

                CHGVAR     VAR(&SUBRNAME) VALUE('RTVPCML')
                CHGVAR     VAR(&RTVPCML) VALUE(0)

                CHGVAR     VAR(&USRSPC) VALUE(&PGMNAME)
                CHGVAR     VAR(&USRSPCLIB) VALUE('QTEMP')

/* Delete user space */
                DLTUSRSPC  USRSPC(&USRSPCLIB/&USRSPC)
                MONMSG     MSGID(CPF2105) EXEC(DO)
                   RCVMSG     PGMQ(*SAME) MSGTYPE(*LAST) RMV(*YES)
                ENDDO

/* Create user space */
                CHGVAR     VAR(&USEXTATR) VALUE(&SUBRNAME)
                CHGVAR     VAR(&USINITSIZ) VALUE(8)
                CHGVAR     VAR(&USINITVAL) VALUE(X'00')
                CHGVAR     VAR(&USPUBAUT) VALUE('*EXCLUDE')
                CHGVAR     VAR(&USTEXT) VALUE('Pgm(' *CAT &PGMNAME *TCAT +
                             ') SubR(' *CAT &SUBRNAME *TCAT ')')
                CHGVAR     VAR(&USREPLACE) VALUE('*YES')
                CHGVAR     VAR(&AEBYTPRO) VALUE(0) /* MONMSG */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QUSCRTUS) PARM(&QUSRSPC &USEXTATR +
                             &USINITSIZ &USINITVAL &USPUBAUT &USTEXT +
                             &USREPLACE &APIERROR)

/* Retrieve pointer to user space */
                CHGVAR     VAR(&AEBYTPRO) VALUE(0) /* MONMSG */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QUSPTRUS) PARM(&QUSRSPC &USPTR &APIERROR)

/* Retrieve the number of bytes of data available to be returned */
                CHGVAR     VAR(&AEBYTPRO) VALUE(1040) /* &APIERROR */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QBNRPII) PARM(&USDTA &USINITSIZ 'RPII0100' +
                             &RPII0100QO &RPII0100OT &RPII0100QM &APIERROR)

                IF         COND(&AEBYTAVL *NE 0) THEN(DO)
                   CHGVAR     VAR(&MSGID) VALUE(&AEEXCPID)
                   CHGVAR     VAR(&MSGDTA) VALUE(&AEEXCPDTA)
                   CHGVAR     VAR(&ERR_PGM) VALUE('QBNRPII')
                   RTNSUBR    RTNVAL(-1)
                ENDDO      /* COND(&AEBYTAVL *NE 0) */

                CHGVAR     VAR(&HDPTR) VALUE(&USPTR)

/* Increase user space size and enable automatic extendibility +
   (dynamic memory allocation) */
                CHGVAR     VAR(&USATRREC) VALUE(2) /* Number of variable +
                             length records */
                CHGVAR     VAR(&USATRKEY1) VALUE(1) /* Key: Space size */
                CHGVAR     VAR(&USATRLEN1) VALUE(4) /* Length of data */
                CHGVAR     VAR(&USATRDTA1) VALUE(&HDBYTAVL) /* Data */
                CHGVAR     VAR(&USATRKEY2) VALUE(3) /* Key: Automatic +
                             extendibility */
                CHGVAR     VAR(&USATRLEN2) VALUE(1) /* Length of data */
                CHGVAR     VAR(&USATRDTA2) VALUE('1') /* Data */
                CHGVAR     VAR(&AEBYTPRO) VALUE(0) /* MONMSG */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QUSCUSAT) PARM(&USRTNLIB &QUSRSPC &USCHGATR +
                             &APIERROR)

/* Retrieve program interface information */
                CHGVAR     VAR(&AEBYTPRO) VALUE(1040) /* &APIERROR */
                CHGVAR     VAR(&AEBYTAVL) VALUE(0)
                CALL       PGM(QBNRPII) PARM(&USDTA &HDBYTAVL 'RPII0100' +
                             &RPII0100QO &RPII0100OT &RPII0100QM &APIERROR)

                IF         COND(&AEBYTAVL *NE 0) THEN(DO)
                   CHGVAR     VAR(&MSGID) VALUE(&AEEXCPID)
                   CHGVAR     VAR(&MSGDTA) VALUE(&AEEXCPDTA)
                   CHGVAR     VAR(&ERR_PGM) VALUE('QBNRPII')
                   CHGVAR     VAR(&ERR_TEXT) VALUE('API(' *CAT &ERR_PGM +
                                *TCAT ')@SUBR(' *CAT &SUBRNAME *TCAT '):')
                   RTNSUBR    RTNVAL(-1)
                ENDDO      /* COND(&AEBYTAVL *NE 0) */

                CHGVAR     VAR(&HDPTR) VALUE(&USPTR)
                CHGVAR     VAR(&ENT_OFF) VALUE(&HDFSTOFF)

                SNDPGMMSG  MSG('Program Call Markup Language (PCML) +
                             found:' *BCAT %CHAR(&HDNBRENT) *TCAT '.')

                DOFOR      VAR(&I) FROM(1) TO(&HDNBRENT)
                   CHGVAR     VAR(&ENPTR) VALUE(&USPTR)
                   CHGVAR     VAR(&INPTR) VALUE(&USPTR) /* */
                   CHGVAR     VAR(%OFFSET(&ENPTR)) VALUE(%OFFSET(&ENPTR) + +
                                &ENT_OFF)
                   CHGVAR     VAR(&ENT_OFF) VALUE(&ENOFFNXT)
                   CHGVAR     VAR(%OFFSET(&INPTR)) VALUE(%OFFSET(&INPTR) + +
                                &ENOFFINF)
                   CHGVAR     VAR(&PCMLROWLEN) VALUE(0)
                   CHGVAR     VAR(&PCMLROWLVL) VALUE(0)
                   CHGVAR     VAR(&PCMLLEN) VALUE(0)
                   CHGVAR     VAR(&PCMLSTMF) VALUE(&PCMLDIR *TCAT &POBJ +
                                *TCAT '_' *CAT &ENMODNAM *TCAT '.pcml')
                   RMVLNK     OBJLNK(&PCMLSTMF)
                   MONMSG     MSGID(CPFA0A9)
                   DOWHILE    COND(&PCMLLEN *LT &ENLENINF)
                      CHGVAR     VAR(&PCMLROWLEN) VALUE(%SCAN('>' &INDTA))
                      IF         COND(&PCMLROWLEN *GT 0) THEN(DO)
                         CHGVAR     VAR(&PCMLROW) VALUE(%SST(&INDTA 1 +
                                      &PCMLROWLEN))
                         CHGVAR     VAR(%OFFSET(&INPTR)) +
                                      VALUE(%OFFSET(&INPTR) + &PCMLROWLEN)
                         IF         COND(%SST(&PCMLROW 1 2) *EQ '</') THEN(DO)
                            CHGVAR     VAR(&PCMLROWLVL) VALUE(&PCMLROWLVL - 1)
                            ENDDO      /* COND(%SST(&PCMLROW 1 2) *EQ '</') */
                            CHGVAR     VAR(&SQL) VALUE('CALL +
                                         QSYS2.IFS_WRITE(PATH_NAME => ''' +
                                         *CAT &PCMLSTMF *TCAT ''', LINE => +
                                         SPACE(' *TCAT %CHAR(&PCMLROWLVL) +
                                         *BCAT '* 3) CONCAT ''' *CAT +
                                         %TRIMR(&PCMLROW) *TCAT ''', +
                                         FILE_CCSID =>' *BCAT +
                                         %CHAR(&PSTMFCCSID) *TCAT ', +
                                         OVERWRITE => ''APPEND'', +
                                         END_OF_LINE => ''' *CAT +
                                         %SST(&PSTMFEOL 2 4) *TCAT ''')')
                            RUNSQL     SQL(&SQL) COMMIT(*NONE)
                            IF         COND(%SST(&PCMLROW 1 6) *EQ '<pcml' +
                                         *OR %SST(&PCMLROW 1 9) *EQ +
                                         '<program' *OR %SST(&PCMLROW 1 8) +
                                         *EQ '<struct') THEN(DO)
                               CHGVAR     VAR(&PCMLROWLVL) +
                                            VALUE(&PCMLROWLVL + 1)
                            ENDDO      /* COND(%SST(&PCMLROW 1 6) *EQ +
                                         '<pcml' *OR %SST(&PCMLROW 1 9) +
                                         *EQ '<program' *OR %SST(&PCMLROW +
                                         1 8) *EQ '<struct') */
                      ENDDO      /* COND(&PCMLROWLEN *GT 0) */
                      CHGVAR     VAR(&PCMLLEN) VALUE(&PCMLLEN + &PCMLROWLEN)
                   ENDDO      /* DOUNTIL */
                   CHGVAR     VAR(&MSGID) VALUE('CPI8859')
                   CHGVAR     VAR(%SST(&MSGDTA 1 256)) VALUE('Program Call +
                                Markup Language (PCML) data for MOD(' *CAT +
                                &ENMODLIB *TCAT '/' *CAT &ENMODNAM *TCAT +
                                ') in' *BCAT %SST(&POBJTYPE 2 8) *TCAT '(' +
                                *CAT &POBJLIB *TCAT '/' *CAT &POBJ *TCAT +
                                ') copied to file ''' *CAT &PCMLSTMF *TCAT +
                                '''.')
                   SNDPGMMSG  MSGID(&MSGID) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
                                TOPGMQ(*PRV (*)) TOMSGQ(*TOPGMQ) MSGTYPE(*INFO)
                ENDDO      /* DOFOR */
                CHGVAR     VAR(&RTVPCML) VALUE(&HDNBRENT)

             ENDSUBR    RTNVAL(&RTVPCML)

/* SUBR(RTVPCML): End ************************************************/

/* SUBR(CLEANUP): Start **********************************************/

 CLEANUP:    SUBR       SUBR(CLEANUP)

                CHGVAR     VAR(&SUBRNAME) VALUE('CLEANUP')

                IF         COND((&USRSPC *NE ' ') *AND (&USRSPCLIB *NE ' +
                             ')) THEN(DO)
                   DLTUSRSPC  USRSPC(&USRSPCLIB/&USRSPC)
                   MONMSG     MSGID(CPF0000)
                ENDDO      /* COND((&USRSPC *NE ' ') *AND (&USRSPCLIB *NE +
                             ' ')) */

             ENDSUBR    RTNVAL(0)

/* SUBR(CLEANUP): End ************************************************/

 ENDPGM:
             ENDPGM

Riferimenti

Related Posts
DB2 for i SQL – Stringhe – POSSTR-LOCATE-LOCATE_IN_STRING (IT)

Introduzione Spesso, nelle nostre applicazioni, abbiamo la necessità di lavorare con le stringhe di testo e l'SQL del DB2 può Read more

DB2 for i & SQL – FAQ & Howto (Part. 1) (IT)

Database DB2 e SQL ... forse lo strumento più potente e completo che abbiamo sulla piattaforma IBM i: ecco una Read more

Annuncio IBM i 7.4

Arriva direttamente con l'uovo di Pasqua questo annuncio IBM per le novità della versione IBM i 7.4, versione iNext secondo Read more

Generated Always Columns – Approfondimenti (IT)

Introduzione "Generated Always Column": sono colonne, campi, di una tabella il cui contenuto è controllato direttamente dal sistema ... e Read more

0
260
Share:
About author

Amministratore sistemi IBM i

Lascia un commento

Il tuo indirizzo email non sarà pubblicato. I campi obbligatori sono contrassegnati *