program UNDEL
c             -----
c
c  Undelete a file on a FILES-11 disk
c
c  --------------------------------------------------------------------------
c
c  Handles disks with any cluster size, and files with any number of
c  extension headers. Use with caution only when you REALLY need it;
c  a backup copy is always preferable if you have one. If the file
c  is really vital, back the disk up before using UNDEL on it.
c
c  Define $ UNDEL=="$disk:[directory]UNDEL.EXE" in SYSLOGIN etc.
c
c  Use:   $ UNDEL disk:filename             ! puts it into original directory
c         $ UNDEL disk:[dir]filename        ! puts it in [dir] if it exists
c  Disk must be mounted Files-11.
c
c  IF THIS PROGRAM SHOULD FALL OVER:
c
c  $ ANALYZE/DISK/REPAIR the disk afterwards if this program does not
c  recover the file or crashes for any reason without finishing normally.
c  You will probably get the file you wanted in the [SYSLOST] directory,
c  with possible multiply allocated blocks. If there are multiply allocated
c  blocks, copy the file to another disk and delete it, then
c  ANALYZE/DISK/REPAIR the disk again to clean it up. You will have to edit
c  or otherwise claen up the junk in the file in this case. If not, then
c  the file and disk are OK.
c
c  ------------------------------------------------------------------------
c
c  Bitmap holds 220 blocks, enough for an RA81 with cluster=1
c
      parameter (maxbitblk=220)
c
      character name*86,file*86,device*10,dir*60,ans*1,result*86
      integer*4 rslen,bitmap(128,maxbitblk),dirty,blocks
      logical*1 done(maxbitblk)
      byte record(512)
c
c  Home block definitions
c
      integer*4 dum3(3),dum,headers,maxfiles
      integer*2 i2dum3(3),cluster,mapvbn,mapsize
      byte struc(2)
c
c  File header definitions
c
      integer*2 check,fid(3),extfid(3),bakfid(3)
      integer*4 filechar,idoff,resoff,acloff
      equivalence (fid(1),record(9)),
     &            (extfid(1),record(15)),
     &            (filechar,record(53)),
     &            (bakfid(1),record(67)),
     &            (check,record(511))
c
c
c  Open INDEXF.SYS and BITMAP.SYS on the afflicted disk
c
      call LIB$GET_FOREIGN(file)
      lendev=INDEX(file,':')
      if(lendev.eq.0) stop 'No device specified, no risks taken'
      device=file(1:lendev)
      print*,'Opening index file and bitmap on ',device
      jpos=INDEX(file,']')
      if(jpos.gt.lendev) then
         dir=file(lendev+1:jpos)
         lend=LENBL(dir)
         file=file(jpos+1:)
         print*,'Attempting to recover ',file(1:LENBL(file)),
     &          ' and place it in directory ',dir(1:LENBL(dir))
      else
         dir=' '
         file=file(lendev+1:)
         print*,'Attempting to recover ',file(1:LENBL(file)),
     &          ' and place it in its original directory'
      endif
      write(6,'(1x,a,$)') 'Continue? (Y/N) '
      read(5,'(a)',end=800) ans
      if(ans.ne.'y') go to 800
      iver=INDEX(file,';')
c
      open(1,file=device(1:lendev)//'[000000]INDEXF.SYS',shared,
     &     form='unformatted',recordtype='fixed',status='old')
      open(2,file=device(1:lendev)//'[000000]BITMAP.SYS',shared,
     &     form='unformatted',recordtype='fixed',status='old')
c
c  Read in the storage bitmap, skipping over the SCB (block 1)
c
      read(2)
      i=1
    5 read(2,end=6) (bitmap(j,i),j=1,128)
      i=i+1
      go to 5
c
    6 nblocks=i
      print*,nblocks,' blocks read from storage bitmap'
      do i=1,nblocks
         done(i)=.false.
      enddo
c
c  Read the home block (record 2) from INDEXF.SYS
c
      print*,'Reading home block on ',device
      read(1)
      read(1) dum3,struc,cluster,i2dum3,mapvbn,dum,maxfiles,mapsize
      if(struc(2).ne.2) stop 'Disk is not a FILES-11 ODS-2 disk.'
      print*,'Disk is Files-1 ODS-2 version',struc(1)
      print*,'Cluster size is',cluster
      print*,'Maximum number of files is',maxfiles
      print*,'Index file bitmap starts at VBN',mapvbn,
     &       ' and goes on for',mapsize,' blocks'
      headers=mapvbn+mapsize
      print*,'File headers start at VBN',headers
