SQL table function for emulate DSPPGMREF command

DSPPGMREF_SQL_Table_Function.sql

/* DSPPGMREF sql table function */
-- 1-mar-2022
-- from Linkedin article Bob Cozzi: https://www.linkedin.com/pulse/dsppgmref-sql-table-function-ibmi-bob-cozzi
-- further enhancements: Marco Riva MK1 www.markonetools.it
-- last update: 15-jun-2024

create or replace function DspPgmRef
  (
   LIBRARY_NAME varchar(10) default '*LIBL',
   OBJECT_NAME  varchar(10),                   -- Required parameter
   OBJECT_TYPE  varchar(60) default '*ALL',
   DATA_OPTION  varchar(10) default '*REPLACE'
  )
  returns table
  (
   objName        varchar(10),
   objLib         varchar(10),
   objType        varchar(10),
   objText        varchar(50),
   objRefCount    int,             -- Objects Referenced Count
   refObjName     varchar(11),     -- Referenced Object name
   refOBJLib      varchar(11),     -- Referenced Object Library
   refObjType     varchar(10),     -- Referenced Object Type
   refSrcName     varchar(11),     -- Ref Name as it appears in Src Pgm
   refRcdFmt      varchar(10),     -- Ref'd File's Record Format
   RcdFmtCount    int,             -- Record Fmts used by this Ref'd File 
   FileUsage      varchar(50),     -- File Usage Input/Output/etc...      
   LvlChkID       char(13),        -- Ref'd Files' RcdFmt LVLCHK ID
   FieldsCount    int,             -- Field Count in Ref'd File           
   --SysName        varchar(8),      -- System name of Ref'd object         
   retrievedTime  timestamp(0)     -- Time DSPPGMREF was run              
  )
  language sql
  modifies sql data
  not fenced
  not deterministic
  --specific st_pgmrefs
  specific DspPgmRef

  -- Date Format ISO is required for dates prior to 1940.
  set option datfmt = *ISO, commit = *NONE

  begin
   declare ERROR_CODE bigint default 0;
   declare pgmRefCmd  varchar(256);
   declare MBROPT     varchar(10) not null default '*REPLACE';
   declare repl       varchar(10);
   declare OBJ_NAME   varchar(11) not null default '';
   declare gen        int not null default 0;
   declare DTS_FMT    varchar(26) not null default 'YYYYMMDDHH24MISSFF12';
   begin
     declare continue handler for sqlexception set ERROR_CODE = 2;

     if (DATA_OPTION is not null and length(data_option) > 0) then
         set repl = trim(L '*' FROM upper(data_option));
         if (length(repl) > 0) then
           set repl = substr(repl, 1, 1);
           if (repl in ('0','A','N')) then
             set mbrOpt = '*ADD';
           end if;
         end if;
     end if;

     -- Check OBJECT_NAME contains '%'
     --  If it does, use *ALL for object name,
     --  and add WHERE clause to the returned SELECT
     --    WHPNAM LIKE :objName
     if (object_name is not null and length(object_name) > 1) then
       set gen = position('%', OBJECT_NAME);
       if (gen is not null and gen > 0 and gen <> length(object_name)) then
         set obj_name = '*ALL';
       elseif (gen is not null and gen = length(object_name)) then
         set gen = 0;
         set obj_name = rTrim(object_name,'% ') concat '*';
       else
         set gen = 0;
         set obj_name = object_name;
       end if;
     end if;

     if (obj_name = '') then
       set OBJ_NAME = '*ALL';
     end if;

     set pgmRefCmd = 'QSYS/DSPPGMREF PGM('
                       CONCAT trim(LIBRARY_NAME)
                       CONCAT '/' CONCAT OBJ_NAME CONCAT ') '
                       CONCAT 'OBJTYPE(' CONCAT OBJECT_TYPE CONCAT ') '
                       CONCAT 'OUTPUT(*OUTFILE) '
                       CONCAT 'OUTFILE(QTEMP/ST_PGMREF2) '
                       CONCAT 'OUTMBR(*FIRST '
                       CONCAT MBROPT CONCAT ')';

   -- Using QCMDEXC requires this UDTF to be "MODIFIES SQL DATA"
     call qsys2.qcmdexc(pgmRefCmd);

   end;

   if ERROR_CODE > 1 then
     signal sqlstate '42704'
     set MESSAGE_TEXT = 'FAILURE on DSPPGMREF cmd inside PGMREF UDTF';
   end if;

   return select
            WHPNAM, WHLIB,
            cast(
            case when WHSPKG = 'P' then '*PGM'
                 when WHSPKG = 'S' then '*SQLPKG'
                 when WHSPKG = 'V' then '*SRVPGM'
                 when WHSPKG = 'M' then '*MODULE'
                 when WHSPKG = 'Q' then '*QRYDFN'
                 else WHSPKG
            end as varchar(10)),
            WHTEXT,
            cast(WHFNUM as int),      -- RefObj Count
            case when WHFNAM = '1' then '*EXPR' else WHFNAM end,
            case when WHLNAM = '1' then '*EXPR' else WHLNAM end,
            WHOTYP,
            case when WHSNAM = '1' then '*EXPR' else WHSNAM end,
            WHRFNM,
            cast(WHRFNB as int),     -- RcdFmt Count
            cast(
            --  1=I,2=O,3=I/O,4=U,5=I/U,6=O/U,7=I/O/U,8=N/S,0=N/A
            --  (Apparently DELETE isn't supported; returned as UPDATE)
            case when WHFUSG = 0 then ' '
                 when WHFUSG = 1 then 'INPUT'
                 when WHFUSG = 2 then 'OUTPUT'
                 when WHFUSG = 3 then 'INPUT  OUTPUT'
                 when WHFUSG = 4 then 'UPDATE'
                 when WHFUSG = 5 then 'INPUT  UPDATE'
                 when WHFUSG = 6 then 'OUTPUT UPDATE'
                 when WHFUSG = 7 then 'INPUT  OUTPUT UPDATE'
                 when WHFUSG = 8 then 'N/S'
                 else 'UNKNOWN'
            end as varchar(30)),
            WHRFSN, WHRFFN, 
            --WHSYSN,
            timestamp_format(substr(WHDTTM, 2, 12), 'YYMMDDHH24MISS', 0)
      from QTEMP.ST_PGMREF2
      -- Note: trim is used here so that the wildcard pattern
      --       of '%XYZ' (which is 4 characters) matches a
      --       WHPNAM value of 'EDTXYZ    '  using LIKE which is
      --       not good at length mismatchs.
      where trim(WHPNAM) like
            case when GEN = 0 then trim(WHPNAM)
                 else upper(object_name)
            end
      order by WHLIB, WHPNAM, WHLNAM, WHFNAM;
end;

label on function DspPgmRef is 'DSPPGMREF table function';

comment on function DspPgmRef
  is 'DSPPGMREF table function: visualizza gli oggetti referenziati da un oggetto programma';

comment on parameter specific function DspPgmRef
  (LIBRARY_NAME is 'Object library. Default is *LIBL',             
   OBJECT_NAME  is 'Object name. Mandatory. Can be a generic name. Wildcards can be * or %.',
   OBJECT_TYPE      is 'Object type. Default is *ALL. Can be a list of object types separated by space',
   DATA_OPTION  is 'Replace the result. Can be *ADD or *REPLACE. Default is *REPLACE'
  );