|
|
(20 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]]
| |
− | | |
− | | |
− | === MODS w/POINTERS===
| |
− | | |
− | 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]]
| |
− | | |
− | | |
− | === QUSRSPLA CL with STG(*DEFINED) DEFVAR===
| |
− | | |
− | | |
− | 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]]
| |
− | | |
− | | |
− | === 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]]
| |
− | | |
− | === 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]] | | [[#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
| |
| | | |
| + | ===RGP API QDFRTVFD === |
| + | [[rQDFRTVFD]] |
| | | |
| [[#top]] | | [[#top]] |
| | | |
− | === RPG FTP TEMPLATE === | + | ===C API QDFRTVFD === |
− | <pre>
| + | [[cQDFRTVFD]] |
− | 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]] | | [[#top]] |
| | | |
− | | + | ===C version of DISPR === |
− | === RPG IFS READ TEMPLATE === | + | [[C version of DISPR ]] |
− | <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('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
| |
− | | |
− | | |
− | </pre>
| |
| | | |
| [[#top]] | | [[#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]] |