c
c  Skip over the alternate home block, index bitmap etc. and start reading
c  headers for the file
c
      do i=3,headers-1
         read(1,end=150)
      enddo
      ivbn=headers-1
      blocks=0
      dirty=0
      iseek=0
      lastblock=0
      do 100 i=1,maxfiles
         ivbn=ivbn+1
         read(1,end=150) record
c
c  Get the name from the ID offset; the first 20 chars are at the ID offset
c  The remaining 66, if they exist, are later on in the ident area
c
   30    idoff=record(1)
         idoff=idoff*2
         mpoff=record(2)
         mpoff=mpoff*2
         if(idoff.le.0.or.idoff.gt.512) go to 100
         k=1
         name=' '
         do j=1,20
            name(j:j)=CHAR(record(idoff+k))
            k=k+1
            if(idoff+k.gt.mpoff) go to 35
         enddo
         k=55
         do j=21,86
            name(j:j)=CHAR(record(idoff+k))
            k=k+1
            if(idoff+k.gt.mpoff) go to 35
         enddo
   35    lenl=INDEX(name,';')-1
         if(iver.gt.0.or.lenl.le.0) lenl=86
         if(iseek.eq.0.and.name(1:lenl).ne.file) go to 100
c
c  The name compared (up to the ';' if a version was not specified)
c
         lenl=LENBL(name)
         print*,'Filename: ',name(1:lenl)
         write(6,1000) ivbn,fid,extfid,filechar,check
c
c  If we are looking for extension headers, scream loudly if all not OK here
c
         if(iseek.gt.0) then
            k=INDEX(name,';')-1
            if(name(1:k).ne.file) stop
     &         'Index file corrupt; bad filename in extension header'
            if(check.ne.0.and.fid(1).ne.0) stop
     &         'Index file corrupt; extension header not deleted'
c
c  See if the file was deleted
c
         else
            if(check.ne.0.and.fid(1).ne.0) then
               print*,'This file is not deleted'
               go to 100
            endif
            write(6,'(1x,a,$)') 'Recover this file? (Y/N) '
            read(5,'(a)',end=100) ans
            if(ans.ne.'y') go to 100
         endif
c
c  Found a deleted file we want to restore - replace the fid and checksum,
c  and clear the delete bit in filechar
c
         fid(1)=ivbn-4*cluster-mapsize
         filechar=filechar.and.'FFFF7FFF'x
