Article 4372 of vmsnet.misc:
Path: nntpd.lkg.dec.com!pa.dec.com!news2.digital.com!news1.digital.com!ames!merlin.arc.nasa.gov!RAGOSTA
From: ragosta@merlin.arc.nasa.gov
Newsgroups: vmsnet.misc
Subject: Sorted Directory 1 of 3
Date: 18 Sep 1995 20:22:52 GMT
Organization: Aeroflightdynamics Directorate
Lines: 314
Message-ID: <43kkes$1mj@news.arc.nasa.gov>
Reply-To: ragosta@merlin.arc.nasa.gov
NNTP-Posting-Host: merlin.arc.nasa.gov

c
c   create a foreign command (SDIR :== $SDIR)
c
c   SDIR [qualifiers] [wildcard filespec]
c
c   where qualifiers are:
c      /DESCEND - sort in descending order instead of ascending
c      /SIZE    - sort by size instead of creation date
c
c
      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*
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') D_FLAG = .TRUE.
         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))
c         names(num_files+1) = next_file
         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/,t38,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(max_files), direc(max_files),  size(max_files),  
     $ names(max_files), num_files
      logical direc
      integer size
      integer *8 date
      character *80 names
c
      include '($fabdef)'
      include '($rabdef)'
      include '($xabdef)'
      include '($xabdatdef)'
      include '($xabfhcdef)'
      include '($xabitmdef)'
c
c --- is this comlicated, 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
      record /rabdef/ rab
      record /bigxab/ xabbig
      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
      integer *8 tdate
      integer parts(2)
      equivalence (parts(1),tdate)
c
      fab.fab$b_fac = fab$m_get              ! readonly
c
      xabbig.xab.xab$b_cod = xab$c_dat       ! This is a DATE XAB
      xabbig.xab.xab$b_bln = xab$c_datlen
      xabbig.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)
      xab2.xabb.xab$l_nxt = 0
c
      items(1).itemcode = XAB$_UCHAR_DIRECTORY  ! IS this file a directory?
      items(1).buflen   = 4
      items(1).bufadr   = %loc(is_dir)
      items(1).retlen   = 0
      items(2).itemcode = 0
      items(2).buflen   = 0
c
      fab.fab$l_xab = %loc(xabbig)
c
      my_open = sys$open (fab)
      if (.not. my_open) return
      my_open = sys$connect (rab)
      if (.not. my_open) return
c
      num_files = num_files + 1              ! Success, add the file
      parts(1) = xabbig.xabdat.xab$q_cdt(1)  ! Date is stored in two parts
      parts(2) = xabbig.xabdat.xab$q_cdt(2)
      date(num_files) = tdate
      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
c --- let the OPEN statement know we are ok (Otherwise the ERR= gets
c      executed)
c
      my_open = 1
      return
      end
c
c---end my_open
c


