- RPG Report - 01 Feb 2011
- RPG Report - 15 Feb 2011
- RPG Report - 01 March 2011
- RPG Report - 15 March 2011
- RPG Report - 05 April 2011
- RPG Report - 19 APR 2011
- RPG Report - 03 MAY 2011
- RPG Report - 17 MAY 2011
- RPG Report - 07 JUNE 2011
- RPG Report - 21 JUNE 2011
- RPG Report - 05 JULY 2011
- RPG Report - 19 JULY 2011
- RPG Report - 02 August 2011
- RPG Report - 16 August 2011
- RPG Report - 06 Sept 2011
- RPG Report - 20 SEPT 2011
- RPG Report - 04 OCT 2011
- RPG Report - 18 Oct 2011
- RPG Report - 01 Nov 2011
- RPG Report - 15 Nov 2011
- CSV Parser
- Relational Database Access
Using IBM i? Need to create Excel, CSV, HTML, JSON, PDF, SPOOL reports? Learn more about the fastest and least expensive tool for the job: SQL iQuery.
New FTP File CL Command
Published by: Bob Cozzi on 01 Nov 2011 view comments
© 2011 Robert Cozzi, Jr. All rights reserved.
RPG Report ™
Issue Date: 01
November 2011
Bob Cozzi's Newsletter for IBM i Professionals
Published by:
midrangeNews.com
© Robert Cozzi, Jr. All rights reserved.
Reproduction/Redistribution prohibited.
A midrangeNews.com Publication
A midrangeNews.com Publication
Updated FTP CL Command
FTPSNDFILE Becomes FTPFILE
In an earlier issue of RPG Report, I published the popular FTPSNDFILE (FTP Send File) CL Command. As the name implies, it allows you to send a file to a remove system using FTP. It allows you to avoid interacting with the FTP client by generating the necessary FTP script for you.
The FTPSNDFILE command is limited in that it sends files (performs an FTP "put") but could not receive files (FTP "get"). The other restriction is that it sends DB2 files but not IFS files.
Introducing the FTPFILE Command
Originally I intended to add the ability to send SAVF (save files) to FTPSNDFILE, but as time passed I realized that sending IFS files would also be beneficial. That lead me to the follow upgrades:
- Transfer Save Files
- Transfer IFS file in BINARY or ASCII modes
- Send or Receive Files
- Bug fixes
Transfer Save Files
The issue with sending save files is that if the .SAVF suffix is NOT specified, and the file does not exist on the target machine, the file that is created will not be a real save file. To support save file transfer, I had to add a RTVOBJD API call to retrieve the object type. If the object is a file and has "SAVF" as it's file attribute, the new FTPFILE command will add use the .SAVF suffix automatically.
When receiving a file, the local file, if it is a save file, should already exist on the local machine or the file may not be created as a save file.
Transfer IFS Files
Why not include the ability to send/receive files to the IFS? To support this feature, the ability to enter an IFS file name is required. Since FTPFILE supports DB2 files, in order to accept IFS file two STMF (stream file) parameters have been added: LCLSTMF and RMTSTMF
These parameter don't show up on the command prompter initially, however if *IFS (or *STMF) is specified for the LCLFILE parameter, the LCLSTMF and RMTSTMF parameters appear.
Send or Receive Files
As it turns out, we don't just send data from the IBM i platform, we also need to receive data. Normally the remote system would initiate that transfer, but obviously receiving files is important. To specify the direction of the transfer, the PUTGET parameter has been added. This parameter must be, obviously, *PUT or *GET.
To insure that the user of the command doesn't assume one direction or another, this new parameter is required. That is it must also be specified. Interactively, if it is not specified, the prompter is automatically evoked.
The CL Command, FTPFILE source code follows, use PDM option 14 (CRTCMD) to compile it with the default values.
FTPFILE: CMD PROMPT('Put or GET Files using FTP')
/**********************************************/
/* Command processing program is FTPFILE */
/*--------------------------------------------*/
/* REQUIREMENTS: FTP server must be active. */
/* The FTP source file for */
/* the generated FTP script */
/* must exist, but the member */
/* is automaticallyed added. */
/* The LOG file must exist */
/* and should be 79 or 80 */
/* bytes in length--a typical */
/* source file is acceptable. */
/**********************************************/
IP: PARM KWD(RMTSYS) TYPE(*CHAR) LEN(128) MIN(1) +
EXPR(*YES) PROMPT('Remote IP or FTP +
server' 1)
PUTGET: PARM KWD(PUTGET) TYPE(*LGL) RSTD(*YES) +
SPCVAL((*PUT '0') (*GET '1') (PUT '0') +
(GET '1') (*SEND '0') (*RECV '1')) MIN(1) +
CHOICE('*PUT, *GET') PROMPT('Send or +
Receive (Put or Get)' 2)
LCLFILE: PARM KWD(LCLFILE) TYPE(QUAL1) SNGVAL((*STMF) +
(*NONE *STMF)) MIN(1) PROMPT('Local file' 3)
LCLMBR: PARM KWD(LCLMBR) TYPE(*GENERIC) LEN(10) +
DFT(*FILE) SPCVAL((*FILE) (*FIRST) +
(*LAST) (*ALL)) EXPR(*YES) PROMPT('Local +
member' 3)
QUAL1: QUAL TYPE(*NAME) LEN(10) MIN(1) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) +
EXPR(*YES) PROMPT('Library')
RMTFILE: PARM KWD(RMTFILE) TYPE(QUAL2) PROMPT('Remote file' 3)
RMTMBR: PARM KWD(RMTMBR) TYPE(*NAME) LEN(10) DFT(*LCLMBR) +
SPCVAL((*LCLMBR) (*LCLFILE) (*RMTFILE)) +
EXPR(*YES) PROMPT('Remote member' 4)
QUAL2: QUAL TYPE(*NAME) LEN(10) DFT(*LCLFILE) +
SPCVAL((*LCLFILE)) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*LCLLIB) SPCVAL((*LCLLIB)) +
EXPR(*YES) PROMPT('Library')
REPLACE: PARM KWD(REPLACE) TYPE(*LGL) LEN(1) RSTD(*YES) +
DFT(*YES) SPCVAL((*YES '1') (*NO '0')) +
EXPR(*YES) PROMPT('Replace data on target +
system')
USER: PARM KWD(USER) TYPE(*CHAR) LEN(64) DFT(*CURRENT) +
SPCVAL((*CURRENT)) EXPR(*YES) +
PROMPT('Remote FTP User ID')
PWD: PARM KWD(PWD) TYPE(*CHAR) LEN(64) DFT(*USERID) +
EXPR(*YES) DSPINPUT(*PROMPT) +
PROMPT('Remote FTP Password')
MODE: PARM KWD(MODE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*AUTO) SPCVAL((*AUTO AUTO) (*BINARY +
BINARY) (*TEXT ASCII) (*ASCII ASCII) +
(*IMAGE BINARY) (AUTO) (BINARY) (ASCII) +
(TEXT ASCII)) EXPR(*YES) PROMPT('Transfer +
mode')
SRCFILE: PARM KWD(SRCFILE) TYPE(QUAL3) PROMPT('Src file +
to receive FTP script')
PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) +
DFT(*LCLMBR) SPCVAL((*LCLMBR) (*GEN)) +
EXPR(*YES) PROMPT('Script source member')
QUAL3: QUAL TYPE(*NAME) LEN(10) DFT(QFTPSRC) EXPR(*YES)
QUAL TYPE(*NAME) DFT(QTEMP) SPCVAL((*LIBL)) +
EXPR(*YES) PROMPT('Library')
/*************************************************************/
/** The LOG member can be a source or database file. */
/** A record length of 79 or 80 or more than 80 is needed. */
/** If the log file does not exist, it is created for you. */
/*************************************************************/
LOG: PARM KWD(LOG) TYPE(QUAL4) DFT(*) SNGVAL((* +
*STDOUT) (*STDOUT) (*NONE) (*SRCFILE)) +
PROMPT('FTP log output')
PARM KWD(LOGMBR) TYPE(*NAME) LEN(10) +
DFT(*LCLMBR) SPCVAL((*LCLMBR) (*SRCMBR +
*SCRIPT) (*SCRIPT)) EXPR(*YES) +
PROMPT('Log member')
QUAL4: QUAL TYPE(*NAME) LEN(10) SPCVAL((QFTPLOG)) +
EXPR(*YES)
QUAL TYPE(*NAME) DFT(QTEMP) SPCVAL((*LIBL)) +
EXPR(*YES) PROMPT('Library')
/* The follow parmaeter is ignored when LOG(*STDIO) is specified. */
DSPFTPLOG: PARM KWD(DSPLOG) TYPE(*LGL) RSTD(*YES) DFT(*NO) +
SPCVAL((*YES '1') (*NO '0')) EXPR(*YES) +
PROMPT('Display FTPLOG after transfer')
/* If either of these parameters are specified, the */
/* LCLFILE and RMTFILE parameters are ignored. */
LOCALIFS: PARM KWD(LCLSTMF) TYPE(*PNAME) LEN(640) +
DFT(*NONE) SPCVAL((*NONE ' ')) MIN(0) +
EXPR(*YES) VARY(*YES) PMTCTL(USESTMF) +
PROMPT('Local Stream file' 4)
REMOTEIFS: PARM KWD(RMTSTMF) TYPE(*PNAME) LEN(640) +
DFT(*NONE) SPCVAL((*NONE ' ')) MIN(0) +
EXPR(*YES) VARY(*YES) PMTCTL(USESTMF) +
PROMPT('Remote Stream file' 4)
USESTMF: PMTCTL CTL(LCLFILE) COND((*EQ *STMF) (*EQ *NONE)) +
NBRTRUE(*GE 1)
DEP CTL(&LCLFILE *EQ ' ') PARM((&LCLSTMF *NE ' ') (&RMTSTMF *NE ' '))
DEP CTL(&RMTFILE *EQ ' ') PARM((&LCLSTMF *NE ' ') (&RMTSTMF *NE ' '))
DEP CTL(&LCLSTMF *NE ' ') PARM((&RMTSTMF *NE ' '))
DEP CTL(&RMTSTMF *NE ' ') PARM((&LCLSTMF *NE ' '))
FTPFILE RPGIV Source Code
Originally written in 2005 and updated earlier this year, FTPFILE is based on the original FTPSNDFILE code base. There are bugs in some of the IBM-supplied QSYSINC source members under v7r1, but they seem to be fixed in the recent set of PTFs.
The only prerequisite to compile the FTPFILE source is that a file named QFTPSRC must exist. Normally I create it at the maximum length allowed by SEU, which is 240 bytes plus the 12 for the source sequence and change date. This means that RCDLEN(252) should be specified on the CRTSRCPF command, as follows:
CRTSRCPF SRCFILE(QFTPSRC) RCDLEN(252)
As with the QCMDSRC, the QRPGLESRC member can take the default parameters, as most of the adjustments have been specified on the Header specification.
FTPFILE: Rev. 23NOV2011
.....H BNDDIR('QC2LE') OPTION(*NODEBUGIO:*SRCSTMT)
H DFTACTGRP(*NO) ACTGRP(*NEW) EXTBININT(*YES)
H Copyright('(c) 2005 - 2011 by Robert Cozzi, Jr.')
*************************************************************************
** FTPFILE - (c) 2005-2011 Robert Cozzi, Jr. **
** All rights reserved. Used by permission. **
**---------------------------------------------------------------------**
** Documentation Located at: http://www.classanova.com//view?id=1403 **
*************************************************************************
** Software is provided "as is" for illustrative/example
** purposes only. No warranty is expressed or implied and
** none is given.
** Permission to reference in other software is granted
** with the following conditions:
** (1) No money is charged or exchanged for this component.
** (2) This notice along with the copyright notification is
** remains in any distribution of this software.
** (3) The right to reproduce this software for publication
** purposes is expressly denied. Instead, please reference
** the original source code via a URL link.
**************************************************************
** **
**************************************************************
** This source is set up to run on OS/400 V5R1 and later.
**
** To Compile this source member, you must first create
** a source file name QFTPSRC with a record length
** of at least 150 bytes, but I recommend 240 (252).
**
** CRTSRCPF QGPL/QFTPSRC RCDLEN(252)
**
** USAGE NOTES: This source file receives the FTP scripts
** that are generated by the program.
**************************************************************
FQFTPSRC UF A E DISK USROPN RENAME(QFTPSRC:FTPSRCREC)
F EXTFILE(szFTPSRC) EXTMBR(szFTPMBR)
** Input parameter list.
** Although not strictly required, this program is
** normally called as the CPP of a command definition.
** These parameters are set up for such a call.
D FtpFile PR
D RemoteIP 128A
D bPutGet 1N
D LocalFile LikeDS(QualObj)
D LocalMbr 10A
D RemoteFile LikeDS(QualObj)
D RemoteMbr 10A
D bReplace 1N
D RemoteUser 64A
D RemotePWD 64A
D TransferMode 10A
D ftpSrcFile LikeDS(QualObj)
D ftpSrcMbr 10A
D ftplogFile LikeDS(QualObj)
D ftplogMbr 10A
D bFtpDspLog 1N
D LCLSTMF 640A Varying
D RMTSTMF 640A Varying
D FTPFILE PI
D RemoteIP 128A
D bPutGet 1N
D LocalFile LikeDS(QualObj)
D LocalMbr 10A
D RemoteFile LikeDS(QualObj)
D RemoteMbr 10A
D bReplace 1N
D RemoteUser 64A
D RemotePWD 64A
D TransferMode 10A
D ftpSrcFile LikeDS(QualObj)
D ftpSrcMbr 10A
D ftplogFile LikeDS(QualObj)
D ftplogMbr 10A
D bFtpDspLog 1N
D LCLSTMF 640A Varying
D RMTSTMF 640A Varying
** This /INCLUDEs (or /COPYs) are required.
** If you do not have QSYSINC library installed
** on your system, the program will not compile.
** QSYSINC is a free library from IBM included
** with your OS/400 installation.
** Also, even though SEU does not recognize /INCLUDE
** directives, they will compile on OS/400 V4.5 and later.
** WARNING: On v7.1 the QSYSINC QUSRMBRD and other RPG source code members
** are coded incorrectly. You will need to copy those members
** to your own library and include your modified versions.
** The latest cum package seems to correct this issue, however.
/INCLUDE QSYSINC/QRPGLESRC,QUSRMBRD
/INCLUDE QSYSINC/QRPGLESRC,QUSROBJD
/INCLUDE QSYSINC/QRPGLESRC,QUSEC
**********************************************************
** Remove Message from Program Queue API
**********************************************************
D QmhRmvPM PR ExtPgm('QMHRMVPM')
D CallStackEntry 64A Const OPTIONS(*VARSIZE)
D CallStackCount 10I 0 Const
D MsgKey 4A Const
D MsgToRemove 10A Const
D apiErrorDS LikeDS(QUSEC)
** Retrieve member description
D QRtvMbrD PR ExtPgm('QUSRMBRD')
D szRecvBuffer 32766A Options(*VARSIZE)
D nLenRecvBuf 10I 0 Const
D Format 8A Const
D FileName 20A Const
D MbrName 10A Const
D bOvrProc 1A Const
D apierror LikeDS(QUSEC) OPTIONS(*NOPASS)
D bFindMbr 1A Const OPTIONS(*NOPASS)
** The OS/400 QUSROBJD API is used to get the library
** name for an unqualified object. For example:
** *LIBL/MYOBJ could be returned with QGPL as the
** name of the library containing the object.
D QRtvObjD PR ExtPgm('QUSROBJD')
D rtnData 32766A OPTIONS(*VARSIZE)
D nRtnDataLen 10I 0 Const
D Format 8A Const
D QualObj 20A Const
D ObjType 10A Const
D apierror LikeDS(QUSEC)
** The C runtime function is used to run CL commands.
** We use it in tihsh program to run FTP "commands".
D system PR 10I 0 extProc('system')
D szCmd * Value OPTIONS(*STRING)
D Qp0zLprintf PR 10I 0 extProc('Qp0zLprintf')
D szOutputString...
D * Value OPTIONS(*STRING)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
** JobLog() is a wrapper for the Qp0zLprintf() Unix-API.
D JobLog PR
D szMsg 4096A Const VARYING
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D * Value OPTIONS(*STRING:*NOPASS)
D runCLCmd PR
D szCmd 4096A Const VARYING
** If we're using V5.1 or later, then declare the
** data structures used by the APIs as Qualified
** data structures based on data structure templates.
** Otherwise, use the LIKE keyword to create
** large field names that are moved back and forth
** between the QSYSINC DS and the fields.
D mbrDesc DS LikeDS(QUSM0100) Inz
D objDesc DS LikeDS(QUSD0200) Inz
D APIError DS LikeDS(QUSEC) Inz
D ext S 10A
D PSDS SDS Qualified
D JobName 10A Overlay(PSDS:244)
D USRPRF 10A Overlay(PSDS:254)
D JobNbr 6A Overlay(PSDS:264)
** Defaults and Constants
D DFTFTPSrc C Const('QTEMP/QFTPSRC')
D DFTFTPSrcMbr C Const('*')
D APPEND C Const('APPEND ')
D REPLACE C Const(' (Replace ')
D GENERICMBR C Const('GENERIC')
D ftpPutGet S 10A Varying INZ(PUT)
D bIFS S 1N Inz(*OFF)
D bPUT C Const(*OFF)
D bGET C Const(*ON)
D PUT C Const('PUT ')
D GET C Const('GET ')
D true C Const(*ON)
D false C Const(*OFF)
D szFTPSrc S 21A Inz(dftFTPSRC)
D szFTPMbr S 10A
D szFTPLog S 21A Inz('QTEMP/QFTPLOG')
D bCrtLog S 1N Inz(*OFF)
D bDspLog S 1N Inz(*OFF)
D bAppend S 1N Inz(*OFF)
D szReplace S 12A Varying
D bGeneric S 1N Inz(*OFF)
D QualObj DS Based(null_T) Qualified
D obj 10A
D lib 10A
D object 10A Overlay(obj)
D file 10A Overlay(obj)
D name 10A Overlay(obj)
D program 10A Overlay(obj)
D library 10A Overlay(lib)
D QualFLM DS Based(null_T) Qualified
D file 10A
D lib 10A
D mbr 10A
D name 10A Overlay(file)
D obj 10A Overlay(file)
D object 10A Overlay(file)
D library 10A Overlay(lib)
D member 10A Overlay(mbr)
** Local OS/400 library/file/member name
D Lcl DS LikeDS(qualFLM)
** Remote OS/400 library/file/member name
D Rmt DS LikeDS(QualFLM)
** Remote IP or domain name, user ID and password
** (remote_Location)
D RmtLoc DS Qualified
D IP 128A
D User 64A
D PWD 64A
** FTP Script Source file, library and member name.
D script DS LikeDS(qualFLM)
** FTP logging source file, library and member name.
D Log DS LikeDS(qualFLM)
** Transfer mode BINARY | ASCII
D tfrMode S 10A Inz('BINARY')
** Long variables to hold CL and FTP command strings.
D szLogFile S 128A Varying
D fileParm1 S 128A Varying
D fileParm2 S 128A Varying
D szLclDir S 640A Varying
D szRmtDir S 640A Varying
D szLclFile S 640A Varying
D szRmtFile S 640A Varying
D szCrtSrc S 512A Varying
D szOvrDbf S 512A Varying
D ftpCmd S 256A Varying
** 8 "digit" date in character format
D YYMD S 8A
** RPGIV-version of "UDATE"; a true date data-type
** initialized to "today" (the system date).
D today S D Inz(*SYS) DATFMT(*ISO)
// Remove "Buffer Overflow" msg when opening Source files
// These can be annoying to the end-user.
D callStkE s 32A
D callStkCnt s 10I 0
D msgKey s 4A
D msgToRmv s 10A
D msgAPIErr s Inz(*ALLX'00') LIKE(QUSEC)
// End Remove "Buffer Overflow" msg
C eval *INLR = *ON
/free
if (%Parms >= 1);
rmtLoc.IP = RemoteIP;
endif;
if (%Parms() >= 2);
if (bPutGet = bPUT);
ftpPutGet = PUT;
else;
ftpPutGet = GET;
ENDIF;
ENDIF;
if (%Parms() >= 16);
if (lclStmf <> '' and lclStmf <> '*NONE' and
%len(lclStmf) > 1);
szLclFile = lclStmf;
bIFS = true;
endif;
endif;
if (%Parms() >= 17);
if (rmtStmf <> '' and rmtStmf <> '*NONE' and
%len(rmtStmf) > 1);
szRmtFile = rmtStmf;
bIFS = true;
endif;
endif;
if (NOT bIFS);
if %Parms >= 3;
Lcl.File = LocalFile.File;
Lcl.Lib = LocalFile.Lib;
endif;
if %Parms >= 4;
lcl.Mbr = LocalMbr;
endif;
if %Parms >= 5;
rmt.File = RemoteFile.File;
rmt.Lib = RemoteFile.Lib;
endif;
if %Parms >= 6;
rmt.Mbr = RemoteMbr;
endif;
endif;
//* Replace(*YES|*NO)
if %Parms >= 7;
bAppend = NOT bReplace;
endif;
if %Parms >= 8;
rmtLoc.User = remoteUser;
endif;
if (rmtLoc.user = '*CURRENT' or rmtLoc.User = '');
rmtLoc.User = psds.USRPRF;
ENDIF;
if %Parms >= 9;
if %subst(RemotePWD:1:3) = '*US';
rmtLoc.PWD = RmtLoc.User;
else;
rmtLoc.PWD = RemotePwd;
endif;
endif;
if %Parms >= 10;
if (transferMode = 'AUTO');
tfrMode = '';
else;
tfrMode = transferMode;
endif;
endif;
// Build qualified FTP Script Source file and library name
if %Parms >= 11;
script.name = ftpSrcfile.name;
script.lib = ftpSrcfile.lib;
szFTPSrc = %TrimR(script.Lib)
+ '/' +
%TrimR(script.file);
endif;
if %Parms >= 12;
script.Mbr = ftpSrcMbr;
szFtpMbr = ftpSrcMbr;
endif;
// FTP log file and library name
if %Parms >= 13;
if ftpLogFile.name = *BLANKS
or ftpLogFile.name = '*NONE';
bCrtLog = *OFF;
else;
bCrtLog = *ON;
endif;
//* If FTPLOG(*SRCFILE | *SCRIPT) is specified, then use the same
//* file and library name as the script file, otherwise
//* use the specific FTPLOGFILE value
if %subst(ftpLogFile:1:4) = '*SRC' or
%subst(ftpLogFile:1:4) = '*SCR';
Log.name = Script.name;
Log.lib = Script.lib;
else;
Log.name = ftpLogFile.name;
Log.Lib = ftplogFile.Lib;
endif;
szFTPLog = %TrimR(Log.lib)
+ '/' +
%TrimR(Log.file);
endif;
if (%Parms >= 14);
Log.Mbr = ftpLogMbr;
endif;
// Display FTP log after FTP Send finishes?
// NOTE: DSPLOG(*STDIO) causes the internal FTP
// standard output log to be displayed.
if %Parms >= 15;
if bFtpDspLog = *OFF
or ftpLogFile.name = '*NONE'
or ftpLogFile.name = *BLANKS
or ftpLogFile.name = '*STDOUT';
bDspLog = *OFF;
else;
bDspLog = *ON;
endif;
endif;
if (NOT bIFS);
// If no member name is specified, use the
// send file's name as the member name.
if (lcl.Mbr = '*LCLFILE' or lcl.Mbr = '*FILE' or
lcl.Mbr = *Blanks);
lcl.Mbr = lcl.File;
endif;
if lcl.Mbr = '*RMTFILE';
lcl.Mbr = rmt.File;
endif;
if lcl.Mbr = '*RMTMBR';
lcl.Mbr = rmt.Mbr;
endif;
// If the member name is *ALL, then we use
// the plain asterisk by itself as the trailing character.
if lcl.Mbr = '*ALL';
lcl.Mbr = '*';
endif;
clear mbrDesc;
clear apiError;
if (lcl.Mbr = '*FIRST'
or lcl.Mbr = '*LAST'
or tfrMode = 'AUTO' or tfrMode = '');
clear mbrDesc;
clear apiError;
apiError.QUSBPRV = %size(ApiError);
//* Get the member description, and hence, the real member name.
//* (i.e., convert *LAST or *FIRST into a real member name).
QRtvMbrD(mbrDesc:%size(mbrDesc):
'MBRD0100': lcl : lcl.Mbr :
'0': ApiError);
if (tfrMode = 'AUTO' or tfrMode = '');
if (mbrDesc.QUSSFIL00= '1');
tfrMode = 'ASCII';
else;
tfrMode = 'BINARY';
endif;
endif;
// Everything go okay?
// then extract the real member name.
if apiError.QUSBAVL = 0;
lcl.Mbr = MbrDesc.QUSMN02;
elseif (%subst(lcl.mbr:1:1) = '*');
//* If the RTVMBRD failed, use the file name as the member name.
lcl.Mbr = lcl.File;
endif;
endif;
// If *LIBL or blanks is used for the library name,
// on the Local File, then use QUSROBJD to find the real
// library name.
clear objDesc;
clear apiError;
apiError.QUSBPRV = %size(apiError);
// Call QUSROBJD to get the library name of the file being sent.
QrtvObjD(objDesc : %size(objDesc) : 'OBJD0200' :
lcl : '*FILE': apiError);
if (apiError.QUSBAVL = 0);
if (objDesc.QUSOBJT01 = '*FILE');
if (objDesc.QUSEOA05 = 'SAVF');
ext = 'SAVF';
else;
ext = 'FILE';
endif;
else;
ext = %subst(objDesc.QUSOBJT01:2);
endif;
if (lcl.Lib = *BLANKS or %subst(lcl.Lib:1:1) = '*');
lcl.Lib = %TrimR(objDesc.QUSOBJLN00);
endif;
endif;
//* FIX: Moved RMTFILE(*LCLFILE) logic to after *LIBL translation.
//* If TOFILE(*LCLFILE) is specified, copy the file name.
//* If the TOFILE's library is blank or *LIBL (expected)
//* then also copy the FROMFILE's library name to the
//* TOFILE's library name.
if (%subst(Rmt.File:1:4) = '*LCL');
rmt.File = Lcl.File;
endif;
//* NOTE: Can't use *LIBL or *CURLIB for the
//* remote file's library name.
if (rmt.Lib = *BLANKS)
or (%subst(Rmt.Lib:1:1) = '*');
rmt.Lib = Lcl.Lib;
endif;
//* If no remote member name is specified, use the file name.
//* NOTE: We can't use *FIRST or *LAST for the remote
//* file since we can't run QUSRMBRD over that file.
if (rmt.Mbr = '*LCLFILE');
rmt.Mbr = lcl.File;
endif;
if (rmt.Mbr = '*RMTFILE' or rmt.Mbr = '*FILE');
rmt.Mbr = rmt.File;
endif;
if (rmt.Mbr = '*LCLMBR' or rmt.Mbr = *Blanks);
rmt.Mbr = lcl.mbr;
endif;
// If the member name is *ALL, then we use
// the plain asterisk by itself as the trailing character.
if rmt.Mbr = '*ALL';
rmt.Mbr = '*';
endif;
// Build the FTP string containing the lib/file/mbr to send.
if (ext = 'FILE' or ext = *BLANKS);
szLclFile = '/qsys.lib' +
'/' + %TrimR(lcl.Lib) + '.lib' +
'/' + %TrimR(lcl.File) + '.file' +
'/' + %TrimR(lcl.Mbr) + '.mbr';
else;
szLclFile = '/qsys.lib' +
'/' + %TrimR(lcl.Lib) + '.lib' +
'/' + %TrimR(lcl.File) + '.' + ext;
endif;
szLclDir = '/qsys.lib' +
'/' + %TrimR(lcl.Lib) + '.lib' ;
if (ext = 'FILE');
szRmtDir = '/qsys.lib' +
'/' + %TrimR(rmt.Lib) + '.lib' +
'/' + %TrimR(rmt.Obj) + '.' + ext;
else;
szRmtDir = '/qsys.lib' +
'/' + %TrimR(rmt.Lib) + '.lib';
endif;
//* Build the remote file name
//* If a generic name, such as AP* or *ALL, such as * is
//* passed in, use the generic member name as the local name.
//* Then we also have to do a CD (change directory) on the
//* remote system to send the generic members.
if %scan('*':lcl.Mbr) > 0;
lcl.Mbr = GENERICMBR; // Used for debug purposes only
bGeneric = *ON;
else;
bGeneric = *OFF;
endif;
if ((NOT bGeneric) or (bPutGet = bGet));
// Regular member name?
if (ext = 'FILE');
szRmtFile = '/qsys.lib' +
'/' + %TrimR(Rmt.Lib) + '.lib' +
'/' + %TrimR(Rmt.File) + '.file' +
'/' + %TrimR(Rmt.Mbr) + '.mbr';
else;
szRmtFile = '/qsys.lib' +
'/' + %TrimR(Rmt.Lib) + '.lib' +
'/' + %TrimR(Rmt.File) + '.' + ext;
endif;
else;
szRmtFile = '/qsys.lib' +
'/' + %TrimR(Rmt.Lib) + '.lib' +
'/' + %TrimR(Rmt.File) + '.' + ext ;
endif;
//* Translate special member identifiers to the actual mbr name.
endif;
// Script source member
if script.mbr = '*LCLMBR';
if (bIFS);
script.mbr = '*GEN';
else;
script.mbr = Lcl.Mbr;
szFTPMbr = lcl.mbr;
endif;
endif;
//* Log member
if (Log.Mbr = '*LCLMBR');
if (bIFS);
log.mbr = '*GEN';
else;
log.Mbr = Lcl.Mbr;
endif;
endif;
// endif;
//* If the caller specified SRCMBR(*GEN) then create
//* a source member name based on today's date.
if (script.mbr = '*GEN' or script.mbr = '' ) or
(%subst(script.mbr:1:1)='*' and bIFS);
//* The member named is: FSyyyymmdd
script.mbr = 'FS' + %char(%date():*ISO0);
endif;
szFtpMbr = script.Mbr; // (fixes a bug in compiler)
//* If the caller specified LOGMBR(*GEN) then create
//* a source member name based on today's date.
if (Log.mbr = '*GEN' or Log.mbr = '') or
(%subst(Log.mbr:1:1)='*' and bIFS);
//* The member named is: FLyyyymmdd
log.mbr = 'FL' + %char(%date():*ISO0);
endif;
// Create the FTP Script Source File Member
szCrtSrc = 'CRTSRCPF FILE(' + %TrimR(script.lib) + '/' +
%TrimR(script.file) + ') ' +
' RCDLEN(240)';
runclCmd( szCrtSrc );
szCrtSrc = 'ADDPFM FILE(' + %TrimR(script.lib) + '/' +
%TrimR(script.file) + ') ' +
' MBR(' + %TrimR(script.Mbr) + ') ' +
' SRCTYPE(FTPSRIPT)';
runclCmd( szCrtSrc );
szCrtSrc = 'CLRPFM FILE(' + %TrimR(script.lib) + '/' +
%TrimR(script.file) + ') ' +
' MBR(' + %TrimR(script.Mbr) + ') ';
runclCmd( szCrtSrc );
// Create the FTP LOG Source File Member
if (%subst(log.File:1:1) <> '*'); // * or *STDOUT means OUTPUT(*)
// *NONE means don't show the log
szCrtSrc = 'CRTSRCPF FILE(' + %TrimR(log.lib) + '/' +
%TrimR(log.file) + ') ' +
' RCDLEN(240)';
runclCmd( szCrtSrc );
szCrtSrc = 'ADDPFM FILE(' + %TrimR(log.lib) + '/' +
%TrimR(log.file) + ') ' +
' MBR(' + %TrimR(log.Mbr) + ') ' +
' SRCTYPE(FTPLOG)';
runclCmd( szCrtSrc );
szCrtSrc = 'CLRPFM FILE(' + %TrimR(log.lib) + '/' +
%TrimR(log.file) + ') ' +
' MBR(' + %TrimR(log.Mbr) + ') ';
runclCmd( szCrtSrc );
endif;
// Open and build the FTP INPUT Script
Open QFTPSrc;
if NOT %OPEN(QFTPSRC);
Joblog('Source file for FTP script +
failed to open. FTP cancelled.');
return;
endif;
// Remove the "Buffer overflow" message
clear apiError;
apiError.QUSBPRV = %size(ApiError);
QMHRMVPM('*':0:' ':'*NEW':ApiError);
//* User ID & PWD
if %subst(rmtLoc.User:1:4) = '*CUR'
or %subst(rmtLoc.User:1:3) = '*US';
rmtLoc.User = PSDS.USRPRF;
endif;
// If PWD(*USER) is specified, change the PWD
// to the user profile id.
if %Subst(RmtLoc.PWD:1:3) = '*US';
rmtLoc.PWD = rmtLoc.User;
endif;
//* Send the FTP user ID and password to the remote FTP server.
srcdta = %Trim(RmtLoc.User) + ' ' +
%Trim(RmtLoc.PWD);
write FTPSrcRec;
//* Change the transfer mode to BINARY or ASCII.
srcdta = %Trim(TFRMode);
write FtpSrcRec;
//* Change the Name Format to 1.
//* NOTE: This may cause the remote location to send a 501 error,
//* but that's okay.
srcdta = 'NAMEFMT 1';
Write FtpSrcRec;
if (bPutGet = bPut);
fileParm1 = %trimR(szLclFile);
fileParm2 = %trimR(szRmtFile);
else;
fileParm1 = %trimR(szRmtFile);
fileParm2 = %trimR(szLclFile);
endif;
// We do a CD and an LCD to the remote and local directories
srcDta = 'CD ' + %trimR(szRmtDir);
write ftpSrcRec;
srcDta = 'LCD ' + %trimR(szLclDir);
write ftpSrcRec;
if (bReplace and (bPutGet = bGet));
szReplace = REPLACE;
else;
szReplace = '';
endif;
if bGeneric;
joblog('Generic file name detected.');
// Generic/Multi-member MPUT or MGET
srcdta = 'M' + ftpPutGet + ' ' + fileParm1 + ' ' + szReplace;
joblog('cmd: %s': %trimR(srcdta));
Write ftpSrcRec;
// Sending a Single member? Use the PUT or APPEND command.
else;
if (bAppend and (bPutGet = bPut));
srcdta = APPEND + fileParm1 + ' ' + fileParm2;
else;
srcdta = ftpPutGet + fileParm1 + ' ' + fileParm2 + szReplace;
endif;
Write ftpSrcRec;
endif;
// Say goodbye to the FTP server.
srcdta = 'QUIT';
Write ftpSrcRec;
Close QFTPSrc;
//*************************************************************
//* At this point, the FTP script has been created and should be
//* stored in the source file, library and member specified.
//* If debugging, use Debug Shift+F9 to open a command-line
//* and then use SEU or DSPPFM to view/review the FTP script.
//*************************************************************
//*************************************************************
//* Prepare the FTP CL command by overriding the FTP input
//* to the script that we just created.
//*************************************************************
szOvrdbf = 'OVRDBF FILE(INPUT) ' +
'TOFILE(' + %TrimR(script.lib) + '/' +
%TrimR(script.file) + ') ' +
'MBR(' + %TrimR(script.Mbr) + ') ' +
'OVRSCOPE(*JOB)';
runCLCmd( szOvrDBF);
//*************************************************************
//* If an FTP log is requested, override the output to
//* the FTP log file, library and member.
//* NOTE: If LOG(*NONE) is specified, the log is overriden
//* to a dummy file in QTEMP that is not displayed.
//* This is done so that the STDIO log that is
//* normally generated by FTP is not displayed.
//*************************************************************
if ((log.File = '*NONE') or bCrtLOG=*OFF);
szCrtSrc = 'CRTSRCPF FILE(QTEMP/QFTPLOG) RCDLEN(240) ' +
' MBR(NULL)';
runclCmd( szCrtSrc );
szOvrdbf = 'OVRDBF FILE(OUTPUT) ' +
'TOFILE(QTEMP/QFTPLOG) MBR(NULL) ' +
'OVRSCOPE(*JOB) ';
runCLCmd( szOvrDbf);
elseif (%subst(log.File:1:1) <> '*'
and log.File <> *BLANK
and bCrtLog);
szOvrdbf = 'OVRDBF FILE(OUTPUT) ' +
'TOFILE(' + %TrimR(log.lib) + '/' +
%TrimR(log.file) + ') ' +
'MBR(' + %TrimR(log.Mbr) + ') ' +
'OVRSCOPE(*JOB) ';
runCLCmd( szOvrDbf );
endif;
//* Evoke FTP to send the file to the remote
//* location using the FTP script we just created.
ftpCmd = 'FTP ' +
'''' + %TRIM(rmtLoc.IP) + '''';
//* Run the FTP command.
runCLCmd( ftpCmd );
// Now go back and obscure the remote user's password
open(e) QFTPSRC;
if %OPEN(QFTPSRC);
// If the source file length is different from our program,
// we swallow that message so as not to confuse the user.
clear apiError;
apiError.QUSBPRV = %size(ApiError);
QMHRMVPM('*':0:' ':'*NEW':ApiError);
// Obscure the password in the FTP script source member
read(e) FTPSRCREC;
if NOT %Error() and NOT %EOF(QFTPSRC);
srcdta = %Trim(RmtLoc.User) + ' ' + '*****';
update FTPSRCREC;
endif;
endif;
// Delete the FTP I/O overrides
runCLCmd(' DLTOVR FILE(INPUT) LVL(*JOB) ');
runCLCmd(' DLTOVR FILE(OUTPUT) LVL(*JOB) ');
//* If the end-user requested that the FTP log be displayed,
//* and an FTP log outfile was specified, then display it
//* using DSPPFM. You could change this to the IFS-style DSPF command.
if %subst(log.File:1:1) <> '*'
and log.File <> *BLANK;
if (bDspLog);
runCLCmd( 'DSPPFM FILE(' + %TrimR(log.lib) + '/' +
%TrimR(log.file) + ') ' +
' MBR(' + %TrimR(log.Mbr) + ') ' +
' FROMRCD(*END)' );
endif;
endif;
return;
/END-FREE
//*****************************************************
//* Write an impromptu message to the joblog **
//*****************************************************
P JobLog B
D JobLog PI
D szMsg 4096A Const VARYING
D s1 * Value OPTIONS(*STRING:*NOPASS)
D s2 * Value OPTIONS(*STRING:*NOPASS)
D s3 * Value OPTIONS(*STRING:*NOPASS)
D s4 * Value OPTIONS(*STRING:*NOPASS)
D s5 * Value OPTIONS(*STRING:*NOPASS)
D s6 * Value OPTIONS(*STRING:*NOPASS)
D s7 * Value OPTIONS(*STRING:*NOPASS)
D s8 * Value OPTIONS(*STRING:*NOPASS)
D s9 * Value OPTIONS(*STRING:*NOPASS)
/FREE
qp0zLprintf('FTPFILE: ');
Qp0zLprintf(szMsg + X'25':s1:s2:s3:s4:s5:s6:s7:s8:s9);
/END-FREE
P JobLog E
//*****************************************************
//* Run a CL command using C-runtime "system" API **
//*****************************************************
P runCLCmd B
D runCLCmd PI
D szCmd 4096A Const VARYING
/FREE
callp(e) system( %trimR(szCmd) );
return;
/END-FREE
P runCLCmd E
Rev. 23NOV2011
Call Me
Bob Cozzi has been providing the solutions to midrange problems, in the form or articles and books since 1983. He is available for consulting/contract development or on-site RPG IV, SQL, and CGI/Web training. Currently many shops are contracting with Cozzi for 1 to 3 days of Q&A and consulting with their RPG staff. Your staff gets to ask real-world questions that apply to their unique development situations. To contact Cozzi, send an email to: bob at rpgworld.com
You can subscribe to RPG Report (we call it "follow") by visiting the RPG Report page on midrangeNews.com and then click the FOLLOW link in the table of contents for that page. To unsubscribe, simply click that same link. You must be signed up and signed in to midrangeNews.com to start following RPG Report.