midrange.com code scratchpad
Name:
RPG version of API QDBRTVSN
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
12/29/2016 04:23:07 pm
IP:
Logged
Description:
to go along with the CL version posted directly into the email list.
Code:
  1. *************** Beginning of data ****************************************
  2.              CMD        PROMPT('Retrieve Short Name(QDBRTVSN)')           
  3.                                                                           
  4.             PARM       KWD(File) TYPE(Obj) MIN(1) PROMPT('Long File Name')
  5.                                                                           
  6. obj:        QUAL       TYPE(*NAME) LEN(128) MIN(1)                        
  7.              QUAL       TYPE(*CHAR) LEN(10) DFT(*LIBL) +                  
  8.                           SPCVAL((*LIBL) (*USRLIBL) (*LIB)) +             
  9.                           CHOICE('*LIBL,*USRLIBL,*LIB if Library') +      
  10.                           PROMPT('Library')                               
  11. ****************** End of data *******************************************
  12.  
  13.  
  14. *************** Beginning of data ****************************************
  15.      h DFTACTGRP(*NO)                                                                               
  16.       *  The Retrieve Short Name(QDBRTVSN) API allows you to get the 10-character                   
  17.       *  object name of a database file or library by providing the long object name.               
  18.       *  The information is returned as a qualified object name.                                    
  19.       *  (Objects with long object names can be created using SQL CREATE statements.                
  20.       *  An object with a long name also has a short 10-character name.)                            
  21.       *http://publib.boulder.ibm.com/infocenter/iseries/v7r1m0/index.jsp?topic=/apis/qdbrtvsn.htm 
  22.                                                                                                     
  23.      D RTVSHRTNAM      Pr                  EXTPGM('RTVSHRTNAM')                                     
  24.      D  LName                              LikeDs(LongName)                                         
  25.      D RTVSHRTNAM      Pi                                                                           
  26.      D  LName                              LikeDs(LongName)                                         
  27.                                                                                                     
  28.      D QDBRTVSN        PR                  ExtPgm('QDBRTVSN')                                       
  29.      D   QualObj                     20a   const                                                    
  30.      D   LongName                   128a   const                                                    
  31.      D   LenLongNam                  10i 0 const                                                    
  32.      D   LongNameLib                 10a   const                                                    
  33.      D   errorCode                32783a   options(*varsize)                                        
  34.                                                                                                     
  35.      D QUILNGTX        PR                  ExtPgm('QUILNGTX')                                       
  36.      D   text                     65535a   const options(*varsize)                                  
  37.      D   length                      10i 0 const                                                    
  38.      D   msgid                        7a   const                                                    
  39.      D   qualmsgf                    20a   const                                                    
  40.      D   errorCode                32783a   options(*varsize)                                        
  41.                                                                                                     
  42.      D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )                                     
  43.      D  MsgId                         7a   Const                                                    
  44.      D  MsgFq                        20a   Const                                                    
  45.      D  MsgDta                      128a   Const                                                    
  46.      D  MsgDtaLen                    10i 0 Const                                                    
  47.      D  MsgTyp                       10a   Const                                                    
  48.      D  CalStkE                      10a   Const  Options( *VarSize )                               
  49.      D  CalStkCtr                    10i 0 Const                                                    
  50.      D  MsgKey                        4a                                                            
  51.      D  Error                     32767a          Options( *VarSize )                               
  52.                                                                                                     
  53.      D SndEscMsg       Pr            10i 0                                                          
  54.      D  MsgId                         7a   Const                                                    
  55.      D  MsgF                         10a   Const                                                    
  56.      D  MsgDta                      512a   Const  Varying                                           
  57.                                                                                                     
  58.      D ErrorNull       ds                  qualified                                                
  59.      D   BytesProv                   10i 0 inz(0)                                                   
  60.      D   BytesAvail                  10i 0 inz(0)                                                   
  61.                                                                                                     
  62.      D ERRC0100        Ds                  Qualified                                                
  63.      D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))                                  
  64.      D  BytAvl                       10i 0                                                          
  65.      D  MsgId                         7a                                                            
  66.      D                                1a                                                            
  67.      D  MsgDta                     1024a                                                            
  68.                                                                                                     
  69.      D LongName        ds                  qualified                                                
  70.      D  Object                      128a                                                            
  71.      D  Library                      10a                                                            
  72.                                                                                                     
  73.      D ShortName       ds                  qualified                                                
  74.      D  Object                       10a                                                            
  75.      D  Library                      10a                                                            
  76.                                                                                                     
  77.      d msg             s            512a                                                            
  78.      D NULL            c                   ''                                                       
  79.      D Slash           s              1a   inz('/')                                                 
  80.       /free                                                                                         
  81.                                                                                                     
  82.            if LName.Library = '*LIB';                                                               
  83.              LName.Library = ' ';     //Must pass *blanks if longname is a library                 
  84.            endif;                                                                                   
  85.              QDBRTVSN( ShortName :                                                                  
  86.                        LName.Object :                                                               
  87.                        %len(LName.Object) :                                                         
  88.                        LName.Library :                                                              
  89.                        ERRC0100);                                                                   
  90.                                                                                                     
  91.              If  ERRC0100.BytAvl > *Zero;                                                           
  92.                ExSr  EscApiErr;                                                                     
  93.              EndIf;                                                                                 
  94.                                                                                                     
  95.           if LName.Library = ' ';                                                                   
  96.              slash = ' ';                                                                           
  97.           endif;                                                                                    
  98.            msg = 'Long name: ' +                                                                    
  99.                  %trim(LName.Library) +                                                             
  100.                   Slash +                                                                           
  101.                  %trim(LName.Object) +                                                              
  102.                  '   Short Name: ' +                                                                
  103.                  %trim(ShortName.Library) +                                                         
  104.                   '/' +                                                                             
  105.                  %trim(ShortName.Object) ;                                                          
  106.                                                                                                     
  107.                                                                                                     
  108.                                                                                                     
  109.               QUILNGTX( msg                                                                         
  110.                       : %len(msg)                                                                   
  111.                       : ' '                                                                         
  112.                       : ' '                                                                         
  113.                       : ErrorNull );                                                                
  114.              *inlr = *on;                                                                           
  115.        //-------------                                                                             
  116.        BegSr  EscApiErr;                                                                            
  117.                                                                                                     
  118.          If  ERRC0100.BytAvl < 16 ;                                                                 
  119.            ERRC0100.BytAvl = 16 ;                                                                   
  120.          EndIf;                                                                                     
  121.                                                                                                     
  122.          SndEscMsg( ERRC0100.MsgId                                                                  
  123.                   : 'QCPFMSG'                                                                       
  124.                   : %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - 16 )                              
  125.                   );                                                                                
  126.        EndSr;                                                                                       
  127.       /end-free                                                                                     
  128.      P SndEscMsg       B                                                                            
  129.      D                 Pi            10i 0                                                          
  130.      D  MsgId                         7a   Const                                                    
  131.      D  MsgF                         10a   Const                                                    
  132.      D  MsgDta                      512a   Const  Varying                                           
  133.      **                                                                                             
  134.      D MsgKey          s              4a                                                            
  135.                                                                                                     
  136.       /Free                                                                                         
  137.                                                                                                     
  138.         SndPgmMsg( MsgId                                                                            
  139.                  : MsgF + '*LIBL'                                                                   
  140.                  : MsgDta                                                                           
  141.                  : %Len( MsgDta )                                                                   
  142.                  : '*ESCAPE'                                                                        
  143.                  : '*PGMBDY'                                                                        
  144.                  : 1                                                                                
  145.                  : MsgKey                                                                           
  146.                  : ERRC0100                                                                         
  147.                  );                                                                                 
  148.         If  ERRC0100.BytAvl > *Zero;                                                                
  149.           Return  -1;                                                                               
  150.         Else;                                                                                       
  151.           Return   0;                                                                               
  152.         EndIf;                                                                                      
  153.       /End-Free                                                                                     
  154.      P SndEscMsg       E  
  155. ****************** End of data *******************************************
© 2004-2019 by midrange.com generated in 0.01s valid xhtml & css