c
c  If we are doing the original header (not an extension):
c  The original directory is pointed to by bakfid; if a directory was specified
c  we need to find out its fid first and put it in the backlink fid
c  Leave extension bakfid alone as it points to the previous file header
c
         if(dir.ne.' '.and.iseek.eq.0)
     &      call PARSE (device(1:lendev)//dir(1:lend)//'*.*',bakfid)
c
c  Checksum the record and write it back into the current record
c
         call CHECKSUM(record)
         print*,'Rewriting file header for ',name(1:lenl)
         write(6,1000) ivbn,fid,extfid,filechar,check 
         call UPD(1,record,512)
c
c  If we are doing the original header (not an extension):
c  Enter file into the directory specified or into its original directory
c
         if(iseek.eq.0) then
            write(6,1020) bakfid
            call ENTER(name(1:lenl),fid,bakfid,device(1:lendev),
     &                 result,rslen)
            if(rslen.gt.0) print*,'Created '//result(1:rslen)
         endif
c
c  Go through the bitmap and see if all the blocks in this file are still free
c  If so, the file is OK; mark the blocks as used and we are done
c  If not, we need to copy this file OFF the disk and ANAL/DISK/REPAIR ASAP
c
c  Record still contains the file header; go through the map area
c  Each bit in the bitmap represents 1 cluster of blocks
c  Clear the bit in the bitmap memory image so we can write it back later
c
         mpend=511
         resoff=record(3)
         if(resoff.gt.0.and.resoff*2+1.lt.mpend) mpend=resoff*2+1
         acloff=record(4)
         if(acloff.gt.0.and.acloff*2+1.lt.mpend) mpend=acloff*2+1
         m=mpoff+1
         print*
         print*,'Checking bitmap for allocation of blocks...'
         print*
         print*,'Count Start Retrieval pointer'
   80    call RPOINTER(record(m),lbncount,lbnstart,m)
         if(m.ge.mpend) go to 85
         if(lbncount.eq.0) go to 80
         lbnstart=lbnstart/cluster
         lbncount=lbncount/cluster
         do j=lbnstart,lbnstart+lbncount-1
            iblock=j/4096+1
            if(iblock.le.0.or.iblock.gt.nblocks) stop 'Silly block #'
            ibit=MOD(j,4096)
            iword=ibit/32+1
            ibit=MOD(ibit,32)
            blocks=blocks+1
            if(.not.LIB$EXTZV(ibit,1,bitmap(iword,iblock)))
     &         dirty=dirty+1
            call LIB$INSV(0,ibit,1,bitmap(iword,iblock))
            done(iblock)=.true.
            lastblock=MAX0(lastblock,iblock)
         enddo
         go to 80
c
c  If the file has extension headers, continue reading these and looking
c  for more retrieval pointers; if not, we are done
c
   85    if(extfid(1).eq.0) then
            if(dirty.gt.0) go to 190
            go to 185
         else
            iseek=extfid(1)
            do j=1,iseek-fid(1)
               ivbn=ivbn+1
               read(1) record
            enddo
            go to 30
         endif
  100 continue
c
c  Whole index file has been scanned, stop
c
  150 print*,'EOF on INDEXF.SYS'
  160 close(1)
      close(2)
      call EXIT
c
c  Here all the storage bits are free - the file is intact, and we have marked
c  them as allocated again. Rewrite the affected bitmap blocks back to
c  BITMAP.SYS
c
  185 print*,'Rewriting affected blocks in BITMAP.SYS: 1 to',
     &       lastblock
      rewind 2
      read(2)
      do j=1,lastblock
         read(2)
         if(done(j)) call UPD(2,bitmap(1,j),512)
      enddo
      print*
      print*,'Recovered',blocks,' blocks'
      print*,'FILE AND DISK HAVE BEEN RECOVERED INTACT'
      go to 160
c
c  Error message for multiply allocated blocks
c
  190 print*,dirty,' out of',blocks,' blocks have been allocated'//
     &       ' to another file!'
      print*,'Do the following in DCL:'
      print*
      print*,'   $ COPY ',result(1:rslen),' another_disk:[directory]'
      print*,'   $ DELETE ',result(1:rslen)
      print*,'   $ ANALYZE/DISK/REPAIR '//device
      print*
      print*,'This will clean up the disk'
      go to 160
c
  800 stop 'UNDEL aborted - no action taken'
c
 1000 format(' VBN',i5,': FID(',i5,2i3,') EXT(',i5,2i3,') CHAR ',z8.8,
     &       ' CHECK ',z4.4)
 1020 format(' Entering file into directory FID (',i5,2i3,')')
      end
      subroutine UPD(iunit,record,length)
c
      byte record(length)
      integer FOR$RAB
c
c  $UPDATE a record back into the file on unit
c
      irab=FOR$RAB(iunit)
      call UPD2(%VAL(irab),record,length)
      return
      end
      subroutine UPD2(rab,record,length)
c
      include '($rabdef)'
c
      integer SYS$UPDATE,SYS$FLUSH
      byte record(length)
      record /rabdef/ rab
c
c  $UPDATE then $FLUSH to RAB
c
      rab.rab$l_rbf=%LOC(record(1))
      rab.rab$w_rsz=length
      iret=SYS$UPDATE(rab)
      if(.not.iret) then
         write(6,1000) rab.rab$l_sts,rab.rab$l_stv
         go to 80
      endif
      iret=SYS$FLUSH(rab)
      if(.not.iret) then
         write(6,1000) rab.rab$l_sts,rab.rab$l_stv
         go to 80
      endif
      return
   80 print*,'Trouble writing the file header into the index file.'
      print*,'You may not have enough privileges. Error text follows:'
      call LIB$STOP(%VAL(iret))
      return
c
 1000 format(' RMS Status on $UPDATE: ',z8.8,' STV value: ',z8.8)
 1010 format(' RMS Status on $FLUSH: ',z8.8,' STV value: ',z8.8)
      end
      subroutine PARSE(string,did)
c
      include '($fabdef)'
      include '($namdef)'
c
      integer SYS$PARSE
      integer*2 did(3),savdid(3)
      character*(*) string
c
      record /fabdef/ fab
      record /namdef/ nam
c
c  Parse device//dir//'*.*' to get the directory id and device into
c  the NAM block
c
      call MOV3(did,savdid)
      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
      fab.fab$l_nam=%LOC(nam)
      fab.fab$l_fna=%LOC(string)
      fab.fab$b_fns=LEN(string)
c
      iret=SYS$PARSE(fab)
      if(.not.iret) then
         write(6,1010) fab.fab$l_sts,fab.fab$l_stv
         print*,'Cannot find the directory you want.'
         print*,'File will be put back into its original directory'
         call MOV3(savdid,did)
         return
      endif
      call MOV3(nam.nam$w_did,did)
      return
c
 1010 format(' RMS Status on $PARSE: ',z8.8,' STV value: ',z8.8)
      end
      subroutine ENTER(file,fid,did,device,result,rslen)
c
      include '($iodef)'
      include '($fibdef)'
c
      integer SYS$ASSIGN,SYS$QIOW,fibdesc(2),iosb(2),rslen
      integer*2 channel,fid(3),did(3)
      character*(*) file,device,result
c
      record /fibdef/ fib
c
c  Invoke ACP function to create a directory entry
c  This will complain if the directory isn't there (but file will be found
c  later by ANAL/DISK/REPAIR and put into [SYSLOST])
c
c  Get a channel to the device
c
      iret=SYS$ASSIGN(device,channel,,)
      if(.not.iret) then
         write(6,1000) iret
         go to 80
      endif
