From:	CSBVAX::CSBVAX::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 18-NOV-1988 10:07
To:	MRGATE::"ARISIA::EVERHART"
Subj:	RE: Directory files


Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Wed, 16 NOV 88 21:54:36 PDT
Received: from CUNYVM.CUNY.EDU by KL.SRI.COM with TCP; Wed, 16 Nov 88 21:27:44 PST
Received: from UALR.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.1) with BSMTP id 9601; Thu, 17 Nov 88 00:03:21 EDT
Date: Wed, 16 Nov 88 21:54 CST
From: Dale Miller <DOMILLER%UALR.BITNET@CUNYVM.CUNY.EDU>
Subject: RE: Directory files
To: INFO-VAX@KL.SRI.COM
X-VMS-To: IN%"INFO-VAX@KL.SRI.COM"

Date sent:  16-NOV-1988 21:48:19
> John Gorentz <GORENTZ%MSUKBS.BITNET@CUNYVM.CUNY.EDU> writes:
>
>>  From:         STEVE ROSEMAN <LUSGR@VAX1.CC.LEHIGH.EDU>
>>  Subject:      What is a Directory file? (in DCL),
>>                or how do you delete accounts?
>>
>>      Even though a directory file 'should' have a name of dirname.DIR;1,
>>  it works with dirname.DIR;2, and can even be renamed to dirname.FROG (even
>>  though in that case the files are not available.)  Is there a way from DCL
>>  to determine if a file is in fact a directory file, in order to delete
>>  its files while zapping a closed account?
>
>I don't know about a *good* way, using lexical functions, but DIR/FULL will
>identify directory files as such.
>
>John Gorentz
>

A (not DCL) but comprehensive solution appears below along with a test
case.  I believe it takes into account the major ways one can "fool" DCL.

******************** Test case ********************************************
$create/dir [test]
$create/dir [test.aaa]
$create [test.aaa]bbb
$create [test.aaa]ccc
$rename [test]aaa.dir [test]aaa.not_a_dir
$create/dir [test.xxx]
$create [test.xxx]yyy.dat
$create [test]xxx.dir
$create/dir [test.qqq]
$create [test.qqq]rrr.dat
$create/dir [test.mmm]
$create [test.mmm]nnn.dat
$rename [test]mmm.dir [test]qqq.dir
$dir [test...]

Directory DISK$CS:[TEST]

AAA.NOT_A_DIR;1     QQQ.DIR;2           QQQ.DIR;1           XXX.DIR;2
XXX.DIR;1

Total of 5 files.

Directory DISK$CS:[TEST.QQQ]

RRR.DAT;1

Total of 1 file.

Directory DISK$CS:[TEST.XXX]

YYY.DAT;1

Total of 1 file.

Grand total of 3 directories, 7 files.  ! Note: DCL finds 7 files, there are
                                        ! REALLY 10
$r dales
Input device and directory, please
disk$cs:[000000]test.dir

DISK$CS:[TEST]AAA.NOT_A_DIR;1
DISK$CS:[TEST.AAA]BBB.;1
DISK$CS:[TEST.AAA]CCC.;1
DISK$CS:[TEST]QQQ.DIR;2
DISK$CS:[TEST.QQQ]NNN.DAT;1
DISK$CS:[TEST]QQQ.DIR;1
DISK$CS:[TEST.QQQ]RRR.DAT;1
DISK$CS:[TEST]XXX.DIR;2
DISK$CS:[TEST]XXX.DIR;1
DISK$CS:[TEST.XXX]YYY.DAT;1
No more files
********************* Program follows ***************************************
        program scan_directory
        implicit none

        include '($iodef)'
        include '($fibdef)'
        include '($ssdef)'
        include '($atrdef)'
        include '($dscdef)'
        include '($fscndef)'
        include 'sys$library:fchdef.for'

        character filename*63, resultname*63,root*63
        character fnam*5/'*.*;*'/
        character path*200,disk*32
        byte statbyte(32), ratbyte(32)
        integer*2 chan, iosb(4), resultname_len
        integer*2 statword(16), ratword(16)
        integer*4 uchar,fname_len,istat,colon_pos,i,totalf,plen,dlen,root_len
        equivalence ( statbyte, statword)
        equivalence ( ratbyte, ratword)
        integer*4 sys$assign,sys$qiow,getfid,status,level,compquad
        integer*4 b_offset,e_offset
        logical do_process
        real*8 revdate,yesterday,day_1
        character*23 date_time

        structure /component/
           integer*2  len, icode
           integer*4  adr
        end structure

        record /component/ filescan_list(2)

