[Info-vax] DIR/DATE_FORMAT=DELTA ?
Phillip Helbig---undress to reply
helbig at astro.multiCLOTHESvax.de
Mon Jan 9 18:08:59 EST 2012
In article <O4qdnWBMKtI51JbSnZ2dnUVZ_tOdnZ2d at earthlink.com>, "John
Reagan" <johnrreagan at earthlink.net> writes:
> DIRECTORY doesn't offer much in the way of what field to sort on. Things
> like /SELECT=SIZE and /SELECT=VERSION don't sort, only select. Just like
> /BEFORE and /SINCE don't sort, only select.
Note sure how relevant this is here, but I picked up the code below
somewhere a long time ago.
PROGRAM SDIR
C*
C* *******************************
C* *******************************
C* ** **
C* ** SDIR **
C* ** **
C* *******************************
C* *******************************
C*
C* AUTHOR :
C* Arthur E. Ragosta
C* RAGOSTA at 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
More information about the Info-vax
mailing list