| Home | Our AS/400 Store | View Our Resumes | Tips | Links | Contact Us |
Display IFS directory. Output to display, printer or file.
filename="Dircmd.txt"
CMD PROMPT('List IFS Directory')
PARM KWD(DIR) TYPE(*PNAME) LEN(256) MIN(1) +
PROMPT('Directory Name')
PARM KWD(OUTPUT) TYPE(*CHAR) LEN(1) RSTD(*YES) +
DFT(*) SPCVAL((*) (*PRINT P) (*OUTFILE +
F)) PROMPT('Output')
PARM KWD(OUTFILE) TYPE(Q1) PMTCTL(OUTFILE) +
PROMPT('File to receive output')
Q1: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) MIN(1)
OUTFILE: PMTCTL CTL(OUTPUT) COND((*EQ F)) NBRTRUE(*EQ 1)
- ------_=_NextPart_000_01BFD74A.04C6AB06
Content-Type: text/plain;
name="DIRrpg.txt"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="DIRrpg.txt"
H DATEDIT(*DMY)
H DftActGrp(*No)
H BndDir( 'QC2LE' )
*---------------------------------------------------------------------
* Module Name : DIR
*
* Description : Display IFS directory. Output to display, printer
* or file.
* Example DIR('home/peter')
*
* Created by : Peter Connell
*
* Date : 26/11/1999
*
*----------------------------------------------------------------*
* CPP for DIR command
*----------------------------------------------------------------*
FQSYSPRT O F 132 PRINTER OFLIND(*INOF) USROPN
*---------------------------------------------------------------------
* Prototype for API procedures
*----------------------------------------------------------------*
Dlstat PR 10I 0 EXTPROC('lstat')
D * VALUE
D * VALUE
Dopendir PR * EXTPROC('opendir')
D * VALUE
Dreaddir PR * EXTPROC('readdir')
D * VALUE
Dclosedir PR 10I 0 EXTPROC('closedir')
D * VALUE
D SndPgmMsg PR N
D Qmsgid 7 CONST
D Qmsgf 20 CONST
D Qmsg 128 CONST
D Qmsgtp 10 CONST OPTIONS(*NOPASS)
*---------------------------------------------------------------------
* Prototypes for retrieving error generated by procedure call
*---------------------------------------------------------------------
D StrErr PR * ExtProc( 'strerror' )
D Err 10I 0 Value
D ErrTxt PR 79
D 1 Options( *Omit )
D GetErr PR * ExtProc( '__errno' )
D 1 Options( *Omit )
*----------------------------------------------------------------*
D*** stat data structure returned by procedure lstat()
D StatDS DS 128
D st_mode 10U 0
D st_ino 10U 0
D st_nlink 5U 0
D reserved1 2A
D st_uid 10U 0
D st_gid 10U 0
D st_size 10U 0
D st_atime 10U 0
D st_mtime 10U 0
D st_ctime 10U 0
D st_dev 10U 0
D st_blksize 10I 0
D st_allocsize 10I 0
D st_objtype 10A
D reserved2 2A
D st_codepage 5U 0
D st_reserved1 62A
D st_ino_gen_id 10U 0
D*** direntry data structure returned by procedure readdir()
D DirEntry DS
D d_reserved1 16A
D d_fileno_genid 10U 0
D d_fileno 10U 0
D d_reclen 10U 0
D d_reserved3 10I 0
D d_reserved4 6A
D d_reserved5 2A
D d_ccsid 10I 0
D d_country_id 2A
D d_language_id 3A
D d_nls_reserved 3A
D d_namelen 10U 0
D d_name 640A
D Null S 1A Inz(X'00')
D ReturnInt S 10I 0
D ReturnDir S *
D PtrToEntry S *
D RtnEntry S BASED(PtrToEntry) Like(DirEntry)
D EntryName S 120A
D EntryPath S 256A
D CmdLine S 512
D CmdLen S 15 5
D HHMMSS S 6 0
D DirError C 'Error occurred when attempting to -
D open directory'
* Input Parameters
D DirName S 100A
D FullName S 256A
D Option S 1A
* Work variables
D OutFile DS
D OutFilNam 10
D OutFilLib 10
D ObjVar S 90
D ObjVarLen S 10I 0 Inz(%size(ObjVar))
D ObjVarFmt S 8
D ObjTyp S 10
D APIERR DS
D ERRSIZ 1 4B 0 INZ(256)
D ERRLEN 5 8B 0 INZ(0)
D ERRMIC 9 15
D ERRNBR 16 16
D ERRDTA 17 272
D PSDS SDS 512
*----------------------------------------------------------------*
C Eval FullName = %trimr(DirName) + Null
* Open directory
C Eval ReturnDir = opendir(%addr(FullName))
* Terminate if error occurred when opening directory
C If ReturnDir = *Null
C Callp SndPgmMsg('CPF9898':'QCPFMSG'
C :ErrTxt(*Omit))
C Eval *inlr = *on
C Return
C Endif
C
* Open file for output
C Open QSYSPRT
C If Option <> 'F'
C Eval *inOF = *on
C Endif
C Dou PtrToEntry = *Null
* Read next directory entry
C Eval PtrToEntry = readdir(ReturnDir)
* Directory entry name is in field d_name
C If PtrToEntry <> *Null
C Eval DirEntry = RtnEntry
C
* Get directory entry name
C Eval EntryName = %str(%addr(d_name))
* Determine object type of entry
C Eval EntryPath = %trim(DirName) + '/'
C + %trimr(EntryName) + Null
C Eval ReturnInt = lstat(%addr(EntryPath)
C : %addr(StatDS))
* Print entry
C Except DirLine
C Endif
C Enddo
* Close directory and printer file
C Eval ReturnInt = closedir(ReturnDir)
C Close QSYSPRT
* Display spool file if requested
C If Option = '*'
C Eval CmdLine = 'DSPSPLF QSYSPRT * *LAST'
C Eval CmdLen = %len(%trim(CmdLine))
C Call 'QCMDEXC' Qcmdexc
* Delete spool file
C Eval CmdLine = 'DLTSPLF QSYSPRT * *LAST'
C Eval CmdLen = %len(%trim(CmdLine))
C Call 'QCMDEXC' Qcmdexc
C Endif
C Eval *inlr = *on
*----------------------------------------------------------------*
C *Inzsr Begsr
C *Entry Plist
C Parm DirName
C Parm Option
C Parm OutFile
C Qcmdexc Plist
C Parm CmdLine
C Parm CmdLen
C TIME HHMMSS
* OUTPUT(*OUTFILE)
C If Option = 'F'
* Check if outfile exists
C Call 'QUSROBJD'
C Parm ObjVar
C Parm ObjVarLen
C Parm 'OBJD0100' ObjVarFmt
C Parm OutFile
C Parm '*FILE' ObjTyp
C Parm APIERR
* Error if library does not exist
C If ERRMIC = 'CPF9810'
C Callp SndPgmMsg('CPF9810':'QCPFMSG'
C :OutFilLib:'*ESCAPE')
C Endif
* Create outfile if necessary
C If ERRMIC = 'CPF9812'
C Eval CmdLine = 'CRTPF FILE('
C + %trimr(OutFilLib) + '/'
C + %trimr(OutFilNam) + ')'
C + ' RCDLEN(132)'
C Eval CmdLen = %len(%trim(CmdLine))
C Call 'QCMDEXC' Qcmdexc
C Else
* Clear outfile
C Eval CmdLine = 'CLRPFM FILE('
C + %trimr(OutFilLib) + '/'
C + %trimr(OutFilNam) + ')'
C Eval CmdLen = %len(%trim(CmdLine))
C Call 'QCMDEXC' Qcmdexc
C Endif
C Eval CmdLine = 'OVRPRTF QSYSPRT TOFILE('
C + %trimr(OutFilLib) + '/'
C + %trimr(OutFilNam) + ')'
C + ' CTLCHAR(*NONE)'
C Eval CmdLen = %len(%trim(CmdLine))
C Call 'QCMDEXC' Qcmdexc
C Endif
C Endsr
*----------------------------------------------------------------*
OQSYSPRT H OF 1 03
O *Date Y 59
O HHMMSS 68 ' : : '
O 73 'Page'
O Page Z 78
O H OF 2 03
O 19 'Directory List for'
O DirName 120
OQSYSPRT EF DirLine
O st_objtype 10
O EntryName 132
*----------------------------------------------------------------*
* Send pgm message
*----------------------------------------------------------------*
P SndPgmMsg B
D PI N
D Msgid 7 CONST
D Msgf 20 CONST
D Msgdta 128 CONST
D Msgtp 10 CONST OPTIONS(*NOPASS)
* Work variables
D Qmsgid S 7
D Qmsgf S 20
D Qmsgdta S 128
D Qmsgln S 10I 0
D Qmsgtp S 10
D Qmsgq S 10
D Qmsgqn S 10I 0 INZ(3)
D Qmsgky S 4
D Qmsger S 15
* Insert default for library if msg file library is blank
C Eval Qmsgid = Msgid
C Eval Qmsgf = Msgf
C Eval Qmsgdta = Msgdta
C If %subst(Qmsgf:11:10) = *blank
C Eval %subst(Qmsgf:11:10) = '*LIBL'
C Endif
C Eval Qmsgln = %len(%trim(Qmsgdta))
C Eval Qmsgq = '*'
C Eval Qmsgtp = '*DIAG'
C If %parms > 3
C Eval Qmsgtp = Msgtp
C Endif
C If Qmsgtp = '*STATUS'
C Eval Qmsgq = '*EXT'
C Endif
C Call 'QMHSNDPM' 99
C Parm Qmsgid Msg ID
C Parm Qmsgf Msg file
C Parm Qmsgdta Msg text
C Parm Qmsgln Msg length
C Parm Qmsgtp Msg type
C Parm Qmsgq Pgm queue
C Parm Qmsgqn Pgm lvl
C Parm Qmsgky Msg key
C Parm *LOVAL Qmsger Error field
C Return *on
P E
*----------------------------------------------------------------*
* Return the previous API function's error in text format
P ErrTxt B Export
D ErrTxt PI 79
D DummyParm 1 Options( *Omit )
* Local variable(s)
D ErrNo S 10I 0 Based( ErrNoPtr )
D RetChr S 79
D Chr300 S 300 Based( Chr300Ptr )
C Eval ErrNoPtr = GetErr( *Omit )
C Eval Chr300Ptr = StrErr( ErrNo )
C Eval RetChr = %Str( Chr300Ptr )
C Return RetChr
P ErrTxt E
| Home | Our AS/400 Store | View Our Resumes | Tips | Links | Contact Us |
Tips and Techniques accumulated by Thomas Bishop from various sources including, but not limited to, Midrange-L, RPG-L, Midrange Computing, and News/400.
|