c to get: IO$_ACCESS, FIB$M_WILD, SS$_NOMOREFILES, ATR$C_STATBLK,
c         ATR$C_RECATTR

        record/atrdef/ acb_list(5)

        record  /fibdef/  fib
        record  /dscdef1/ fib_char
        common  /where/   level
        common  /fibcom/  fib,resultname,resultname_len,disk,dlen,
        1 root,root_len

 1001   format(1x,a)
 1002   format(q,a)
        level=0
        totalf=0
        fib_char.dsc$w_maxstrlen = 64
        fib_char.dsc$b_dtype     = dsc$k_dtype_t
        fib_char.dsc$b_class     = dsc$k_class_s
        fib_char.dsc$a_pointer   = %loc(fib)
        call sys$bintim('1 00:00:00.00',day_1)
        call sys$bintim('-- 00:00:00.00',yesterday)
        call addquad(yesterday,day_1,yesterday)
        call sys$asctim(,date_time,yesterday,,)

c       Read in the device and directory name to scan
        type*,'Input device and directory, please'
        read(*,1002)fname_len,filename
        call str$upcase(filename,filename)

        colon_pos = index( filename, ':')
c       if (colon_pos .eq. 0) go to 10
        dlen = colon_pos - 1
        disk = filename(1:dlen)
        filescan_list(1).icode = fscn$_name
        filescan_list(2).icode = 0
        filescan_list(2).len   = 0
        call sys$filescan(filename,filescan_list,)
        b_offset = filescan_list(1).adr - %loc(filename) + 1
        root_len = filescan_list(1).len
        e_offset = b_offset + root_len - 1
        root = filename(b_offset:e_offset)

C For ACP QIOs you must specify ONLY the DISK DEVICE in the $ASSIGN.
C DO NOT put the directory or filename in the $ASSIGN.
C It is important to have either a colon in the device spec or to be sure
C to send only the exact length of the string.  Trailing blanks will
C result in INVALID DEVICE NAME errors because it attempts to match
C the blanks also.

        istat=sys$assign( filename(1:colon_pos), chan,,)
        if (.not. istat) call lib$stop( %val(istat))

C Search for a file name match on name, type or version

        fib.fib$w_nmctl = fib$m_wild

C Load the Attribute Control Block structure to get information from
C the Record Attributes Area and the Attributes Statistics Block

        acb_list(1).atr$w_size=32
        acb_list(1).atr$w_type=atr$c_statblk
        acb_list(1).atr$l_addr=%loc(statbyte)

        acb_list(2).atr$w_size=32
        acb_list(2).atr$w_type=atr$c_recattr
        acb_list(2).atr$l_addr=%loc(ratbyte)

        acb_list(3).atr$w_size=4
        acb_list(3).atr$w_type=atr$c_uchar
        acb_list(3).atr$l_addr=%loc(uchar)

        acb_list(4).atr$w_size=8
        acb_list(4).atr$w_type=atr$c_revdate
        acb_list(4).atr$l_addr=%loc(revdate)

        acb_list(5).atr$w_size=0
        acb_list(5).atr$w_type=0
        acb_list(5).atr$l_addr=0

c       Call GETFID to return the file id of the DIRECTORY specified
c       and place it into FIB$W_DID(1:3).
c       You can see a file id by doing a DIR/FULL on a file.

        status = getfid( filename(1:fname_len),
        1   fib.fib$w_did)
        if (.not. status) call lib$stop( %val(status))


c       IO$_ACCESS does directory lookup if FIB$W_DID is nonzero and
c       associates the specific file with the disk channel.
c       P2 is required for initiating the search.  A character variable
c       name must be passed, not a literal string.
c       The P3 and P4 parameters are required, they are used with FIB$L_WCC
c       to continue the wildcard search from the last position.

 0150   istat = sys$qiow( , %val(chan), %VAL(io$_access), iosb,,,
        1   fib_char, fnam, resultname_len,
        2   resultname, acb_list,)
        if (.not. istat) call lib$signal(%val(istat))

        if (iosb(1) .eq. (ss$_nomorefiles)) go to 1200
        if (iosb(1) .eq. (ss$_nosuchfile)) go to 1200
        if (.not. iosb(1)) call lib$stop( %val(iosb(1)))

        call makepath(path,plen)
        write(6,1001)path(:plen)

        if((uchar.and.fch$m_directory).ne.0) then
            if(do_process(resultname(1:resultname_len))) then
                call push_context(0)
                end if
        else
c           if(compquad(revdate,yesterday).eq.-1.and.level.ne.0) then
c               call makepath(path,plen)
c               call sys$asctim(,date_time,revdate,,)
c               write(6,1001)path(:plen)
c               totalf=totalf+jzext(statword(4))
c       Delete him!
c               call push_context(1)
c               fib.fib$l_wcc = 0
c               fib.fib$w_nmctl = fib$m_findfid
c               istat = sys$qiow( , %val(chan),
c       1           %val(io$_delete+io$m_delete), iosb,,,
c       1           fib_char,,,,,)
c               if(.not.istat) call lib$signal(%val(istat))
c               if (.not.iosb(1)) call lib$signal( %val(iosb(1)))
c               call pop_context
c               end if
        end if
        go to 150
 1200   if(level.eq.0) then
