C_Title CDDIR obtains directories of CDROM disk -- VMS (non-TAE) version C C_VARS include '($syssrvnam)' !FORTRAN system service definitions include '($iodef)' !FORTRAN I/O definitions include '($ssdef)' !FORTRAN system service code defns C C include TAE information C CTAE INCLUDE 'TAE$INC:PGMINC.FIN/NOLIST' CTAE COMMON /TAEBLK/ BLOCK CTAE INTEGER BLOCK(XPRDIM) C C_DESC This program lists the directories on a CDROM disk. It will list C file name, extension, version number, file size, date and whether C the file is data file or directory file for each file in the C user specified directory(ies). If the user does not specify C either the device or directory, the program tries to obtain the C appropriate default from the logical name PIC$CDROM if it exists. C If not provided by PIC$CDROM, the device defaults to DUB0: and C the directory to the highest level (ROOT) directory. If the C user enters three dots (...) at the end of the directory entry, C the contents of all subdirectories from that point are listed. C C The program has the ability to generate a file of complete file C names. This option is triggered when the EXTENT input ! RMX C parameter is utilized by the user. No header or trailer is C provided in the file. This option is especially useful C when a file of file names needs to be generated for input C to a program which is going to processes many images. C C_USER Input parameters ! RMX v C CHARACTER*50 TO ! The optional output file name. C When a value is entered, the output will be saved C in a new version of the specified file. If no value C is given for this parameter the output is directed C to the the user's terminal. C CHARACTER*8 EXTENT !This option triggers CDDIR to create only a file of C file names which end with the given extension name. C For example EXTENT=IMQ will list only those files C which have an extension of IMQ. This option is useful C when creating a file of file names which will act as C input to a program which needs to process many images. C CHARACTER*50 FROM ! Directory spec: ddun:[directory.sub direc...]. C The device and directory defaults are DUB0: and C the "ROOT" directory. Directories are specified C as main directory (as listed in "ROOT" directory) C any subdirectories; e.g. [dir.subd1.subd2]. Using C '...' causes the current subdirectory and any C subdirectories to be listed; e.g. [...] lists all C directories on the disk; while [dir.s1dir...] lists C the dir.s1dir directory and all those below it.!RMX ^ C_KEYS CDROM ! RMX C C_HIST 2Apr87, DMcMacken, ISD, U.S.G.S., Flagstaff, Original Version C 1Jan89 DMcMacken, ISD, Modify for ISO standard C 5Jan89 EEliason, Astrogeology, U.S.G.S., Added extent file capabilities C 12Jan89 RMehlman (RMX) UCLA/IGPP, VMS (non-TAE) version ! RMX C Interactive Fortran input replaces TAE. ! RMX C Program now loops on FROM parameter. ! RMX C C_END C****************************************************************************** c c local variables c character*50 dir_nam !directory name including c device, ddcn:[dir1.dir2...] character*50 dir_up !uppercase copy of dir_nam character*100 dir_lst(4096) !directory list name character*8 extent !list files with a given extension integer*4 ext_len !extension name length character*64 str !hold a string integer*4 str_len integer*2 ldir(4096) !directory name length integer*2 ndir !number of directories character*100 dir_tmp !current directory integer*2 kdir !length of current directory name integer*4 blk_adr(4096) !directory addresses integer*4 blk_sz(10000) !directory sizes integer*4 chan !assigned channel byte ibuf(61440) !I/O buffer byte dbuf(3000) !directory buffer integer*4 log_blk !disk logical block integer*4 blk_len !no bytes to read integer*2 iosb(4) !I/O status block integer*4 status !system call return status character*4 dev !device name integer*4 mrk !string pointer integer*4 mrk2 !string pointer character*31 dir_str1 !subdirectory string 1 character*31 dir_str2 !subdirectory string 2 character*50 direc !directory string integer*4 root_blk !root directory location integer*4 dir_blk !directory location pointer integer*4 root_len !root directory size integer*4 dir_len !directory record length integer*4 dir_sz !directory size integer*4 fid_len !length of file identifier logical*2 found !file found flag logical*2 dir_all !flag to list all subdirectories logical*2 dir_end !end of directory string flag integer*4 nblks !number of blks in file integer*2 year !file date - year integer*2 mon !file date - month integer*2 day !file date - day integer*2 hr !file time - hour integer*2 min !file time - minute integer*2 sec !file time - second integer*2 log_blk_sz !disk logical block size integer*2 blk_fac !disk blocking factor character*1 file_type !file type (directory or file) integer*2 file_flg !file flag byte integer*4 nfiles !number of files in directory integer*4 tblks !total blocks in directory integer*4 gtfiles !grand total files integer*4 gtblks !grand total blocks integer*4 ipr/6/ !sys$out unit INTEGER*4 ITERM/5/ !INTERACTIVE INPUT UNIT ! RMX integer*4 nxt_blk !next logical block to read integer*4 num_sec !number logical sectors in directory integer*4 i_sec !sector index character*50 out_lst !output file integer*4 out_len !length of output file specification integer*2 sdx !standard index - 1 = High Sierra c 2 = ISO c Offsets into buffers for volume and directory c parameters. Correct offsets for High Sierra or c ISO standards are found using sdx (standard index). c integer*2 rb(2) !root block pointer offset integer*2 rl(2) !root directory length offset integer*2 lbs(2) !logical block size offset integer*2 db(2) !directory block pointer offset integer*2 ds(2) !directory size offset integer*2 ff(2) !file flags offset c c default device and directory strings c character*9 cdrom_log !device/directory logical name character*50 default_str !default device/directory string character*4 default_dev !default device character*50 default_dir !default directory integer*4 ierr !error value from subroutine c data rb /183, 159/ data rl /191, 167/ data lbs /137, 129/ data db /3, 3/ data ds /11, 11/ data ff /25, 26/ data cdrom_log /'PIC$CDROM'/ c c determine device and directory defaults c status = lib$sys_trnlog (cdrom_log,, default_str,,,) if (status .ne. SS$_NORMAL) default_str = ' ' mrk = index (default_str, ':') mrk2 = index (default_str, ']') if (mrk .eq. 0) then default_dev = 'DUB0' else default_dev = default_str(:mrk-1) endif if (mrk2 .eq. 0) then default_dir = 'ROOT' else default_dir = default_str(mrk+2:mrk2-1) endif c c c initialize TAE call and obtain the directory specification c CTAE call xzinit (block, xprdim, ipr, xabort, istat) CTAE call xrstr (block, 'FROM', 1, dir_nam, in_len, icount, istat) CTAE call xrstr (block, 'TO', 1, out_lst, out_len, icount, istat) CTAE call xrstr (block, 'EXTENT',1,extent, ext_len, icount, istat) C VMS parameter input WRITE (ITERM, 7000) ! RMX 7000 FORMAT (/'$Enter output specification (default: terminal): ') ! RMX READ (ITERM, 9000, END=10) OUT_LST ! RMX c c parse output string c ier = 6 C if (out_len .eq. 0) then IF (OUT_LST.EQ.' ') THEN ! RMX ipr = 6 open (unit=ipr, file='sys$output',status='new', 1 carriagecontrol='list') else ipr = 1 open (unit=ipr, file=out_lst, status='new', 1 carriagecontrol='list') endif WRITE (ITERM, 7500) ! RMX 7500 FORMAT (/'$Enter extension for file list (default: none)') ! RMX READ (ITERM, 9000, END=10) EXTENT ! RMX C*********************************************************************** C If EXTENT is not blank then construct the file extension string C*********************************************************************** if (extent.ne.' ') then call str$upcase(extent,extent) if (extent(1:1).ne.'.') extent = '.'//extent ext_len = lenosp(extent) end if c C Loop on requests ! RMX 10 CONTINUE ! RMX C write (ITERM, 8000) ! RMX 8000 format (/'$Enter directory specification, or EOF to exit: ') ! RMX read (ITERM, 9000, end=1000) dir_nam ! RMX 9000 format (a) ! RMX c c parse directory name string c call str$upcase (dir_up, dir_nam) mrk = index (dir_up, ':') mrk2 = index (dir_up, ']') if (mrk .ne. 0) then dev = dir_up(1:mrk-1) else dev = default_dev endif if (mrk2 .ne. 0) then direc = dir_up(mrk+2:mrk2-1) else direc = default_dir endif kdir = index (direc, '...') if (kdir .eq. 0) then dir_lst(1) = direc else if (kdir .eq. 1) then dir_lst(1) = 'ROOT' else dir_lst(1) = direc(1:kdir-1) endif ldir(1) = index (dir_lst(1), ' ') - 1 ndir = 1 c c search for directory c chan = 0 sblk = 0 fsize = 0 c c open channel to device c status = sys$assign (dev, chan,,) if (.not. status) then write (ier, 6001) 6001 format (/' %CDDIR-F-NOTASG, could not assign channel to device') call lib$stop (%val(status)) endif c c read volume descriptor block c log_blk = 64 blk_len = 2048 status = sys$qiow (, %val(chan), %val(io$_readlblk), 1 iosb,,, ibuf, %val(blk_len), 2 %val(log_blk),,,) c c determine the standard under which disk was written c call cdstand (ibuf, sdx, ierr) if (ierr .lt. 0) then write (ier, 6000) 6000 format (/ ' %CDDIR-F-NOTSTD, ', 1 'CDROM not written in acceptable standard') call exit endif c c copy needed parameters into variables from buffer c call b2b (ibuf(rb(sdx)), root_blk, 4) call b2b (ibuf(rl(sdx)), root_len, 4) call b2b (ibuf(lbs(sdx)), log_blk_sz, 2) c c search directory tree c starting at root c blk_fac = log_blk_sz/512 log_blk = root_blk*blk_fac blk_len = root_len dir_all = .false. if (direc .eq. 'ROOT') then found = .true. dir_end = .true. else found = .false. dir_end = .false. mrk = 1 endif do while (.not. dir_end) c c determine name of directory we want on this level c mrk = index (direc, '.') if (mrk .eq. 0) then dir_str1 = direc else if (mrk .eq. 1) then dir_all = .true. found = .true. dir_end = .true. else dir_str1 = direc(1:mrk-1) direc = direc(mrk+1:50) endif if (.not. dir_end) then if (mrk .eq. 0) dir_end = .true. found = .false. nxt_blk = log_blk num_sec = (blk_len + 2047)/2048 blk_len = 2048 i_sec = 0 do while (i_sec .lt. num_sec .and. .not. found) i_sec = i_sec + 1 c c read directory block c status = sys$qiow (, %val(chan), 1 %val(io$_readlblk), iosb,,, 2 ibuf, %val(blk_len), 3 %val(nxt_blk),,,) if (.not. status) then write (ier, 6002) 6002 format (/' %CDDIR-F-REDDIR, error reading directory') call lib$stop (%val(status)) endif c c scan directory entries on level c if (i_sec .eq. 1) then mrk2 = ibuf(1) + 1 mrk2 = ibuf(mrk2) + mrk2 else mrk2 = 1 endif dir_str2 = ' ' do while (mrk2 .lt. blk_len .and. 1 ibuf(mrk2) .ne. 0 .and. 2 dir_str1 .ne. dir_str2) c c copy entry to directory buffer c dir_len = ibuf(mrk2) call b2b (ibuf(mrk2), dbuf, dir_len) c c copy needed directory parameters from buffer into variables c call b2b (dbuf(db(sdx)), dir_blk, 4) call b2b (dbuf(ds(sdx)), dir_sz, 4) call b2b (dbuf(ff(sdx)), file_flg, 2) c c construct directory name string from entry c fid_len = dbuf(33) dir_str2 = ' ' call b2b (dbuf(34), %ref(dir_str2), fid_len) c c save pointer in case this is it c point to next directory entry c log_blk = dir_blk*blk_fac mrk2 = mrk2 + dir_len enddo c c set values depending on whether we found it or not c if (dir_str1 .eq. dir_str2) then blk_len = dir_sz found = .true. else found = .false. endif nxt_blk = nxt_blk + 4 enddo endif enddo c c finished search of directories c now list directory (if possible) c if (found) then blk_adr(1) = log_blk blk_sz(1) = blk_len gtfiles = 0 gtblks = 0 idir = 1 do while (idir .le. ndir) log_blk = blk_adr(idir) blk_len = blk_sz(idir) c c open directory c dir_tmp = dir_lst(idir) kdir = ldir(idir) idir = idir + 1 if (extent.eq.' ') then write (ipr, 8002) dev, dir_tmp 8002 format (/' Directory of', x, a, ':[', a, ']'/ 1 5x, 'file', 29x, 'size', 4x, 'date', 6x, 'time', 2 3x, 'type'/) end if c nfiles = 0 tblks = 0 num_sec = (blk_len+2047)/2048 blk_len = 2048 i_sec = 0 do while (i_sec .lt. num_sec) i_sec = i_sec + 1 status = sys$qiow (, %val(chan), %val(io$_readlblk), 1 iosb,,, ibuf, %val(blk_len), 2 %val(log_blk),,,) if (.not. status) then write (ier, 6002) call lib$stop (%val(status)) endif c c list names in directory c if (i_sec .eq. 1) then mrk2 = ibuf(1) + 1 mrk2 = ibuf(mrk2) + mrk2 else mrk2 = 1 endif dir_str2 = ' ' do while (mrk2 .lt. blk_len .and. 1 ibuf(mrk2) .ne. 0) c c copy entry into directory buffer c dir_len = ibuf(mrk2) call b2b (ibuf(mrk2), dbuf, dir_len) c c copy needed parameters from buffer into variables c call b2b (dbuf(db(sdx)), dir_blk, 4) call b2b (dbuf(ds(sdx)), dir_sz, 4) call b2b (dbuf(ff(sdx)), file_flg, 2) c c construct file name string from entry c fid_len = dbuf(33) dir_str2 = ' ' call b2b (dbuf(34), %ref(dir_str2), fid_len) if (btest(file_flg, 1)) then file_type = 'D' if (dir_all) then ndir = ndir + 1 dir_lst(ndir) = 1 dir_tmp(1:kdir)//'.'// 2 dir_str2(1:fid_len) ldir(ndir) = kdir + 1 fid_len + 1 blk_adr(ndir) = dir_blk*blk_fac blk_sz(ndir) = dir_sz endif else file_type = 'F' endif c c write directory entry c nblks = (dir_sz + 511)/512 year = dbuf(19) + 1900 mon = dbuf(20) day = dbuf(21) hr = dbuf(22) min = dbuf(23) sec = dbuf(24) nfiles = nfiles + 1 tblks = tblks + nblks if (extent.eq.' ') then write (ipr, 8001) dir_str2(1:fid_len), 1 nblks, mon, day, year, hr, min, 2 sec, file_type 8001 format (5x, a, t35, i6, i5, '-', i2, '-', 1 i4, i3, ':', i2, ':', i2, 2x, a) else jdir = index(dir_tmp,'ROOT.') + 1 if (jdir.ne.1) jdir = jdir + 4 str='['//dir_tmp(jdir:kdir)//']'// 1 dir_str2(1:fid_len) str_len = 2 + kdir + fid_len if (index(str,extent(1:ext_len)) 1 .ne.0) then if (ipr.eq.6) then write(ipr,8010) str(1:str_len) else write(ipr,8011) str(1:str_len) end if 8010 format(1x,a) 8011 format(a) end if end if c c point to next directory entry c mrk2 = mrk2 + dir_len enddo log_blk = log_blk + 4 enddo gtfiles = gtfiles + nfiles gtblks = gtblks + tblks if (extent.eq.' ') then write (ipr, 8003) tblks, nfiles 8003 format ('0Total of', i8, ' blocks in', i4, ' files.') end if enddo if (extent.eq.' ') then if (dir_all) write (ipr, 8005) gtblks, gtfiles 8005 format (/'0Grand total of', i10, ' blocks in', i5, ' files.') end if else mrk = index (direc, ' ') - 1 write (ier, 6004) dev, direc(:mrk) 6004 format (/' %CDDIR-F-DNF, directory not found' / 1 x, a, ':[', a, ']') endif c GO TO 10 ! GO BACK FOR ANOTHER REQUEST ! RMX c c that's all folks c 1000 continue call exit end