Difference between revisions of "Snippets"
From MidrangeWiki
(→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(' | + | 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
Contents
- 1 SNIPPETS
- 1.1 Snippets View
- 1.2 Create a Snippets Category
- 1.3 Snippets RPG
- 1.4 Long Procedure Name
- 1.5 Examples
- 1.6 Exporting and importing snippets
- 1.7 DayOfWeek snippet
- 1.8 FirstFriday snippet
- 1.9 System Date snippet
- 1.10 CLLE Subroutine
- 1.11 RPG SYSTEM NAME
- 1.12 MODS w/POINTERS
- 1.13 QUSRSPLA CL with STG(*DEFINED) DEFVAR
- 1.14 RPG WAIT sim DLYJOB
- 1.15 GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC
- 1.16 Format the date like "Wed, 12 Dec 2001 13:21:01
- 1.17 RPG FTP TEMPLATE
- 1.18 RPG IFS READ TEMPLATE
- 2 External links
- 3 Categories
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
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.
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.
- Open the Snippets view.
- Create a new 'Drawer' for your snippets.
- Copy some source.
- Right-click in your snippet drawer, paste.
- 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.
Examples
Subprocedure skeleton:
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
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>
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
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
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
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
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
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.
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
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
GET ROW AND COL FOR A DSPF FIELD FOR CSRLOC
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
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
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
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
External links
The official WDSC web page [22]
The WDSC Developer blog [23]
WDSC tags on del.ici.ous [24]