c           print*,'Total deleted=',totalf
            stop 'No more files'
        else
            call pop_context
            go to 0150
        end if
        end









        subroutine push_context(which)
        implicit none
        include '($fibdef)'
        include '($fscndef)'
        integer*2 length,hold_length(10),hold_directory(3,10)
        integer*4 level,hold_wcc(10),which
        integer*4 dlen,plen,i,b_offset,e_offset,root_len
        character*63 filename,hold_filename(10),root
        character path*200,disk*32

        structure /component/
           integer*2  len, icode
           integer*4  adr
        end structure

        record /component/ filescan_list(2)
        record /fibdef/  fib
        common /where/   level
        common /fibcom/  fib,filename,length,disk,dlen,root,root_len

        level=level+1

        if(level.gt.10) then
            type *,'More than 10 levels ... aborting'
            call lib$stop()
            endif

        hold_length(level)      = length
        hold_filename(level)    = filename
        hold_directory(1,level) = fib.fib$w_did(1)
        hold_directory(2,level) = fib.fib$w_did(2)
        hold_directory(3,level) = fib.fib$w_did(3)
        hold_wcc(level)         = fib.fib$l_wcc
        fib.fib$l_wcc           = 0
        if(which.eq.1) return                           !Don't move FID to DID
        fib.fib$w_did(1)        = fib.fib$w_fid(1)
        fib.fib$w_did(2)        = fib.fib$w_fid(2)
        fib.fib$w_did(3)        = fib.fib$w_fid(3)
        return
c
        entry pop_context
        length           = hold_length(level)
        filename         = hold_filename(level)
        fib.fib$w_did(1) = hold_directory(1,level)
        fib.fib$w_did(2) = hold_directory(2,level)
        fib.fib$w_did(3) = hold_directory(3,level)
        fib.fib$l_wcc    = hold_wcc(level)
        fib.fib$w_nmctl  = fib$m_wild           ! Just in case
        level=level-1
        return

        entry makepath(path,plen)
        filescan_list(1).icode = fscn$_name
        filescan_list(2).icode = 0
        filescan_list(2).len   = 0
        path=disk(1:dlen)//':['//root(1:root_len)//'.'
        call str$trim(path,path,plen)
        if (level.eq.0) then
            path = path(1:plen-1)//']'//filename
            call str$trim(path,path,plen)
        else
            do i = 1, level
                call sys$filescan(hold_filename(i),filescan_list,)
                b_offset = filescan_list(1).adr -
        1           %loc(hold_filename(i)) + 1
                e_offset = b_offset + filescan_list(1).len - 1
                path(plen+1:) = hold_filename(i)(b_offset:e_offset)//'.'
                plen = plen + filescan_list(1).len + 1
                end do
            path(plen:) = ']'//filename(1:length)
            plen = plen + length
        end if
        return
        end









        logical function do_process(filename)
        implicit none
        character*(*) filename
        parameter num_exclusions=1
        character*63 exclname(num_exclusions)
        integer i,level
        common  /where/ level

        exclname(1)='000000.DIR;1'

        do_process=.true.

        if(level.ne.0) return

        do i=1,num_exclusions
            if(filename.eq.exclname(i)) then
                do_process=.false.
                return
                end if
            end do
        return
        end









        integer function getfid(filename,fid)
        implicit none

        include '($fabdef)'
        include '($namdef)'

        record /fabdef/ fab
        record /namdef/ nam
        integer sys$open,sys$close
        character*(*) filename
        integer*2 fid(3)
        integer istat

c       Do the initialization done automatically by MACRO (but not FORTRAN)
        fab.fab$b_bid = fab$c_bid
        fab.fab$b_bln = fab$c_bln
        nam.nam$b_bid = nam$c_bid
        nam.nam$b_bln = nam$c_bln

c       Now, my parameters
        fab.fab$l_nam = %loc(nam)
        fab.fab$l_fna = %loc(filename)
        fab.fab$b_fns = len(filename)

        getfid = sys$open(fab)
        if(.not.getfid) return
        fid(1) = nam.nam$w_fid_num
        fid(2) = nam.nam$w_fid_seq
        fid(3) = nam.nam$w_fid_rvn
        getfid = sys$close(fab)
        return
        end

--------------------------------------------------------------------------
| Dale O. Miller                        | #   #  ###  #     ####         |
| University of Arkansas at Little Rock | #   # #   # #     #   #        |
| 2801 S. University                    | #   # ##### #     ####         |
| Little Rock, AR  72204-1099  USA      | #   # #   # #     #  #         |
| (501)569-8714                         |  ###  #   # ##### #   #        |
| DOMILLER@UALR.BITNET                  | Disclaimer: This does not      |
| 92-20-28 W,34-43-30 N.ICBMNET         | say what I say it doesn't say. |
--------------------------------------------------------------------------