c
c  Create the directory entry
c
      fibdesc(1)=22
      fibdesc(2)=%LOC(fib)
      call MOV3(did,fib.fib$w_did)
      call MOV3(fid,fib.fib$w_fid)
      fib.fib$w_nmctl=fib$m_newver
      iret=SYS$QIOW(,%VAL(channel),%VAL(io$_create),iosb,,,
     &              fibdesc,file,rslen,result,,)
      if(iret) iret=iosb(1)
      if(iret) return
c
c  Error entering the file in the directory
c
      write(6,1000) iret
   80 print*,'The file has not been entered in a directory.'
      print*,'ANALYZE/DISK/REPAIR is required to put it in [SYSLOST]'
      rslen=0
      return
 1000 format(' $ASSIGN status: ',z8.8)
 1010 format(' $QIOW status on CREATE: ',z8.8)
      end
      subroutine MOV3(fid,blkfid)
c
      integer*2 fid(3),blkfid(3)
c
c  Move a 3-word fid
c
      blkfid(1)=fid(1)
      blkfid(2)=fid(2)
      blkfid(3)=fid(3)
      return
      end
      subroutine RPOINTER(map,lbncount,lbnstart,m)
c
      integer*2 map(*)
c
c  Break the count and start fields out of a retrieval pointer
c  Handle the 3 formats of 'em that exist
c  Bump m by the # of bytes in the pointer found
c
      itype=LIB$EXTZV(14,2,map(1))
      if(itype.eq.0) then		! Placement word or junk
         lbncount=0
         lbnstart=0
      else if(itype.eq.1) then		! 4-byte short form
         lbncount=LIB$EXTZV(0,8,map(1))+1
         lbnstart=map(2)+65536*LIB$EXTZV(8,6,map(1))
      else if(itype.eq.2) then		! 6-byte medium form
         lbncount=LIB$EXTZV(0,14,map(1))+1
         lbnstart=map(2)+65536*map(3)
      else if(itype.eq.3) then		! 8-byte long form
         lbncount=map(2)+65536*LIB$EXTZV(0,14,map(1))+1
         lbnstart=map(3)+65536*map(4)
      endif
      j=(itype+1)*2
      m=m+j
      if(itype.eq.0) return
      write(6,'(2i6,4(1x,z4.4))') lbncount,lbnstart,(map(i),i=1,itype+1)
      return
      end
      integer function LENBL(string)
c
      character*(*) string
c
c  Returns the length of a character string, ignoring trailing blanks
c
      do 20 l=LEN(string),1,-1
   20   if(string(l:l).ne.' ') go to 40
      l=0
   40 LENBL=l
      return
      end