midrange.com code scratchpad
Name:
SQL wrapper over QDBRTVFD
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
01/20/2020 01:32:22 pm
IP:
Logged
Description:
SQL UDF over QDBRTVFD. Returns one value at a time.
Handles TYPE OF FILE, FILE TYPE, MAINT flag, Public AUT, MAXMBRS, NUMMBRS, CCSID, and REUSEDLT flag.
Code:
  1. **Free
  2.   Ctl-Opt Nomain
  3.           Option(*Srcstmt:*Nodebugio:*Noshowcpy) Debug(*yes);
  4.  
  5.   // Wrapper for QDBRTVFD API for SQL use.
  6.   // https://www.ibm.com/support/knowledgecenter/ssw_ibm_i_74/apis/qdbrtvfd.htm
  7.  
  8.   // CRTRPGMOD MODULE(KEVIN/UDBRTVFD)
  9.   // CRTSRVPGM SRVPGM(KEVIN/UDBRTVFD) EXPORT(*ALL)
  10.   // Create or Replace Function KEVIN/UDBRTVFD
  11.   // ParFile Char(10),
  12.   // ParLib  Char(10),
  13.   // ParField Char(10))
  14.   // Returns Char(10)
  15.   // Language RPGLE
  16.   // No SQL
  17.   // Not Fenced
  18.   // External Name 'KEVIN/UDBRTVFD(SQLRTVFD)'
  19.   // Parameter Style General
  20.  
  21.   Dcl-Pr SQLRTVFD Char(10);
  22.     *N Char(10);                             // File Name
  23.     *N Char(10);                             // Library
  24.     *N Char(10);                             // Variable to retrieve
  25.   End-Pr;
  26.  
  27.   Dcl-Pr RTVFD  ExtPgm('QDBRTVFD');
  28.     *N Char(65535) Options(*varsize);        // Receiver variable
  29.     *N Int(10)     Const;                    // Length of receiver variable
  30.     *N Char(20);                             // Qualified returned file name
  31.     *N Char(8)     Const;                    // Format name
  32.     *N Char(20)    Const;                    // Qualified file name
  33.     *N Char(10)    Const;                    // Record format name
  34.     *N Char(1)     Const;                    // Override processing
  35.     *N Char(10)    Const;                    // System
  36.     *N Char(10)    Const;                    // Format type
  37.     *N LikeDs(Qusec);                        // Error code
  38.   End-Pr;
  39.  
  40.  
  41.   Dcl-Ds Qusec;
  42.     BytesProvided Int(10) Inz(%Size(Qusec));
  43.     BytesAvailable Int(10);
  44.     ErrorId Char(7);
  45.     Filler Char(1);
  46.     MessageData Char(500);
  47.   End-Ds;
  48.  
  49.   Dcl-Proc SQLRTVFD Export;
  50.     Dcl-Pi *N Char(10);
  51.       FileName Char(10);
  52.       Library Char(10);
  53.       ReturnField Char(10);
  54.     End-Pi;
  55.  
  56.     /Copy Qsysinc/Qrpglesrc,Qdbrtvfd
  57.  
  58.     Dcl-Ds FDH LikeDs(QDBQ25) Based(ptrRcvVar);
  59.     Dcl-DS PFA LikeDs(QDBQ26) Based(ptrPFA);
  60.  
  61.     Dcl-C Bit0 x'80';
  62.     Dcl-C Bit1 x'40';
  63.     Dcl-C Bit2 x'20';
  64.     Dcl-C Bit3 x'10';
  65.     Dcl-C Bit4 x'08';
  66.     Dcl-C Bit5 x'04';
  67.     Dcl-C Bit6 x'02';
  68.     Dcl-C Bit7 x'01';
  69.  
  70.     Dcl-S ptrRcvVar Pointer;
  71.     Dcl-S ptrPFA Pointer;
  72.  
  73.     Dcl-S ActualFile Char(20);
  74.     Dcl-S ReceiveVar Char(4096);
  75.     Dcl-S ReturnValue VarChar(256);
  76.  
  77.     ReturnValue = '*ERROR';
  78.  
  79.     If Library = '';
  80.       Library = '*LIBL';
  81.     EndIf;
  82.  
  83.     RtvFd(ReceiveVar
  84.        :%Len(ReceiveVar)
  85.        :ActualFile
  86.        :'FILD0100'
  87.        :FileName + Library
  88.        :'*FIRST'
  89.        :'0'
  90.        :'*LCL'
  91.        :'*INT'
  92.        :Qusec);
  93.  
  94.     If BytesAvailable > 0;
  95.       Return ErrorId;
  96.     EndIf;
  97.  
  98.     ptrRcvVar = %Addr(ReceiveVar);
  99.     ptrPFA = ptrRcvVar + FDH.QDBPFOF;
  100.  
  101.     Select;
  102.       When ReturnField = 'QDBFHFPL' or ReturnField = 'TYPEOFFILE';
  103.         If %Bitand(%Subst(FDH.QDBBITS27:1:1):Bit2) = Bit2;
  104.           ReturnValue = 'LOGICAL';
  105.         Else;
  106.           ReturnValue = 'PHYSICAL';
  107.         EndIf;
  108.       When ReturnField = 'QDBFHFSU' or ReturnField = 'FILETYPE';
  109.         If %Bitand(%Subst(FDH.QDBBITS27:1:1):Bit4) = Bit4;
  110.           ReturnValue = '*SRC';
  111.         Else;
  112.           ReturnValue = '*DATA';
  113.         EndIf;
  114.       When ReturnField = 'QDBFKFDM' or ReturnField = 'MAINT';
  115.         ReturnValue = FDH.QDBFKFDM00;
  116.       When ReturnField = 'QDBFHAUT' or ReturnField = 'AUT';
  117.         ReturnValue = FDH.QDBFHAUT;
  118.       When ReturnField = 'QDBFHMXM' or ReturnField = 'MAXMBRS';
  119.         ReturnValue = %Char(FDH.QDBFHMXM);
  120.       When ReturnField = 'QDBFHMNUM' or ReturnField = 'NUMMBRS';
  121.         ReturnValue = %Char(FDH.QDBHMNUM);
  122.       When ReturnField = 'QDBFTCID' or ReturnField = 'CCSID';
  123.         ReturnValue = %Char(FDH.QDBFTCID);
  124.       When ReturnField = 'QDBFRDEL' or ReturnField = 'REUSEDLT';
  125.         If %Bitand(PFA.QDBBITS33:Bit0) = Bit0;
  126.           ReturnValue = '*YES';
  127.         Else;
  128.           ReturnValue = '*NO';
  129.         EndIf;
  130.     EndSl;
  131.  
  132.     Return ReturnValue;
  133.  
  134.    End-Proc; 
  135.  
  136.  
  137.  
  138. Examples.
  139. select system_table_name, system_table_schema,                    
  140. Udbrtvfd(system_table_name,system_table_schema,'MAINT') as MAINT, 
  141. Udbrtvfd(system_table_name,system_table_schema,'AUT') as PUBAUT,  
  142. Udbrtvfd(system_table_name,system_table_schema,'TYPEOFFILE') as   
  143. TypeOfFile,                                                       
  144. Udbrtvfd(system_table_name,system_table_schema,'REUSEDLT') as     
  145. REUSEDLT                                                          
  146. from systables                                                    
  147. where system_table_schema = 'MPMS04'                              
  148.  
  149. SYSTEM_TABLE_NAME  SYSTEM_TABLE_SCHEMA  MAINT       PUBAUT      TYPEOFFILE  REUSEDLT
  150.    AAMU                MPMS04           I           *ALL        PHYSICAL    *NO     
  151.    AANN                MPMS04           I           *ALL        PHYSICAL    *NO     
  152.    AANS                MPMS04           I           *ALL        PHYSICAL    *NO     
  153.    AANS01              MPMS04           I           *ALL        LOGICAL     *NO     
  154.  
  155. select udbrtvfd('MPAT92','MPMS04','TYPEOFFILE')
  156.  from sysibm/sysdummy1                         
  157.  
  158. select udbrtvfd('MPAT92','MPMS04','TYPEOFFILE')
  159.  from sysibm/sysdummy1                         
  160.  
© 2004-2019 by midrange.com generated in 0.003s valid xhtml & css