RE: Sample Free Form RPG program w/embedded SQL

      /DEFINE HSpec
      /INCLUDE ROUTINES/QRPGLESRC,HSPEC
      /UNDEFINE HSpec


      
***************************************************************************
      * Program: SRCPFUNLCK - Unlock all source physical files.      *
      *      *
      *      *
      * Modification log:      *
      * 07/13/05 by R.Berendt, CCP    Group Dekko Services, LLC      *
      *          Created.      *
      *      *
      * Compilation instructions:      *
      *   (no special instructions this time.)      *
      *      *
      
***************************************************************************


      /DEFINE DSpec
     D SRCPFUNLCK      PR                  EXTPGM('SRCPFUNLCK')
      /INCLUDE ROUTINES/QRPGLESRC,SRVPGMCPY
      /INCLUDE ROUTINES/QPROTOSRC,RLSLOCKS
     D InitSql         PR
     D DeclareC1       PR                  like(sqlstt)
     D OpenC1          PR                  like(sqlstt)
     D FetchC1         PR                  like(sqlstt)
     D CloseC1         PR                  like(sqlstt)
     D ErrorHandler    PR
     D  Procedure                    10a   const
     D SRCPFUNLCK      PI                        *ENTRY PLIST
     D SourceFile      ds                  qualified
     D  File                         10a
     D  Library                      10a
      /UNDEFINE DSpec

      /free
       InitSql();
       Select;
       When DeclareC1()<>*all'0';
         ErrorHandler('DeclareC1');
       When OpenC1()<>*all'0';
         ErrorHandler('OpenC1');
       Other;
         Dow FetchC1()=*all'0';
           callp RlsLocks(SourceFile.File:SourceFile.Library);
         EndDo;
         Select;
         When SqlStt='02000';
           // End of cursor (normally).  Ok.
         Other;
           ErrorHandler('FetchC1');
         EndSl;
         CloseC1();
       EndSl;
       *inlr=*on;
       return;
      /end-free


      /eject
     P InitSql         B
     D InitSql         PI
      /free
       // Traditionally SqlStt and SqlCod are not set by 'Set Option'
       // or 'Declare cursor' statements
       SqlStt=*all'0';  // Initially comes in as all blanks
       SqlCod=*zeros;  // Initially set to some ridiculously high number. 
It's
                       // a conversion of blanks to a binary number thing.
      /end-free
     C/EXEC SQL
     C+ Set Option
     C+     Naming    = *Sys,
     C+     Commit    = *None,
     C+     UsrPrf    = *User,
     C+     DynUsrPrf = *User,
     C+     Datfmt    = *iso,
     C+     CloSqlCsr = *EndMod
     C/END-EXEC
      /free
       return;
      /end-free
     P InitSql         E


      /eject
     P DeclareC1       B
     D DeclareC1       PI                  like(sqlstt)
     C/EXEC SQL
     C+ Declare C1 Cursor for
     C+ Select SYSTEM_TABLE_SCHEMA, SYSTEM_TABLE_NAME
     C+ From QSYS2/SysTables
     C+ Where file_type='S'
     C+ Order by SYSTEM_TABLE_SCHEMA, SYSTEM_TABLE_NAME
     C/END-EXEC
      /free
       return sqlstt;
      /end-free
     P DeclareC1       E


      /eject
     P OpenC1          B
     D OpenC1          PI                  like(sqlstt)
     C/EXEC SQL
     C+ Open C1
     C/END-EXEC
      /free
       return sqlstt;
      /end-free
     P OpenC1          E


      /eject
     P FetchC1         B
     D FetchC1         PI                  like(sqlstt)
     C/EXEC SQL
     C+ Fetch C1 into :SourceFile.Library, :SourceFile.File
     C/END-EXEC
      /free
       return sqlstt;
      /end-free
     P FetchC1         E


      /eject
     P CloseC1         B
     D CloseC1         PI                  like(sqlstt)
     C/EXEC SQL
     C+ Close C1
     C/END-EXEC
      /free
       // Tell the program that called us, via a data queue, that we are 
done.
       callp qsnddtaq('SRCPFUNLCK':'*LIBL':1:'Y');
       return sqlstt;
      /end-free
     P CloseC1         E



      /eject
     P ErrorHandler    B
     D ErrorHandler    PI
     D  Procedure                    10a   const
     D CheckPsds       s                   like(MyPsds)
      /free
       eSubject='Error processing list of source physical files';
       eMessage ='While attempting to lock all source physical files - and 
';
       eMessage+='release any existing locks (to prepare for backup), I 
ran ';
       eMessage+='into an error attempting ' + Procedure + '<EOL>SqlStt=';
       eMessage+=SqlStt+'<EOL>SqlCod=';
       eMessage+=%char(SqlCod);
       CheckPsds=MyPsds;
       ExcpHdlr01(eSubject:eMessage:CheckPsds);
       return;
      /end-free
     P ErrorHandler    E

Rob Berendt