From: helbig@astro.rug.nl Sent: Tuesday, May 02, 2000 1:14 PM To: Info-VAX@Mvb.Saic.Com Subject: RE: wish list: DIRECTORY limitation In article <1137A4A23A51D311B2D600105A1D5213019AEDD6@seantexch.unitedad.com>, Terry Marosites writes: > If you're going to have a wish list for the DIRECTORY verb why not add on my > wish. Have an /orderby . So that I can do a Dir /orderby=date=create or Dir > /orderby=date=backup or dir /orderby=type or dir /orderby. I guess there are > a lot if wish commands that we could wish for. Hmmm maybe some could > actually come true. Got this somewhere, sometime.... PROGRAM SDIR C* C* ******************************* C* ******************************* C* ** ** C* ** SDIR ** C* ** ** C* ******************************* C* ******************************* C* C* AUTHOR : C* Arthur E. Ragosta C* RAGOSTA@MERLIN.ARC.NASA.GOV C* C* MS 219-1 C* NASA Ames Research Center C* Moffett Field, Ca. 94035-1000 C* (415) 604-5558 C* C* DESCRIPTION : C* SORTED DIRECTORY C* PRODUCE A SIMPLE DIRECTORY LISTING SORTED BY DATE or SIZE C* C* /DESCENDING = OLDEST DATES FIRST, ELSE NEWEST FIRST C* /SIZE = sort by size instead of date C* C* SUBPROGRAM REFERENCES : C* C* ASSUMPTIONS AND RESTRICTIONS : C* NOT TRANSPORTABLE. C* DIRECTORY TRUNCATED AT 'max_files' FILE NAMES. C* C* LANGUAGE AND COMPILER : C* ANSI FORTRAN 77 C* C* CHANGE HISTORY : C* 22 MAR 1993 - INITIAL VERSION C* 14 SEP 1995 - Converted to alpha C* 30 OCT 1995 - Bug fixed in USEROPEN C* C*********************************************************************** C* PARAMETER (MAX_FILES=1000) common /data/ $ date(max_files), direc(max_files), size(max_files), $ names(max_files), num_files logical direc integer size integer *8 date character *80 names c integer indx(max_files) c CHARACTER *127 P(2), PATH, next_file CHARACTER *20 Q(2) character *23 adate CHARACTER *4 ON, OFF LOGICAL D_FLAG, S_FLAG external my_open C ON = CHAR(27) // '[1m' ! Bold on OFF = CHAR(27) // '[0m' ! Bold off D_FLAG = .FALSE. S_FLAG = .FALSE. CALL GETFOR (NQ, Q, NP, P) DO 1 I = 1, NQ IF (Q(I)(1:1) .EQ. 'D') THEN ! Just in case he said /DATE IF ((LENGTH(Q(I)) .LE. 1) .OR. (Q(I)(2:2) .NE. 'A')) $ D_FLAG = .TRUE. ENDIF IF (Q(I)(1:1) .EQ. 'S') S_FLAG = .TRUE. 1 CONTINUE C C --- Defaults to current directory C IF (NP .EQ. 0) THEN CALL DEFAULT ( PATH ) ELSE PATH = P(1) ENDIF CALL PARSE ( PATH, '*.*;*', 'FULL', PATH ) num_files = 0 c c --- loop over wildcards for each file; "MYOPEN" does all the work c 10 call getfile ( path, next_file ) if (next_file .ne. ' ') then call parse (next_file, ' ', 'LO', names(num_files+1)) OPEN (UNIT=0, FILE=next_file(1:length(next_file)), $ STATUS='OLD', ERR=10, useropen=my_open) 30 close(unit=0) if (num_files .le. max_files) go to 10 endif C C --- sort file list by date or size C IF (S_FLAG) THEN call isorti (size, num_files, indx) ! by File SIZE !!! ELSE call isorti8 (date, num_files, indx) ! by DATES !!! ENDIF C C --- In descending order ? C IF (D_FLAG) THEN ISTART = NUM_FILES IEND = 1 INCR = -1 ELSE ISTART = 1 IEND = NUM_FILES INCR = 1 ENDIF C C -- Note that directory files are bolded on output c DO 100 I = ISTART, IEND, INCR ln = length(names(indx(i))) c c ----- Sorted by size c if (s_flag) then if (direc(indx(i))) then if (ln .le. 30) then write (6,900) on, $ names(indx(i))(1:ln), off, size(i) else write (6,901) on, $ names(indx(i))(1:ln), off, size(i) endif else if (ln .le. 30) then write (6,910) names(indx(i))(1:ln), size(i) else write (6,911) names(indx(i))(1:ln), size(i) endif endif c c ----- Sorted by date c else call sys$asctim ( , adate, date(i) ,) if (direc(indx(i))) then if (ln .le. 30) then write (6,920) on, $ names(indx(i))(1:ln), off, adate(1:17) else write (6,921) on, $ names(indx(i))(1:ln), off, adate(1:17) endif else if (ln .le. 30) then write (6,930) names(indx(i))(1:ln), adate(1:17) else write (6,931) names(indx(i))(1:ln), adate(1:17) endif endif endif 100 CONTINUE C CALL EXIT 900 format(' ',3a,t38,i5) 901 format(' ',3a/,t38,i5) 910 format(' ',a,t30,i5) 911 format(' ',a/,t30,i5) 920 format(' ',3a,t38,a) 921 format(' ',3a/,t30,a) 930 format(' ',a,t30,a) 931 format(' ',a/,t30,a) END C C---END SDIR C integer function my_open (fab, rab, lun) c* c* This routine is called by the FORTRAN OPEN statement to extract the c* file size, date, and directory flag for each file. c* PARAMETER (MAX_FILES=1000) common /data/ $ date(2,max_files), direc(max_files), size(max_files), $ names(max_files), num_files logical direc integer size integer *4 date ! Fudge to make it easier to move quadword character *80 names c include '($fabdef)' c include '($rabdef)' include '($xabdef)' include '($xabdatdef)' include '($xabfhcdef)' include '($xabitmdef)' c c --- is this complicated, or what? c structure /bigxab/ union map record/xabdef/ xab endmap map record /xabdatdef/ xabdat endmap endunion endstructure c structure /bigxab1/ union map record/xabdef/ xaba endmap map record /xabfhcdef/ xabfhc endmap endunion endstructure c structure /bigxab2/ union map record/xabdef/ xabb endmap map record /xabitmdef/ xabitm endmap endunion endstructure c record /fabdef/ fab c record /rabdef/ rab record /bigxab/ xab0 record /bigxab1/ xab1 record /bigxab2/ xab2 c structure /itmlst/ integer *2 buflen integer *2 itemcode integer *4 bufadr integer *4 retlen end structure record /itmlst/ items(3) c logical is_dir integer sys$open, sys$connect c c --- WARNING !!! The following is not strictly accurate as it should c scan the XAB list and resolve any differences between my XABs c and any passed by the USEROPEN routine, but this was a pain c and (not being a file system expert) I couldn't get it to work c right. This SEEMS to work. c isave = fab.fab$l_xab fab.fab$b_fac = fab$m_get ! readonly fab.fab$l_xab = %loc(xab0) c xab0.xab.xab$b_cod = xab$c_dat ! This is a DATE XAB xab0.xab.xab$b_bln = xab$c_datlen xab0.xab.xab$l_nxt = %loc(xab1) c xab1.xaba.xab$b_cod = xab$c_fhc ! size XAB xab1.xaba.xab$b_bln = xab$c_fhclen xab1.xaba.xab$l_nxt = %loc(xab2) c xab2.xabb.xab$b_cod = xab$c_itm ! Item code XAB xab2.xabb.xab$b_bln = xab$c_itmlen xab2.xabitm.xab$b_mode= xab$k_sensemode xab2.xabitm.xab$l_itemlist = %loc(items) c c --- This SHOULD be set to ISAVE, but when I do that, the OPEN fails. c Also, there is the possibility of a duplicate XAB, which is a pain c to correct. c xab2.xabb.xab$l_nxt = 0 c items(1).buflen = 4 items(1).itemcode = XAB$_UCHAR_DIRECTORY ! Is this file a directory? items(1).bufadr = %loc(is_dir) items(1).retlen = 0 items(2).buflen = 0 items(2).itemcode = 0 my_open = sys$open (fab) ! Just to fill the XABs c c --- Undo the damage done above. c fab.fab$l_xab = isave if (.not. my_open) return c num_files = num_files + 1 ! Success, add the file date(1,num_files) = xab0.xabdat.xab$q_cdt(1) ! Date is stored in date(2,num_files) = xab0.xabdat.xab$q_cdt(2) ! two parts direc(num_files) = is_dir c c --- the calculation for size comes from an example on the DEC c bulletin board c if (xab1.xabfhc.xab$w_ffb .eq. 0) then if (xab1.xabfhc.xab$l_hbk .eq. 0) then size(num_files) = 0 else size(num_files) = xab1.xabfhc.xab$l_ebk - 1 endif else size(num_files) = xab1.xabfhc.xab$l_ebk endif c return end c c---end my_open c