Difference between revisions of "Snippets"

From MidrangeWiki
Jump to: navigation, search
(GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC)
m
 
(21 intermediate revisions by 2 users not shown)
Line 87: Line 87:
 
[[#top]]
 
[[#top]]
  
===Examples===
 
Subprocedure skeleton:
 
 
[[Image:Lpex_snippet_rpg_subprocedure.JPG]]
 
 
 
====Subprocedure skeleton====
 
      * ${proc_comment}
 
    p ${proc_name}        b
 
    d ${proc_name}        pi            10i 0
 
    d  ${parm_name}                      1a
 
   
 
    d rc                            10i 0 inz
 
     
 
    c/free
 
        return rc;
 
      /end-free
 
    p                e
 
 
==== EXEC SQL ====
 
ref [http://wiki.midrange.com/index.php/SQLRPGLE]
 
    C/EXEC SQL
 
    C+ SELECT * FROM mylib/myfile
 
    C/END-EXEC
 
free
 
  exec sql select * from mylib/myfile;
 
 
 
==== Open Cursor and Fetch Mainline ====
 
ref [http://wiki.midrange.com/index.php/SQLRPGLE]
 
    H ActGrp(*CALLER)
 
    H DftActGrp(*NO)
 
    D OpenCursor      PR              n
 
    D FetchCursor    PR              n
 
    D CloseCursor    PR              n
 
    D MyLib          s            10a
 
    D MyFile          s            10a
 
      /free
 
      *inlr=*on;
 
      if not OpenCursor();
 
        // perform error routine to alert the troops
 
        // ...
 
      Else;
 
        Dow FetchCursor();
 
          // putting the fetchcursor on the do loop allows the user of
 
          // iter, and thus iter will not perform an infinite loop
 
          // normal processing here...
 
        EndDo;
 
        CloseCursor();
 
      EndIf;
 
      return;
 
      /end-free
 
 
====  Open Cursor Procedure ====
 
ref [http://wiki.midrange.com/index.php/SQLRPGLE]
 
    P OpenCursor      B
 
    D OpenCursor      PI                  like(ReturnVar)
 
    D ReturnVar      s              n
 
      // The immediately following /EXEC SQL is SQL's version of RPG's H Spec
 
      // It is never executed.  Just used at compile time.
 
    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
 
    C/EXEC SQL
 
    C+ Declare C1 cursor for
 
    C+  Select System_Table_Schema as library,
 
    C+        System_Table_Name  as file
 
    C+  from qsys2/systables
 
    C/END-EXEC
 
    C/EXEC SQL
 
    C+ Open C1
 
    C/END-EXEC
 
      /free
 
      Select;
 
        When SqlStt='00000';
 
          return *on;
 
        Other;
 
          return *off;
 
      EndSl;
 
      /end-free
 
    P OpenCursor      E
 
 
==== Fetch Cursor Procedure ====
 
ref [http://wiki.midrange.com/index.php/SQLRPGLE]
 
    P FetchCursor    B
 
    D FetchCursor    PI                  like(ReturnVar)
 
    D ReturnVar      s              n
 
    C/EXEC SQL
 
    C+ Fetch C1 into :MyLib, :MyFile
 
    C/END-EXEC
 
      /free
 
      Select;
 
        When sqlstt='00000';
 
          // row was received, normal
 
          ReturnVar=*on;
 
        When sqlstt='02000';
 
          // same as %eof, sooner or later this is normal
 
          ReturnVar=*off;
 
        Other;
 
          // alert the troops!
 
          ReturnVar=*off;
 
      EndSl;
 
      return ReturnVar;
 
      /end-free
 
    P FetchCursor    E
 
 
==== Close Cursor Procedure ====
 
ref [http://wiki.midrange.com/index.php/SQLRPGLE]
 
    P CloseCursor    B
 
    D CloseCursor    PI                  like(ReturnVar)
 
    D ReturnVar      s              n
 
    C/EXEC SQL
 
    C+ Close C1
 
    C/END-EXEC
 
      /free
 
      Select;
 
        When sqlstt='00000';
 
          // cursor was closed, normal
 
          ReturnVar=*on;
 
        Other;
 
          // alert the troops!
 
          ReturnVar=*off;
 
      EndSl;
 
      return ReturnVar;
 
      /end-free
 
    P CloseCursor    E
 
 
 
[[#top]]
 
  
 
===Exporting and importing snippets===
 
===Exporting and importing snippets===
Line 280: Line 145:
 
[[#top]]
 
[[#top]]
  
=== DayOfWeek snippet===
 
ref [[http://archive.midrange.com/rpg400-l/200105/msg00507.html]]
 
  
 +
===Examples===
 +
[[Snippets/Examples]]
  
      * // Procedure:  DayOfWeek                                          //
 
      * // Purpose:  Determine the day of week for a particular date      //
 
      * // Parameters:                                                    //
 
      * //    I: dt  -- date                                              //
 
      *
 
      * // Returns:                                                        //
 
      * //    0..6    -- 0=Sunday, 1=Monday, 2=Tuesday, etc.              //
 
      * // Notes:                                                          //
 
      * //    January 5, 1800 is a Sunday.  This procedure only works for  //
 
      * //    dates later than 1800-01-05.                                //
 
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P DayOfWeek      b
 
    P
 
    D DayOfWeek      pi            10i 0
 
    D
 
    D  dt                            d  value datfmt(*iso)
 
      /free
 
        return %rem (%diff (dt: d'1800-01-05': *days): 7);
 
      /end-free
 
    P DayOfWeek      e
 
                                                                                         
 
 
[[#top]]
 
[[#top]]
 
=== FirstFriday snippet===
 
 
 
    H DFTACTGRP(*NO ) OPTIMIZE(*NONE) OPTION(*NODEBUGIO)                 
 
                                                                         
 
                         
 
    D WDATE          S            10A                                 
 
                                                                         
 
                             
 
    D FirstFriday    PR            1A                                 
 
    D  Wdate                        10A                                 
 
                                                                         
 
               
 
      /FREE                                                               
 
        *INLR = *on;                                       
 
        WDATE = '2008-12-05';                                                 
 
        *IN01 = FirstFriday(WDATE);                                           
 
      /END-FREE 
 
                                                               
 
      * // Procedure:  FirstFriday                                        //
 
      * // Purpose:  Determine if the date is the First Friday            //
 
      * // Parameters:                                                    //
 
      * //    I: WDATE  -- 10 character ISO delim date                    //
 
      *
 
      * // Returns:                                                        //
 
      * //    0..1    -- 0=NO, 1=YES                                      //
 
      * // Notes:                                                          //
 
      * //    January 5, 1800 is a Sunday.  This procedure only works for  //
 
      * //    dates later than 1800-01-05.                                //
 
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P FirstFriday    B                                                       
 
    P                                                                         
 
    D FirstFriday    PI            1A                                       
 
    D  WDATE                        10A                                       
 
                                                                               
 
      /free                                                                     
 
                                                                               
 
        if %rem(%abs(%diff (%DATE(WDATE) : d'1800-01-05': *days)): 7) = 5       
 
          and %subdt(%DATE(WDATE)  :*D) <=7;                                   
 
            // it is the first Friday of the month                             
 
            RETURN '1';                                                         
 
      endif;                             
 
          RETURN '0';                     
 
                                           
 
    /end-free                             
 
    P FirstFriday    E                   
 
  
  
 +
===CodeGrabs===
 +
[[Snippets/CodeGrabs]]
  
 
[[#top]]
 
[[#top]]
=== System Date snippet===
 
  
ref [[http://archive.midrange.com/rpg400-l/200604/msg00457.html]]
+
===Templates===
 +
[[Snippets/Templates]]
  
Time also works  Return  %INT(%CHAR(%TIME():*ISO0)) set PI to 6S 0.
 
 
      * // Procedure:  SysDate                                            //
 
      * // Purpose:  Gets the system date YYYYMMDD format 8S 0              //
 
      * // Parameters:                                                    //
 
      * // Returns:                                                        //
 
      * //    int    -- date in YYYYMMDD fmt                              //
 
    * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P SysDate        B                       
 
    P                                         
 
    D SysDate        PI            8S 0     
 
    D                                         
 
      /free                                     
 
        Return    %INT(%CHAR(%DATE():*ISO0)); 
 
      /end-free                                 
 
    P SysDate        E                       
 
 
[[#top]]
 
[[#top]]
  
=== CLLE Subroutine===
+
===UDDS File Displayer===
 
+
[[UDDS File Displayer]]
ref [[http://archive.midrange.com/midrange-l/200605/msg01206.html]]
 
 
 
Sample code  V5R4
 
 
 
START:      PGM
 
    SAVLIB    LIB( PVCPROD)  DEV(TAP01) ENDOPT(*LEAVE)  /* Daily library backup */
 
    MONMSG    MSGID(PVC0001)  EXEC(DO)
 
      CALLSUBR BADLIBSAVE
 
    ENDDO
 
RETURN
 
SUBR BADLIBSAVE
 
  /* test */
 
ENDSUBR
 
ENDPGM
 
  
 
[[#top]]
 
[[#top]]
  
=== RPG SYSTEM NAME===
+
===UDDS File Display/Update===
 
+
[[UDDS File Display/Update]]
ref: [[http://archive.midrange.com/rpg400-l/200506/msg00326.html]]
 
 
 
 
 
D RtvSysName      PR            8A                                     
 
D  MyName        S            10A                                     
 
C                  eval      *inlr = *on                               
 
C                  EVAL      MyName =  RtvSysName()                   
 
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++   
 
*  Retrieve System Name                       
 
P RtvSysName      B                  Export                             
 
D RtvSysName      PI            8A                                     
 
D QWCRNETA        PR                  ExtPgm('QWCRNETA')                 
 
D  RcvVar                  32766A  OPTIONS(*VARSIZE)                 
 
D  RcvVarLen                  10I 0 const                                 
 
D  NbrNetAtr                  10I 0 const                                 
 
D  AttrNames                  10A  const                                 
 
D  ErrorCode                  256A                                         
 
D* Error code structure                                                     
 
D EC              DS          256                                           
 
D* Receiver variable for QWCRNETA                     
 
D DS              ds                                                         
 
D  Filler                      32A                                       
 
D  RtnSystem                    8A                                       
 
  * Call API to get system name                                               
 
C                  callp    QWCRNETA(DS: %size(DS): 1: 'SYSNAME': EC)     
 
C                  return    RtnSystem                 
 
P                E                                                         
 
  
 
[[#top]]
 
[[#top]]
  
  
=== MODS w/POINTERS===
+
===RGP  API QDFRTVFD ===
 
+
[[rQDFRTVFD]]
ref: [[http://archive.midrange.com/rpg400-l/200812/msg00473.html]]
 
 
 
DEdtCstRtn        PR                  ExtPgm('@EDTCSTRTN')
 
D SubParm                            Like(MyStruct)
 
D SubParm1                            Like(Struct1)
 
 
Dmystruct      e ds                  ExtName(EDTCSTPF)
 
D                                    occurs(500)
 
DStruct1        e ds                  ExtName(EDTCSTHDR)
 
 
 
I fill the structure and then call the second program
 
 
 
    %occur(myStruct) = 1;
 
    Callp EdtCstRtn(MyStruct:Struct1);
 
 
 
Here is the code from the Called program:
 
 
 
DCstRtnParm      PR                  ExtPgm('@EDTCSTRTN')
 
DPlistPR                              Like(PlistParm)
 
DPlist1PR                            Like(Plist1)
 
DCstRtnParm      PI
 
DPlistPI                              Like(PlistParm)
 
DPlist1PI                            Like(Plist1)
 
 
DPlistParm      e ds                  ExtName(EDTCSTPF)
 
D                                    occurs(500)
 
D                                    based(p_PlistParm)
 
DPlist1        e ds                  ExtName(EDTCSTHDR)
 
D                                    based(p_Plist1)
 
 
  /free
 
      p_PlistParm = %addr(PlistPI);
 
      p_Plist1    = %addr(Plist1PI);
 
 
 
... do NOT EVAL one to the other...
 
... simply access PlistParm as a normal MODS.
 
  
 
[[#top]]
 
[[#top]]
  
 
+
===C  API QDFRTVFD  ===
=== QUSRSPLA CL with STG(*DEFINED) DEFVAR===
+
[[cQDFRTVFD]]
 
 
 
 
ref: [[http://archive.midrange.com/rpg400-l/200902/msg00380.html]]
 
 
 
[[http://publib.boulder.ibm.com/iseries/v5r1/ic2924/index.htm?info/apis/QUSRSPLA.htm | See IBM defn of the SPLA0100 format for whatever attribute you need.]]
 
 
 
/*    GET A SPOOL FILE ATTRIBUTE                                  */   
 
            PGM        PARM(&SPLF &FULLJOB  &RTNWID  )                 
 
                                                                         
 
            DCL        &SPLF *CHAR LEN(10)                               
 
            DCL        &FULLJOB *CHAR LEN(26)                           
 
                                                                         
 
            DCL        &SPLNBR *CHAR LEN(5)                             
 
            DCL        &SPLNBRD *DEC LEN(9 0)                           
 
            DCL        &SPLNBRB *CHAR LEN(4)                             
 
                                                                         
 
            DCL        &DSLEND *DEC LEN(9 0)                             
 
            DCL        &DSLENB *CHAR LEN(4)                             
 
                                                                         
 
            DCL        &INTJOB *CHAR LEN(16)                             
 
            DCL        &INTSPLF *CHAR LEN(16)                           
 
            DCL        &RTNWID *DEC (15 5)                               
 
                                                                         
 
            DCL        &DS      *CHAR LEN(1000)                         
 
            DCL        &RTNWIDTH *DEC (15 5) STG(*DEFINED) DEFVAR(&DS 889)
 
                                                                     
 
      /* GET LAST SPOOL FILE */                                     
 
            CHGVAR    &SPLNBRD -1                                   
 
            CHGVAR    %BIN(&SPLNBRB 1 4) &SPLNBRD                   
 
      /* USE 1000 BYTE DS        */                                 
 
            CHGVAR    &DSLEND 1000                                 
 
            CHGVAR    %BIN(&DSLENB 1 4) &DSLEND                     
 
                                                                     
 
      /* CALL API TO GET SPLFA */                                   
 
      /* OFFSET 888 CONTAINS THE WIDTH AS PACKED DECIMAL 15,5 */     
 
            CALL      QUSRSPLA PARM(&DS &DSLENB 'SPLA0100' +       
 
                        &FULLJOB &INTJOB &INTSPLF &SPLF &SPLNBRB)   
 
            MONMSG  CPF0000                                         
 
                                                                     
 
RTNWID:    CHGVAR &RTNWID    &RTNWIDTH                             
 
                                                                     
 
            RETURN                                                   
 
            ENDPGM                                                   
 
  
 
[[#top]]
 
[[#top]]
  
 +
===C version of DISPR ===
 +
[[C version of DISPR ]]
  
=== RPG WAIT sim DLYJOB  ===
 
ref: [[http://archive.midrange.com/rpg400-l/200501/msg00399.html]]
 
 
    HBNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*NEW)
 
      * this uses the C sleep API
 
      * this is a sample program named 'PSLEEP' to demo the call to the sleep API 
 
      * to test,  call  PSLEEP '0000000005'
 
      *
 
    D PSLEEP          PR
 
    D SECSA                        10A
 
    D PSLEEP          PI
 
    D SECSA                        10A
 
      *
 
    D WAIT            PR            1A
 
    D SECS                          10U 0
 
 
 
    D CURTIME        S              T
 
    D SECS            S            10U 0
 
    D ANS            S            20A
 
 
 
    D SECSDS          DS            10
 
    D SECSN                        10S 0
 
 
 
      /FREE
 
            *INLR = *ON;
 
   
 
            SECSDS = SECSA;
 
            SECS  = SECSN;
 
     
 
            CURTIME = %TIME();
 
            DSPLY CURTIME;
 
   
 
            WAIT(SECS);
 
   
 
            CURTIME = %TIME();
 
            DSPLY CURTIME ' ' ANS;
 
      /END-FREE
 
 
 
      * // Procedure:  Sleep                                              //
 
      * // Purpose:  Wait for a number of  seconds                        //
 
      * // Parameters:                                                    //
 
      * //    I: WSECS  -- 10 int                                          //
 
      *
 
      * // Returns:                                                        //
 
      * //    0..1    -- 0=NOT OK, 1=OK                                    //
 
      * //\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\//
 
    P WAIT            B
 
    P
 
    D WAIT            PI            1A
 
    D WSECS                        10U 0
 
 
 
    DSLEEP            PR            1A  EXTPROC(X'A293858597')
 
    D SECS                          10U 0 VALUE
 
 
 
      /FREE
 
          RETURN  SLEEP(WSECS);
 
      /END-FREE
 
    P WAIT            E     
 
 
[[#top]]
 
[[#top]]
 
=== GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC  ===
 
ref: [[http://archive.midrange.com/rpg400-l/200602/msg00655.html]][[http://archive.midrange.com/rpg400-l/200601/msg01038.html]]
 
 
 
This is an example program showing the usage of the GETROWCOL procedure.
 
 
Its purpose is to set up the ROW and COL for CSRLOC to position to a FIELD in error without the need for indicators.
 
 
You can use a ERRMSG or ERRMSGID on a dummy O field so you will still need to use one indicator for an error.
 
 
If you use ERRMSG or ERRMSGID you will need to position the cursor with a Write before you turn on the indicators for ERRMSG and ERRMSGID. 
 
 
<pre>
 
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 
      *
 
 
    D  FILE          S            10A  INZ('URFILE')
 
    D  FORMAT        S            10A  INZ('URFMT')
 
    D  FLDNAM        S            10A  INZ('URFLD')
 
    D  ROW          S              3S 0
 
    D  COL          S              3S 0
 
 
    D GETROWCOL      PR
 
    D                              10A  const
 
    D                              10A  const
 
    D                              10A  const
 
    D                              32A  const
 
    D                                3S 0
 
    D                                3S 0
 
      /free
 
          *INLR = *ON;
 
          GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL);
 
      /end-free
 
 
 
    P GETROWCOL      B
 
      *
 
      *    Retreive a DSPF FIELD  Row and Col
 
      *    Used for Setting  CSRLOC for cursor positioning
 
      *    USAGE
 
      *    GETROWCOL  (FILE :'*LIBL' : FORMAT : FLDNAM : ROW : COL)
 
      *
 
    D GETROWCOL      PR
 
    D  schFile                    10A  const
 
    D  schLib                      10A  const
 
    D  schFormat                  10A  const
 
    D  schString                  32A  const
 
    D  rtnROW                      3S 0
 
    D  rtnCOL                      3S 0
 
 
    D GETROWCOL      PI
 
        //  PARMS  IN
 
    D  schFile                    10A  const
 
    D  schLib                      10A  const
 
    D  schFormat                  10A  const
 
    D  schString                  32A  const
 
        //  PARMS  OUT
 
    D  rtnROW                      3S 0
 
    D  rtnCOL                      3S 0
 
 
    D QUSCRTUS        PR                  ExtPgm('QUSCRTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ExtAttrib                  10A  CONST
 
    D  InitialSize                10I 0 CONST
 
    D  InitialVal                  1A  CONST
 
    D  PublicAuth                  10A  CONST
 
    D  Text                        50A  CONST
 
    D  Replace                    10A  CONST options(*nopass)
 
    D  ErrorCode                32767A  options(*varsize:*nopass)
 
 
    D QUSPTRUS        PR                  ExtPgm('QUSPTRUS')
 
    D  UserSpace                  20A  CONST
 
    D  Pointer                      *
 
 
    D QUSDLTUS        PR                  ExtPgm('QUSDLTUS')
 
    D  UserSpace                  20A  CONST
 
    D  ErrorCode                32767A  options(*varsize)
 
 
    D QUSLFLD        PR                  ExtPgm('QUSLFLD')
 
    D  UsrSpc                      20A  const
 
    D  Format                      8A  const
 
    D  QualFile                    20A  const
 
    D  RcdFmt                      10A  const
 
    D  UseOvrd                      1A  const
 
    D  ErrorCode                32767A  options(*nopass:*varsize)
 
 
    D ErrorCode      ds                  qualified
 
    D  BytesProv                  10I 0 inz(0)
 
    D  BytesAvail                  10I 0 inz(0)
 
 
    D ListHeader      ds                  based(p_ListHeader)
 
    d  ListOffset                  10I 0 overlay(ListHeader:125)
 
    d  EntryCount                  10I 0 overlay(ListHeader:133)
 
    d  EntrySize                  10I 0 overlay(ListHeader:137)
 
 
    D Field          ds                  based(p_Field)
 
    D                                    qualified
 
    D  Name                        10a
 
    D  FILLER                      438a
 
    d  DspRow                      10i 0
 
    d  DspCol                      10i 0
 
 
    D TEMPSPC        C                  'GETROWCOL QTEMP'
 
 
    D x              s            10I 0
 
 
      /free
 
 
                  rtnROW =    999;
 
                  rtnCOL =    999;
 
          // --------------------------------------------------
 
          // Delete the user space if it exists (ignore errors)
 
          ErrorCode.BytesProv = %size(ErrorCode);
 
          QUSDLTUS( TEMPSPC: ErrorCode );
 
          ErrorCode.BytesProv = 0;
 
 
          // --------------------------------------------------
 
          // Create a new 128k user space
 
          QUSCRTUS( TEMPSPC : 'SCHTEXT' : 128 * 1024  : x'00'
 
                  : '*EXCLUDE' : 'List of fields in file' : '*NO'
 
                  : ErrorCode );
 
 
          // --------------------------------------------------
 
          // Dump list of fields in file to user space
 
          // Invalid data is ignored and is 999 returned for row and col
 
          monitor;
 
          QUSLFLD( TEMPSPC : 'FLDL0100'  : SchFile + SchLib
 
                  : SchFormat  : *OFF  : ErrorCode );
 
              on-Error;
 
                RETURN;
 
            EndMon;
 
          // --------------------------------------------------
 
          // Get a pointer to the user space
 
          QUSPTRUS( TEMPSPC: p_ListHeader );
 
 
          // --------------------------------------------------
 
          // Loop through all fields in space, to get the field we need
 
          for x = 0 to (EntryCount - 1);
 
              p_Field = p_ListHeader + ListOffset + (EntrySize * x);
 
 
              if Field.Name = schString;
 
                  rtnRow =    Field.DspRow;
 
                  rtnCol =    Field.DspCol;
 
                leave;
 
              endif;
 
          endfor;
 
 
          // --------------------------------------------------
 
          // Delete temp user space & end
 
          QUSDLTUS( TEMPSPC: ErrorCode );
 
 
            return;
 
 
      /end-free
 
    P                E     
 
</pre>
 
 
[[#top]]
 
 
=== Format the date like "Wed, 12 Dec 2001 13:21:01 ===
 
 
ref [[http://archive.midrange.com/midrange-l/200112/msg01289.html]]
 
 
RFC2822 requires a date in the format "Wed, 12 Dec 2001 13:21:01 -0500".
 
 
ILE procedure that makes use of SQL
 
 
 
h option(*nodebugio:*srcstmt) dftactgrp(*no) actgrp('QILE')
 
                                                           
 
d getWordyDate    pr                  like(WordyDate)     
 
                                                           
 
d WordyDate      s            31                       
 
d reply          s              1                       
 
                                                           
 
c                  eval      WordyDate = getWordyDate() 
 
c    WordyDate    dsply                  reply         
 
c                  eval      *inlr = *on                 
 
                                                           
 
p getWordyDate    b                                       
 
d getWordyDate    pi                  like(WordyDate)     
 
                                                         
 
d tz              s              6  0                     
 
d t              s              t                       
 
d d              s              d                       
 
d dn              s              9                       
 
d mn              s              9                       
 
d rtn            ds                                           
 
d  ShortDayName                  3                             
 
d                                2    inz(', ')                 
 
d  DayNumeric                    2  0                           
 
d                                1    inz(' ')                 
 
d  ShortMonthName                3                             
 
d                                1    inz(' ')                 
 
d  YearNumeric                  4  0                           
 
d                                1    inz(' ')                 
 
d  TimeOut                        t  timfmt(*hms)             
 
d                                1    inz(' ')                 
 
d  TimeZone                      5                             
 
                                                                 
 
c/exec sql                                                     
 
c+ set (:tz,:TimeOut,:d,:dn,:mn) = (current_timezone,           
 
c+ current_time, current_date, substr(dayname(current_date),1,9),
 
c+ substr(monthname(current_date),1,9))                         
 
c/end-exec                                                     
 
                                                                 
 
c                  eval      DayNumeric = %subdt(d:*d)             
 
c                  eval      YearNumeric = %subdt(d:*y)             
 
c                  eval      ShortDayName = dn                     
 
c                  eval      ShortMonthName = mn                   
 
c                  eval      TimeZone =                             
 
c                            %trim(%editw(%dec(tz/100:4:0):'0-    '))
 
                                                                     
 
c                  return    rtn                                   
 
p getWordyDate    e   
 
 
 
USING the CEE APIs
 
 
  ** Get local time API
 
d CEELOCT        PR                  opdesc
 
d  output_lil                        Like(discard1)
 
d  output_secs                      Like(cur_time)
 
d  output_greg                      Like(discard2)
 
d  output_fc                        Like(Fc) Options(*Nopass)
 
  ** Convert to arbitrary timestamp API
 
d CEEDATM        PR                  opdesc
 
d  input_secs                        Like(cur_time)
 
d  picture_str                      Like(Pictureds) const
 
d  output_ts                        Like(Pictureds)
 
d  output_fc                        Like(Fc) Options(*Nopass)
 
  * Get offset from UTC API
 
d CEEUTCO        PR
 
d  hours                              Like(hrs2utc)
 
d  minutes                            Like(mins2utc)
 
d  seconds                            Like(cur_time)
 
d  output_fc                          Like(Fc) Options(*Nopass)
 
 
d discard1        S            10I 0
 
d cur_time        S              8F
 
d discard2        S            23A
 
d hrs2utc        s            10I 0
 
d mins2utc        s                  Like(hrs2utc)
 
d hh              s              2A
 
d mm              s              2A
 
d discard3        s                  Like(cur_time)
 
d WDate          s                  Like(Pictureds)
 
 
d Fc              ds
 
d  sev                          5U 0
 
d  msgno                        5U 0
 
d  flags                        1A
 
d  facid                        3A
 
d  isi                          10U 0
 
d Pictureds      ds
 
d  Piclen1                1      2I 0
 
d  Picture                3    34A
 
d  Piclen2                1      4I 0
 
d  Picture2              5    36A
 
 
  * Get current local time from clock:
 
c                  Callp    CEELOCT(discard1 : cur_time : discard2)
 
  * Convert to e-mail format:
 
c                  Callp    CEEDATM(cur_time :
 
c                                    'Www, DD Mmm YYYY HH:MI:SS' :
 
c                                    WDate)
 
  * Retrieve offset from UTC
 
c                  Callp    CEEUTCO(hrs2utc : mins2utc : discard3)
 
  * Format the UTC offset nicely
 
  *  and tack it onto the string...
 
c                  If        hrs2utc < *Zero
 
c                  Eval      WDate = %trimr(WDate) + ' -'
 
c                  Eval      hrs2utc = 0 - hrs2utc 
 
c                  Else
 
c                  Eval      WDate = %trimr(WDate) + ' +'
 
c                  EndIf
 
c                  Move      hrs2utc      hh
 
c                  Move      mins2utc      mm
 
c                  Eval      WDate = %TrimR(WDate) + hh + mm
 
 
 
[[#top]]
 
 
=== RPG  FTP TEMPLATE ===
 
<pre>
 
    H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO) ACTGRP(*CALLER)
 
    H Bnddir('QC2LE')
 
      //
 
      //***************************************************************
 
      //  USE  FTP TO GET OR PUT FILES TO THE IFS
 
      //  BIN(ARY) TRANSFERS ARE USED,DATA IS ASSUMED TO BE ASCII
 
      //  IT IS ASSUMED OTHER FUNCTIONS PUT OR GET FROM IFS TO DB FILES
 
      //  SENT FILES (PUT) ARE ARCHIVED TO ARCH SUBDIRECTORY IF IT EXISTS
 
        //
 
        //  REQUIRES FILES FTPADDR AND FTPMSGLOG
 
        //  (LAYOUT CAN BE INFERRED FROM THIS PGM LOGIC)  
 
      //
 
      //  PARMS  IN
 
      // D  ADDR  10A KEY TO FILE FOR USER PWORD AND FTP_ADDR
 
      // D  FDIR  40A        LCD IFS DIRECTORY OF FILE TO PUT/GET
 
      // D  TDIR  40A CD IFS DIRECTORY OF FILE TO PUT/GET
 
      // D  FN    3A PUT  OR GET
 
      // D  FFIL  40A NAME OF FILE
 
      //
 
      //  PARMS OUT
 
      // D  FERR  1A FTP FAIL IF NOT ZERO
 
      //***************************************************************
 
      //
 
      //
 
    FFTPADDR  IF  E          K DISK
 
 
    D PROFILE        S            25
 
    D FROMDIR        S            40
 
    D TODIR          S            40
 
    D FNC            S              3
 
    D FNCFILE        S            40
 
      //
 
    D RT              S            10I 0
 
    D SRCDTA          S            100
 
    D NOK            C                  -1
 
    D OK              C                  0
 
    D TCK1            C                  'TRANSFER COMPLETE'
 
      // Program Status
 
    D                SDS
 
    D  PGM                    1    10
 
    D  WSID                244    253A
 
    D  USER                254    263A
 
    D  NBR                  264    269A
 
    D  DAT                  276    281A
 
      //
 
      //
 
      //-------------------- Prototypes
 
    D FTPPGM        PR
 
    D                              10A
 
    D                              40A
 
    D                              40A
 
    D                                3A
 
    D                              40A
 
    D                                1A
 
    D FTPPGM        PI
 
    D  ADDR                        10A
 
    D  FDIR                        40A
 
    D  TDIR                        40A
 
    D  FN                            3A
 
    D  FFIL                        40A
 
    D  FERR                          1A
 
      //  FOR RUNNING AS400 COMMANDS
 
    D SYS            PR            10I 0 Extproc('system')
 
    D  CmdString                    *  Value
 
    D                                    Options(*String)
 
      //
 
    D MAIN            PR
 
    D WRKFILES        PR
 
    D LOADFTPS        PR
 
    D DOTHEFTP        PR
 
    D RMVWRKF        PR
 
    D CKTHEFTP        PR
 
    D MOVTOARCH      PR
 
    D LOGTHEFTP      PR
 
 
      /FREE
 
                MAIN();
 
      /END-FREE
 
      //
 
      //###################################################//
 
    P    MAIN        B
 
      //
 
      //***************************************************************
 
    D MAIN            PI
 
      /FREE
 
              *INLR = *ON;
 
      //
 
        WRKFILES();  // SETUP FTP WORK FILES
 
      //
 
        LOADFTPS();  // SETUP FTP COMMANDS
 
      //
 
        DOTHEFTP();  // EXECUTE THE FTP
 
      //
 
        CKTHEFTP();  // CHECK THE TRANSFER
 
      //
 
        MOVTOARCH(); // MOVE TO ARCHIVE
 
      //
 
        LOGTHEFTP(); // LOG THE FTP OUTPUT
 
      //
 
        RMVWRKF ();  // CLEANUP THE WORK FILES
 
      RETURN;
 
      //###################################################//
 
      /END-FREE
 
    P    MAIN        E
 
      //
 
      //###################################################//
 
    P  WRKFILES      B
 
      /FREE
 
      RT  = SYS('DLTF  QTEMP/INPUT');
 
      RT  = SYS('DLTF  QTEMP/OUTPUT');
 
      RT  = SYS('CRTSRCPF  QTEMP/INPUT MBR(*FILE)');
 
      RT  = SYS('CRTSRCPF  QTEMP/OUTPUT MBR(*FILE)');
 
      RT  = SYS('OVRDBF INPUT  QTEMP/INPUT OVRSCOPE(*JOB)');
 
      RT  = SYS('OVRDBF OUTPUT  QTEMP/OUTPUT OVRSCOPE(*JOB)');
 
      /END-FREE
 
    P  WRKFILES      E
 
      //
 
      //###################################################//
 
    P  LOADFTPS      B
 
      /FREE
 
          FERR = '0';
 
          CHAIN ADDR  FTPADDR;
 
            IF NOT %FOUND;
 
                FERR = '1';
 
                RETURN;
 
              ENDIF;
 
        //
 
          PROFILE = FTUSER + ' ' + FTPASS;
 
          FROMDIR = FDIR;
 
          TODIR  = TDIR;
 
          FNCFILE = FFIL;
 
          FNC    = FN;
 
        //
 
        EXEC SQL SET OPTION COMMIT =*NONE;
 
        //
 
        EXEC SQL
 
        INSERT INTO  INPUT  VALUES
 
        (0,0 , :PROFILE                            ) ,
 
        (0,0 , 'NAMEFMT 1          '                ) ,
 
        (0,0 , 'LCD ' || :FROMDIR                  ) ,
 
        (0,0 , 'CD '  || :TODIR                    ) ,
 
        (0,0 , 'BIN '                              ) ,
 
        (0,0 , :FNC ||' ' || :FNCFILE              ) ,
 
        (0,0 , 'CLOSE '                            ) ,
 
        (0,0 , 'QUIT'                              ) ;
 
        //
 
        IF  sqlstt <> '00000';
 
                FERR = '2';
 
                RETURN;
 
        ENDIF;
 
      /END-FREE
 
    P  LOADFTPS      E
 
      //
 
      //###################################################//
 
    P  DOTHEFTP      B
 
      /FREE
 
        IF  FERR <> '0';
 
          RETURN;
 
        ENDIF;
 
      RT  = SYS('FTP ' + FTADDR );
 
      /END-FREE
 
    P  DOTHEFTP      E
 
      //
 
      //###################################################//
 
    P  CKTHEFTP      B
 
      /FREE
 
          EXEC SQL                                     
 
SELECT SRCDTA into :SRCDTA FROM OUTPUT WHERE 
 
  UPPER(SRCDTA)  like  '%TRANSFER COMPLETE%'       
 
  FETCH FIRST 1 ROW ONLY ;     
 
        //   
 
        IF  sqlstt <> '00000';
 
                FERR = '3';
 
                RETURN;
 
        ENDIF;
 
      /END-FREE
 
    P  CKTHEFTP      E
 
      //
 
      //###################################################//
 
    P  MOVTOARCH      B
 
      /FREE
 
        IF  FERR <> '0';
 
          RETURN;
 
        ENDIF;
 
        //  ONLY ARCHIVE THE SENT FILES  (PUT)
 
        IF  FNC  =  'GET';
 
          RETURN;
 
        ENDIF;
 
      RT  = SYS('MOV OBJ(''' + %TRIM(FROMDIR) +
 
                          %TRIM(FNCFILE) +  ''') ' +
 
                'TODIR('''+ %TRIM(FROMDIR) + 'ARCH'')') ;
 
      /END-FREE
 
    P  MOVTOARCH      E
 
      //
 
      //###################################################//
 
    P  LOGTHEFTP      B
 
      /FREE
 
        EXEC SQL
 
        INSERT INTO FTPMSGLOG
 
        (SELECT :WSID, :USER,:NBR, :DAT, SRCDTA FROM OUTPUT) ;
 
      /END-FREE
 
    P  LOGTHEFTP      E
 
      //
 
      //###################################################//
 
    P  RMVWRKF        B
 
      /FREE
 
      RT  = SYS('DLTF  QTEMP/INPUT');
 
      RT  = SYS('DLTF  QTEMP/OUTPUT');
 
      RT  = SYS('DLTOVR  INPUT LVL(*JOB)');
 
      RT  = SYS('DLTOVR  OUTPUT LVL(*JOB)');
 
      /END-FREE
 
    P  RMVWRKF        E
 
</pre>
 
 
[[#top]]
 
 
 
=== RPG  IFS READ TEMPLATE ===
 
<pre>
 
H OPTIMIZE(*NONE) OPTION(*NODEBUGIO)
 
    H DFTACTGRP(*NO ) ACTGRP(*CALLER)
 
  >
 
  >  *  RPGLE  IFSREADR  CHECK the files in a directory
 
  >  *  If the file exists it needs to be PROCESSED
 
  >  *
 
      *
 
      *  PARMS IN
 
      *  prefix  10 chr  10 character prefix to find a file
 
      *  path    256 chr  the path on the IFS to check 
 
      *
 
 
 
      *
 
    D p_old_dir      s              *
 
    D old_dir        s            256A
 
    D p_new_dir      s              *
 
    D new_dir        s            256A
 
 
    d* a few local variables...
 
    D dh              S              *
 
    D PathName        S            256A
 
    D Name            S            256A
 
    D cl              S            10U 0
 
    D @loop          S              1A
 
    D NameF          S            64A
 
    D Suff            S              3A
 
    D x              S              9P 0
 
    D prefixv        S            10A  varying
 
 
  >
 
      //-------------------- Prototypes
 
    D MAIN            PR
 
    D WRKFILES        PR
 
 
    D IFSREADR        PR
 
    D                              10A
 
    D                              256A
 
    D IFSREADR        PI
 
    D  prefix                      10A
 
    D  PATH                        256A
 
 
 
 
      *
 
    d**********************************************************************
 
    d*
 
    d* Directory Entry Structure (dirent)
 
    d*
 
    d* struct dirent {
 
    d*  char          d_reserved1[16];  /* Reserved                      */
 
    d*  unsigned int  d_reserved2;      /* Reserved                      */
 
    d*  ino_t          d_fileno;        /* The file number of the file    */
 
    d*  unsigned int  d_reclen;        /* Length of this directory entry
 
    d*                                    * in bytes                      */
 
    d*  int            d_reserved3;      /* Reserved                      */
 
    d*  char          d_reserved4[8];  /* Reserved                      */
 
    d*  qlg_nls_t      d_nlsinfo;        /* National Language Information
 
    d*                                    * about d_name                  */
 
    d*  unsigned int  d_namelen;        /* Length of the name, in bytes
 
    d*                                    * excluding NULL terminator      */
 
    d*  char          d_name[_QP0L_DIR_NAME]; /* Name...null terminated  */
 
    d*
 
    d* };
 
 
    D p_dirent        s              *
 
    D dirent          ds                  based(p_dirent)
 
    D  d_reserv1                  16A
 
    D  d_reserv2                  10U 0
 
    D  d_fileno                    10U 0
 
    D  d_reclen                    10U 0
 
    D  d_reserv3                  10I 0
 
    D  d_reserv4                    8A
 
    D  d_nlsinfo                  12A
 
    D    nls_ccsid                10I 0 OVERLAY(d_nlsinfo:1)
 
    D    nls_cntry                  2A  OVERLAY(d_nlsinfo:5)
 
    D    nls_lang                  3A  OVERLAY(d_nlsinfo:7)
 
    D    nls_reserv                3A  OVERLAY(d_nlsinfo:10)
 
    D  d_namelen                  10U 0
 
    D  d_name                    640A
 
 
    d*--------------------------------------------------------------------
 
    d* Open a Directory
 
    d* DIR *opendir(const char *dirname)
 
    D opendir        PR              *  EXTPROC('opendir')
 
    D  dirname                        *  VALUE
 
 
    d*--------------------------------------------------------------------
 
    d* Read Directory Entry
 
    d* struct dirent *readdir(DIR *dirp)
 
    D readdir        PR              *  EXTPROC('readdir')
 
    D  dirp                          *  VALUE
 
 
 
    d*--------------------------------------------------------------------
 
    d* Close  Directory
 
    d* int closedir(DIR *dirp)
 
    D closedir        PR            10U 0 EXTPROC('closedir')
 
    D  cldirp                        *  VALUE
 
 
 
      /FREE
 
                MAIN();
 
      /END-FREE
 
 
      //###################################################//
 
    P    MAIN        B
 
      /FREE
 
          *inlr = '1' ;
 
          prefixv = %trim(prefix);
 
 
      // Step1: Open up the directory.
 
              PathName= %trim(PATH)+ x'00';
 
              dh = opendir(%addr(PathName));
 
 
      // Step2: Read each entry from the directory
 
          dow      @loop = @loop;
 
                p_dirent = readdir(dh);
 
                  if      p_dirent =  *NULL;
 
                    leave;
 
                  endif;
 
 
                  Name = %subst(d_name:1:d_namelen);
 
      // not a file
 
          If Name = '. ' or Name = '.. ' ;
 
            Iter;
 
          Endif;
 
 
      // Strip the suffix
 
            Namef = %subst(Name:1:10);
 
            x  = %scan('.':Name:1);
 
            If x > 1;
 
            NameF = %subst(Name:1:x-1);
 
            EndIf;
 
      // not a file  (assume names without suff are not files)
 
            If x < 2;
 
            Iter;
 
            Endif;
 
      // Get the suffix
 
            Suff  = %trim(%subst(Name:x+1));
 
 
 
      //  PROCESS  THE FILE
 
 
          WRKFILES();
 
 
 
          EndDo;
 
 
      // Step3: Close  the directory.
 
              cl = closedir(dh);
 
      /END-FREE
 
 
    P    MAIN        E
 
 
 
      //###################################################//
 
    P    WRKFILES    B
 
 
    D FTPPROC        PR                  EXTPGM('FTPPROC')
 
    D                              10A  CONST
 
    D                              40A  CONST
 
    D                              40A  CONST
 
    D                                3A  CONST
 
    D                              40A  CONST
 
    D                                1A
 
 
    D WC011R          PR                  EXTPGM('WC011R')
 
    D                              10A  CONST
 
    D                              10A  CONST
 
    D                              10A  CONST
 
    D                              256A  CONST
 
    D                                1A
 
 
    D  ADDR          s            10A
 
    D  FDIR          s            40A
 
    D  TDIR          s            40A
 
    D  FFIL          s            40A
 
    D  FERR          s              1A
 
    D  CDATA        s            256A
 
    D  ERR          s              1A
 
    D  @@ENV        S              4A
 
      /FREE
 
            x  = %scan(prefixv:NameF:1);
 
 
            If x = 1;
 
        //  Found a file matching the pre fix
 
 
          ADDR = 'CAR';
 
          FFIL =  NAME;
 
        //  GET A DIR FOR A CONTROL FILE
 
        WC011R ('INVC  ':'COMPY1  ':'LOC  ': CDATA: ERR) ;
 
          TDIR =  CDATA;
 
 
          FDIR  =  %TRIM(PATH);
 
 
 
        IF (ERR = 'N') ;
 
        //  FTP SEND THE FILE
 
        FTPPROC    ( ADDR : FDIR : TDIR :'PUT': FFIL : FERR );
 
        ENDIF;
 
 
            EndIf;
 
 
      /END-FREE
 
    P    WRKFILES    E
 
 
 
</pre>
 
 
[[#top]]
 
==External links==
 
The official WDSC web page [http://www-306.ibm.com/software/awdtools/wdt400/]
 
 
The WDSC Developer blog [http://wdsc.wordpress.com/]
 
 
WDSC tags on del.ici.ous [http://del.icio.us/tag/wdsc]
 
  
 
==Categories==
 
==Categories==
 
[[Category:WDSC]]
 
[[Category:WDSC]]

Latest revision as of 19:50, 19 August 2022


SNIPPETS

A snippet is a sort of code template or skeleton that allows you to quickly set up a commonly used code fragment like a subprocedure definition (in ILE RPG). Snippets are available from WDSC 7.0 up.

This differs from code templates because the code template is invoked by the code completion facility Ctrl+Space.

Code completion with templates requires you to start keying the 'trigger' (in RPG, usually the operation code.)

With snippets, you can have Lpex include anything at all, with no trigger needed aside from the double click on the selected snippet.


Snippets View

original post [1]

To open a snippets view:

  • Enable XML Developer capability:
    • Window → Preferences → General → Capabilities, and then check XML Developer.
  • Window → Show view → Other → Basic → Snippets

#top

Create a Snippets Category

original post [2]

  • You only need to create a Category once, conceptually its like CRTSRCPF.
  • Create as many Categories as you wish.
  • -Right-click in the Snippets view and select Customize...
  • -Click the New button and create a New Category
  • -Click the New button and create a New Item
  • -Click on the snippet and then click the New button that is adjacent to the Variables list
  • -Enter your snippet and use the Insert Variable Placeholder button to add the variable

alternatively use the copy, right click process below, its easier.

Use snippets for RPGLE, CLLE, DSPF and PRTF source members.


#top

Snippets RPG

original post [3]

You can use the snippets to insert stuff into your program.

To create your own RPG snippets,

  • you can open the view in RSE or iSeries Editing perspective,
  • select your source,
  • then Right Click / Paste in the snippets view, into your Previously created Category.

It will then create a new template.

To use the snippet;

  • Open a source member for editing.
  • Place the cursor where you want the code.
  • Go to the Snippets view, to the Category where the snippet is.
  • Double click on the snippet and it appears in the source


original post [4]

Another method is to create a Snippet.

  1. Open the Snippets view.
  2. Create a new 'Drawer' for your snippets.
  3. Copy some source.
  4. Right-click in your snippet drawer, paste.
  5. This will bring up the snippet creation wizard.

Long Procedure Name

original post [5]

How do I get the PR to stay at the same column position, irrespective of what name I use for the procedure ?

Use:

D ${Procedure}...
                          PR  

Otherwise the procedure name has to always be 12 characters in length. With the elipsis (...) it can be up to 60 odd characters in length.


#top


Exporting and importing snippets

ref [[6]]

Snippets can be transferred to another PC by the process of exporting and importing.

You export on the PC you want to copy the snippets from, and import on the PC you want to copy them to.

Exporting

  • In the Snippets view right click and select Customize
  • Select your custom snippet category
  • Select Export (top of the category list, left side)
  • See the 'Save as...' dialogue box, remember the file name you chose!
  • Copy/FTP/email that XML file to the target PC

Importing

  • Get a snippets XML file some place where it's available to WDSC
  • In the Snippets view right click and select Customize
  • Select your custom snippet category
  • Select Import (top of the category list, left side)
  • See the 'Open...' dialogue box.
  • Select the XML file to import

Snippets XML structure

<?xml version="1.0" encoding="UTF-16"?>
<snippets>
    <category filters="*" id="category_1185380127750" initial_state="0" label="RPG" largeicon="" smallicon="">
        <description/>
        <item category="category_1185380127750" class="" editorclass="" id="item_1207666311828" label="subprocedure" largeicon="" smallicon="">
            <description><![CDATA[Subprocedure skeleton]]></description>
            <content><![CDATA[
      * ${proc_comment}
     p ${proc_name}        b
     d ${proc_name}        pi            10i 0
     d  ${parm_name}                      1a
     
     d rc                            10i 0 inz

     c/free
        return rc;
      /end-free
     p                 e]]></content>
            <variable default="Description of procedure" id="name_3" name="proc_comment">
                <description><![CDATA[Description]]></description>
            </variable>
            <variable default="new_parm" id="name_2" name="parm_name">
                <description><![CDATA[Parameter name]]></description>
            </variable>
            <variable default="new_proc" id="name_1" name="proc_name">
                <description><![CDATA[Procedure name]]></description>
            </variable>
        </item>
    </category>
</snippets>


#top


Examples

Snippets/Examples

#top


CodeGrabs

Snippets/CodeGrabs

#top

Templates

Snippets/Templates

#top

UDDS File Displayer

UDDS File Displayer

#top

UDDS File Display/Update

UDDS File Display/Update

#top


RGP API QDFRTVFD

rQDFRTVFD

#top

C API QDFRTVFD

cQDFRTVFD

#top

C version of DISPR

C version of DISPR

#top

Categories