Difference between revisions of "Snippets"

From MidrangeWiki
Jump to: navigation, search
(GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC)
m (/)
Line 1,244: Line 1,244:
 
     P    WRKFILES    B
 
     P    WRKFILES    B
  
     D FTPPROC        PR                  EXTPGM('FTPPROC')
+
     D FTPPROC        PR                  EXTPGM('FTPPGM')
 
     D                              10A  CONST
 
     D                              10A  CONST
 
     D                              40A  CONST
 
     D                              40A  CONST
Line 1,296: Line 1,296:
  
 
[[#top]]
 
[[#top]]
 +
 
==External links==
 
==External links==
 
The official WDSC web page [http://www-306.ibm.com/software/awdtools/wdt400/]
 
The official WDSC web page [http://www-306.ibm.com/software/awdtools/wdt400/]

Revision as of 21:47, 30 September 2010


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

Examples

Subprocedure skeleton:

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 [6]

    C/EXEC SQL
    C+ SELECT * FROM mylib/myfile
    C/END-EXEC
free
 exec sql select * from mylib/myfile;


Open Cursor and Fetch Mainline

ref [7]

    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 [8]

    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 [9]

    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 [10]

    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

ref [[11]]

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

DayOfWeek snippet

ref [[12]]


     * // 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

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                     


#top

System Date snippet

ref [[13]]

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

CLLE Subroutine

ref [[14]]

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

RPG SYSTEM NAME

ref: [[15]]


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


MODS w/POINTERS

ref: [[16]]

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


QUSRSPLA CL with STG(*DEFINED) DEFVAR

ref: [[17]]

[| 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


RPG WAIT sim DLYJOB

ref: [[18]]

    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

GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC

ref: [[19]][[20]]


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.

     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       

#top

Format the date like "Wed, 12 Dec 2001 13:21:01

ref [[21]]

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

     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

#top


RPG IFS READ TEMPLATE

 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('FTPPGM')
     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


#top

External links

The official WDSC web page [22]

The WDSC Developer blog [23]

WDSC tags on del.ici.ous [24]

Categories