| 
*-------------------------------------------------------------------------
* READ_DIR : lecture d'une directory , avec recherche des
* fichiers suivant un masque recu en paramètre
*-------------------------------------------------------------------------
H datedit( *dmy ) dftactgrp( *no ) bnddir( 'QC2LE' )
H option( *srcstmt : *nodebugio )
*-------------------------------------------------------------------------
* Prototypes pour les APIs IFS
*----------------------------------------------------------------
D errno pr 10i 0
*----------------------------------------------------------------
D strerror pr * ExtProc('strerror')
D errnum 10I 0 value
*-------------------------------------------------------------------------
D lstat pr 10i 0 extproc('lstat')
D * value
D * value
*----------------------------------------------------------------
D opendir pr * extproc('opendir')
D * value
*----------------------------------------------------------------
D readdir pr * extproc('readdir')
D * value
*----------------------------------------------------------------
D closedir pr 10i 0 extproc('closedir')
D * value
*----------------------------------------------------------------
* Prototypes pour les APIs envoi de message
*----------------------------------------------------------------
D sndpgmmsg pr extpgm('QMHSNDPM')
D msgid 7a const
D qualmsff 20a const
D msgdata 65535a const options(*varsize)
D msgdatalen 10i 0 const
D msgtype 10a const
D tocse 65535a const options(*varsize)
D tocsectr 10i 0 const
D msgkey 4a const
D errcode * const
*-------------------------------------------------------------------------
|
|
* DS systeme D pgmsts sds D pgmname *proc *------------------------------------------------------------------------- * Data Structure renvoyee par 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 * Last access time in seconds since Epoch D st_atime 10u 0 * Last change time in seconds since Epoch D st_mtime 10u 0 * Last change status time in seconds since Epoch 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 * Data Structure poste Directory renvoye par 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 * paramètres et autres variables D dirname s 100a D ficname s 32a D ficname2 s like(ficname) D fullname s 256a D option s 1a D pos s 3I 0 * XLATE D minuscule C 'abcdefghijklmnopqrstuvwxyz' D MAJUSCULE C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' D msg s 80a varying D msgkey s 4a D msgid s 7a D dsp s 52a D null s 1a inz(x'00') D entrycount s 10u 0 D returnint s 10i 0 D ptrtodir s * D ptrtoentry s * D rtnentry s based(ptrtoentry) like(direntry) D entryname s 120a D entryname2 s like(entryname) D entrypath s 256a D cmdline s 512 D cmdlen s 15 5 D hhmmss s 6 0 D objvar s 90 D objvarlen s 10i 0 inz(%size(objvar)) D objvarfmt s 8 D objtyp s 10 D epoch s z inz(z'1970-01-01-00.00.00.000000') D dt s z * qualification D outfile ds D outfilnam 10 D outfillib 10 *---------------------------------------------------------------- |
|
* Error Messages D api_error ds D err_size 10i 0 inz( %size( api_error )) D err_length 10i 0 inz(0) D err_id 7a D 1a D err_data 128a *----------------------------------------------------------------- * c'est parti ! *----------------------------------------------------------------- C eval fullname = %trimr( dirname ) + null * Ouvre la directory C eval ptrtodir = opendir( %addr( fullname ) ) C if ptrtodir = *null C eval msgid = 'CPE' + %char( errno ) C eval msg = %trim( %str( strerror( errno ) ) ) + C ' - API opendir()' C exsr sndescmsg C endif * Initialise le nombre d'objets récupérés C eval entrycount = 0 C dou ptrtoentry = *null * Lecture du poste suivant C eval ptrtoentry = readdir( ptrtodir ) * Place le poste renvoye dans la DS DirEntry C if ptrtoentry <> *null C eval direntry = rtnentry * Compte le nombre d'objets récupérés C eval entrycount = entrycount + 1 * Recupere le nom de l'objet C eval entryname = %str( %addr( d_name ) ) * Determine le type de l'objet (STMF, DIR, ...) C eval entrypath = %trim( dirname ) + '/' C + %trimr( entryname ) + null C eval returnint = lstat( %addr( entrypath ) C : %addr( statds ) ) * si prb, envoi de message |
|
C if returnint < 0 C eval msgid = 'CPE' + %char( errno ) C eval msg = %trim( %str( strerror( errno ) ) ) + C ' - API lstat()' C exsr sndescmsg C else * Affiche le nom du poste lu si fichier et commence pareil... C eval dsp = %trim(entryname) + ' ' + st_objtype C if st_objtype = '*STMF' * on ignore la casse C eval entryname2=%xlate(minuscule : MAJUSCULE: C entryname) C if pos < 1 C or (%subst(ficname2: 1 : pos) C = %subst(entryname2 : 1 : pos) C ) C dsply dsp C endif C endif C endif * Date & heure traduits depuis "Epoch" C epoch adddur st_atime:*s dt C endif C enddo * Ferme directory C eval returnint = closedir( ptrtodir ) C if returnint < 0 C eval msgid = 'CPE' + %char( errno ) C eval msg = %trim( %str( strerror( errno ) ) ) + C ' - API closedir()' C exsr sndescmsg C endif C eval *inlr = *on |
|
*----------------------------------------------------------
C *inzsr begsr
C *entry plist
C parm dirname
C parm ficname
* cadrage a gauche
c eval ficname2 = %triml(ficname)
* conversion (ignorer la casse, là aussi)
C eval ficname2 = %xlate(minuscule : MAJUSCULE :
C ficname2)
* recherche caractère joker
C eval pos = %scan('*' : ficname2) - 1
c if pos < 1
* si non, on travaille sur le premier espace
C eval pos = %scan(' ' : ficname2) - 1
c endif
c
C endsr
*------------------------------------------------------------
C sndescmsg begsr
* Envoie un message d'échappement à l'appelant
C callp sndpgmmsg( msgid : 'QCPFMSG QSYS'
C : msg : %len(msg)
C : '*ESCAPE' : '*'
C : 4 : msgkey
C : *null )
C endsr
* -----------------------------------------------------------
* Procedure d'erreur errno pour APIs type Unix
* -----------------------------------------------------------
P errno b
D errno pi 10i 0
D syserrno pr * extproc('__errno')
D p_errno s *
D retval s 10i 0 based(p_errno)
C eval p_errno = syserrno
C return retval
P e
|
