midrange.com code scratchpad
Name:
Call the QBNRPII API to retrieve the PCML from an RPG or COBOL program
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
08/20/2009 10:39:03 pm
IP:
Logged
Description:
Command to display the PCML in an program, and the RPGLE command processing program. The RPG program calls the QBNRPII API to get the information. (To get PCML into an RPG or COBOL program, specify PGMINFO(*YES *MODULE) on the compile command.)
Code:
  1. cmd ('Display the PCML in a module')
  2.              PARM       KWD(OBJ) TYPE(QUALOBJ) PROMPT('Object +
  3.                           containing module')
  4.              PARM       KWD(MODULE) TYPE(QUALMOD) DFT(*ALLBNDMOD) +
  5.                           SNGVAL((*ALLBNDMOD *ALLBNDMOD)) +
  6.                           PROMPT('Module')
  7.              PARM       KWD(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
  8.                           DFT(*PGM) VALUES(*PGM *SRVPGM) +
  9.                           SPCVAL((*PGM *PGM) (*SRVPGM *SRVPGM)) +
  10.                           PROMPT('Object type') CHOICE('*PGM *SRVPGM')
  11.              PARM       KWD(STATSONLY) TYPE(*CHAR) LEN(10) RSTD(*YES) +
  12.                           DFT(*NO) VALUES(*NO *YES) +
  13.                           SPCVAL((*NO *NO) (*YES *YES)) +
  14.                           PROMPT('Show stats only') CHOICE('*NO *YES')
  15.  
  16.   QUALOBJ:      QUAL TYPE(*NAME)               +
  17.                 EXPR(*YES)                     +
  18.                 LEN(10)
  19.            QUAL TYPE(*NAME)                    +
  20.                 EXPR(*YES)                     +
  21.                 LEN(10)                        +
  22.                 DFT(*LIBL)                     +
  23.                 SPCVAL((*CURLIB *CURLIB)       +
  24.                        (*LIBL *LIBL))          +
  25.                 PROMPT('Library')
  26.   QUALMOD:      QUAL TYPE(*NAME)               +
  27.                 EXPR(*YES)                     +
  28.                 LEN(10)
  29.            QUAL TYPE(*NAME)                    +
  30.                 EXPR(*YES)                     +
  31.                 LEN(10)                        +
  32.                 DFT(*ANY)                      +
  33.                 SPCVAL((*ANY *ANY))            +
  34.                 PROMPT('Library')
  35.  
  36. ----------------------------------------------------------------------------------------------
  37.       /if defined(*crtbndrpg)
  38.      H dftactgrp(*No) actgrp(*NEW)
  39.       /endif
  40.      H bnddir('QC2LE')
  41.  
  42.      D psds           sds
  43.      D   errmsg                       7a   overlay(psds:40)
  44.  
  45.      D qualname        ds                  qualified based(template)
  46.      D   obj                         10a
  47.      D   lib                         10a
  48.  
  49.       * Prints the value of the module's PCML, or "***NOTFOUND***" if
  50.       * the PCML was not in the module.
  51.      D dspPcmlFromModule...
  52.      D                 pr                  extpgm('DSPPCMLMD')
  53.      D   objQual                           likeds(qualname) const
  54.      D   modQual                           likeds(qualname) const
  55.      D   objType                     10a   const
  56.      D   statsOnly                   10a   const
  57.  
  58.      D dspPcmlFromModule...
  59.      D                 pi
  60.      D   objQual                           likeds(qualname) const
  61.      D   modQual                           likeds(qualname) const
  62.      D   objType                     10a   const
  63.      D   statsOnly                   10a   const
  64.  
  65.      D buffer          s          65535a   based(bufPtr)
  66.  
  67.      D Qbn_Interface_Entry_t...
  68.      D                 ds                  qualified based(template)
  69.       * Offset from start of receiver
  70.      D  Offset_Next_Entry...
  71.      D                               10i 0
  72.      D  Module_Name...
  73.      D                               10a
  74.      D  Module_Library...
  75.      D                               10a
  76.      D  Interface_Info_CCSID...
  77.      D                               10i 0
  78.      D  Interface_Info_Type...
  79.      D                               10i 0
  80.       * Offset from start of receiver
  81.      D  Offset_Interface_Info...
  82.      D                               10i 0
  83.      D  Interface_Info_Length_Ret...
  84.      D                               10i 0
  85.      D  Interface_Info_Length_Avail...
  86.      D                               10i 0
  87.  
  88.      D Qbn_PGII0100_t  ds                  qualified based(template)
  89.      D  Bytes_Returned...
  90.      D                               10i 0
  91.      D  Bytes_Available...
  92.      D                               10i 0
  93.      D  Obj_Name...
  94.      D                               10a
  95.      D  Obj_Lib_Name...
  96.      D                               10a
  97.      D  Obj_Type...
  98.      D                               10a
  99.      D  Reserved3...
  100.      D                                2a
  101.      D  Offset_First_Entry...
  102.      D                               10i 0
  103.      D  Number_Entries...
  104.      D                               10i 0
  105.  
  106.      D errcode         ds                  qualified
  107.      D   bytesprov                   10i 0 inz(0)
  108.      D   bytesavail                  10i 0
  109.  
  110.       * Define the initial storage for the first call to the API
  111.      D tempRcvr        ds                  likeds(Qbn_PGII0100_t)
  112.      D rcvr            ds                  likeds(Qbn_PGII0100_t)
  113.      D                                     based(pRcvr)
  114.      D pRcvr           s               *   inz(*null)
  115.  
  116.      D entry           ds                  likeds(Qbn_Interface_Entry_t)
  117.      D                                     based(pEntry)
  118.      D pEntryData      s               *
  119.  
  120.      D data            s             50a   based(pData)
  121.      D line            s             80a   varying
  122.      D off             s              6p 0
  123.      D lenRemaining    s             10i 0
  124.      D len             s             10i 0
  125.  
  126.      D memcpy          pr              *   extproc('__memcpy')
  127.      D   rcvr                          *   value
  128.      D   src                           *   value
  129.      D   len                         10u 0 value
  130.  
  131.      D print           pr
  132.      D   msg                           *   value options(*string)
  133.  
  134.       * Prototype for QBNRPII (Retrieve Program Interface Information)
  135.       * The receiver might be larger than the RPG limit of 64K
  136.       * so we'll just define it as the structure header, but actually
  137.       * pass a larger receiver
  138.      D QBNRPII         pr                  extpgm('QBNRPII')
  139.      D  Receiver_variable...
  140.      D                                     likeds(Qbn_PGII0100_t)
  141.      D  Length_of_receiver_variable...
  142.      D                               10i 0 const
  143.      D  Format_name...
  144.      D                                8a   const
  145.      D  Qualified_object_name...
  146.      D                                     likeds(qualname) const
  147.      D  Object_Type...
  148.      D                               10a   const
  149.      D  Qualified_bound_module_name...
  150.      D                                     likeds(qualname) const
  151.      D  Error_code...
  152.      D                                     likeds(errcode)
  153.       /free
  154.  
  155.         // print parms
  156.         print ('Printing PCML info');
  157.         print ('   Object: ' + %trim(objQual.lib) + '/' + objQual.obj
  158.              + objType);
  159.         if (modQual.lib = *blank);
  160.            print ('   Module: ' + modQual.obj);
  161.         else;
  162.            print ('   Module: ' + %trim(modQual.lib) + '/' + modQual.obj);
  163.         endif;
  164.  
  165.         // call the API once, to see how much storage to allocate
  166.         callp(e) QBNRPII (tempRcvr : %size(tempRcvr) : 'RPII0100'
  167.               :  objQual : objType : modQual : errcode);
  168.         if %error;
  169.            print ('   Error ' + errmsg + ' retrieving info');
  170.            exsr cleanup;
  171.            return;
  172.         endif;
  173.  
  174.         print ('   Length of information: '
  175.                + %char(tempRcvr.Bytes_Available));
  176.         if statsOnly = '*YES';
  177.            exsr cleanup;
  178.            return;
  179.         endif;
  180.  
  181.         if tempRcvr.Bytes_Available <= tempRcvr.Bytes_Returned;
  182.            pRcvr = %addr(tempRcvr);
  183.         else;
  184.            pRcvr = %alloc(tempRcvr.Bytes_Available);
  185.            callp(e) QBNRPII (rcvr : tempRcvr.Bytes_Available : 'RPII0100'
  186.               :  objQual : objType : modQual : errcode);
  187.         endif;
  188.         if %error
  189.         or rcvr.Number_Entries = 0;
  190.            print ('   Information not found');
  191.            exsr cleanup;
  192.            return;
  193.         endif;
  194.  
  195.         pEntry = pRcvr + rcvr.offset_First_Entry;
  196.         pEntryData = pRcvr + entry.Offset_Interface_Info;
  197.         lenremaining = entry.Interface_Info_Length_Ret;
  198.         print ('   Length of data: '
  199.                + %char(entry.Interface_Info_Length_Ret));
  200.  
  201.         if lenRemaining = 0;
  202.            exsr cleanup;
  203.            return;
  204.         endif;
  205.         off = 0;
  206.         dow lenRemaining > 0;
  207.            len = lenRemaining;
  208.            if len > %size(data);
  209.               len = %size(data);
  210.            endif;
  211.            pData = pEntryData + off;
  212.            line = %editc(off:'N') + ':  ' + %subst(data : 1: len);
  213.            print (line);
  214.            off = off + len;
  215.            lenRemaining = lenRemaining - len;
  216.         enddo;
  217.         exsr cleanup;
  218.         return;
  219.  
  220.         //---------------------------------------
  221.         // S U B R O U T I N E S
  222.         //---------------------------------------
  223.         begsr cleanup;
  224.            if  pRcvr <> *null
  225.            and pRcvr <> %addr(tempRcvr);
  226.               dealloc(n) pRcvr;
  227.            endif;
  228.         endsr;
  229.  
  230.       /end-free
  231.  
  232.  
  233.      P print           b
  234.      D print           pi
  235.      D   msg                           *   value options(*string)
  236.      D printf          pr                  extproc('printf')
  237.      D   template                      *   value options(*string)
  238.      D   msg                           *   value options(*string : *nopass)
  239.      D newline         c                   x'15'
  240.       /free
  241.          printf ('%' + newline : msg);
  242.       /end-free
  243.      P print           e
  244.  
© 2004-2019 by midrange.com generated in 0.005s valid xhtml & css