program bupres c c program to do directory of bup magnetic tapes c logical*1 buffer(4096),yesno(80),yes,no,dir,query,file real buff2(1024) integer recn,buff3(2048),begin,out,fname(3) common/zips/ recn,begin,numdir common/ctl/ out,fname,dir,query,file equivalence (buffer(1),buff2(1)),(buffer(1),buff3(1)) data vol1/4hVOL1/,hdr1/4hHDR1/ data yes/'Y'/,no/'N'/ data dir/.false./,file/.false./,query/.false./ data out/5/ data fname/0,0,3RDAT/ call extmt(7) c rewind the tape recn=1 call extmt(1,4096,buffer,long) if(long.eq.0) go to 9999 if(buff2(1).ne.vol1) go to 9997 type 10,(buffer(j),j=5,10) 10 format(' Magnetic Tape Volume Label : ',6a1) recn=2 call extmt(1,4096,buffer,long) if(long.eq.0) go to 9999 if(buff2(1).ne.hdr1) go to 9995 type 20,(buffer(j),j=5,21) 20 format(' Magnetic Tape Header Label : ',17a1) recn=3 call extmt(1,4096,buffer,long) if(long.eq.0) go to 9999 type 30,(buffer(j),j="1731,"1744) 30 format(' Volume Name of Backed Up Disk: ',13a1) type 40,(buffer(j),j="1745,"1760) 40 format(' Owner Name of Backed Up Disk : ',12a1) 50 type 49,"200 49 format(' Options!',/, *' QUIT',/, *' QUERY, Query which files to restore',/, *' DIR, Generate a director listing on an output device',/, *' FILE, Enter a file name to be restored',/, *' Enter option?',a1) call gtlin(yesno) if(index(yesno,'QUIT').eq.1) GO TO 8999 if(index(yesno,'DIR').eq.1) go to 2000 if(index(yesno,'FILE').eq.1) go to 3000 if(index(yesno,'QUERY').ne.1) go to 50 QUERY=.TRUE. go to 6000 2000 continue DIR=.true. type 2001,"200 2001 format(' Directory Output File Name? (Valid File Name or TT:)', *a1) call gtlin(yesno) if(len(yesno).eq.0) go to 6000 if(index(yesno,'TT:').eq.1) go to 6000 out=2 iz=len(yesno) call assign(2,yesno,iz,'NEW','CC') WRITE(OUT,30) (buffer(j),j="1731,"1744) WRITE(OUT,40) (buffer(j),j="1745,"1760) go to 6000 3000 continue FILE=.true. 3002 type 3001,"200 3001 format(' File Name To Be Restored?',a1) call gtlin(yesno) iz=len(yesno) if(iz.eq.0) go to 3002 idot=index(yesno,'.') if(idot.eq.0) idot=iz+1 ip=irad50(idot-1,yesno,fname) if(idot.gt.iz) go to 6000 ip=irad50(iz-idot,yesno(IDOT+1),fname(3)) D CALL R50ASC(9,FNAME,YESNO) D TYPE 3003,(YESNO(J),J=1,9) D3003 FORMAT(1X,' Searching for ',6A1,'.',3A1) 6000 continue c c now copy the directory to a disk file c call assign(1,'sy:tmp.tmp',10,'scr','nc') numseg=buff3(1537) d type *,' numseg=',numseg c total number of directory segments c nxtseg=buff3(1538) d type *,' next segment=',nxtseg c next logical segment number c lstseg=buff3(1539) d type *,' last segment = ',lstseg c last directory segment c longde=14+buff3(1540) d type *,' directory entry length',longde c length in bytes of directory entry c begin=buff3(1541) d type *,' first data block is',begin c first data block in this segment c call putseg(buff3(1542),longde) 1000 if(nxtseg.le.0) go to 8000 nextbk=4+nxtseg*2 call loadbk(buffer,nextbk,nptr) NXTSEG=BUFF3(NPTR+1) BEGIN=BUFF3(NPTR+4) CALL PUTSEG(BUFF3(NPTR+5),LONGDE) GO TO 1000 8000 continue if(numdir.eq.0) GO TO 8999 endfile 1 rewind 1 c c now copy the files c call cop(buffer,numdir) 8999 type *,' ' call exit 9995 type 9996,(buffer(j),j=1,21) 9996 format(' Illegal HDR1 label : ',21a1) call exit 9997 type 9998,(buffer(j),j=1,11) 9998 format(' Illegal VOL1 label : ',11a1) call exit 9999 type *,' Unexpected E-O-F Encountered in record number ',recn call exit end subroutine putseg(dir,long) logical*1 dir(long,1) common/zips/ recn,begin,numdir integer recn,begin logical*1 done done=.false. num=1 1000 call putsg(dir(1,num),done) if(done) return num=num+1 go to 1000 end subroutine putsg(entrys,done) integer entrys(7) common/zips/ recn,begin,numdir common/ctl/ out,fname,dir,query,file integer recn,begin,out,fname(3) logical*1 done,prot,outbuf(10),inbuff(80),dir,query,file logical*1 DATES(12) real*4 months(12) data months/3hJAN,3HFEB,3HMAR,3HAPR,3HMAY,3HJUN,3HJUL, *3HAUG,3HSEP,3HOCT,3HNOV,3HDEC/ c type 67,entrys c67 format(1x,7o8) if(entrys(1).ne."4000) go to 1000 done=.true. return 1000 iend=begin+entrys(5)-1 if((entrys(1).eq."400).or.(entrys(1).eq."1000)) go to 9000 prot=.false. if(entrys(1).eq."102000) go to 2000 if(entrys(1).eq."2000) go to 3000 type 1500,entrys,begin,iend 1500 format(' Illegal Directory Entry',/, *1x,7o10,/,1x,2i10) call exit 2000 prot=.true. 3000 continue call r50asc(9,entrys(2),outbuf) IDAY=(ENTRYS(7).AND."1740)/32 IMONTH=(ENTRYS(7).AND."36000)/1024 IYEAR=(ENTRYS(7).AND."37) IP=IYEAR.AND."20 IF(IP.NE.0) IYEAR=IYEAR.OR."37740 IYEAR=IYEAR+"110+1900 D TYPE *,IDAY,IMONTH,IYEAR ENCODE(11,3021,DATES) IDAY,MONTHS(IMONTH),IYEAR 3021 FORMAT(I2,'-',A3,'-',I4) DATES(12)=0 3300 IF(.NOT.QUERY) GO TO 5000 type 3500,(outbuf(j),j=1,9),(DATES(JJ),JJ=1,11),"200 3500 format(1h-,'Restore?: ',6a1,'.',3a1,2X, *'(',11A1,')',' (Yes or No)',a1) call gtlin(inbuff) if(len(inbuff).eq.0) go to 9000 if(index(inbuff,'N').eq.1) go to 9000 if(index(inbuff,'Y').ne.1) go to 3300 3550 numdir=numdir+1 type 3600,"200 3600 format(20x,' Output file name?',a1) call gtlin(inbuff) log=len(inbuff) if(log.ne.0) go to 4000 do 3601 i=1,6 3601 inbuff(i)=outbuf(i) inbuff(7)='.' do 3602 i=7,9 3602 inbuff(i+1)=outbuf(i) inbuff(11)=0 4000 continue d log=len(inbuff) write(1) begin,entrys,(inbuff(k),k=1,20) d type 4001,begin,entrys(5),(inbuff(k),k=1,log) d4001 format(1x,2i5,5x,20a1) GO TO 9000 5000 IF(.NOT.DIR) GO TO 6000 C HERE FOR DIRECTORY OUTPUT C WRITE(OUT,5002) (outbuf(j),j=1,9),(DATES(JJ),JJ=1,11), *ENTRYS(5) 5002 FORMAT(1X,6A1,'.',3A1,5X,11A1,5X,I5) GO TO 9000 6000 IF(.NOT.FILE) GO TO 9000 IF(ENTRYS(2).NE.FNAME(1)) GO TO 9000 IF(ENTRYS(3).NE.FNAME(2)) GO TO 9000 IF(ENTRYS(4).NE.FNAME(3)) GO TO 9000 GO TO 3550 9000 begin=iend+1 return end SUBROUTINE loadbk(buffer,nextbk,nptr) INTEGER BUFFER(2048) common/zips/ recn,begin,numdir integer recn,begin new=3+nextbk/8 if(new.eq.recn) go to 9000 idel=new-recn if(idel.eq.1) go to 8000 if(idel.gt.1) go to 7000 c c if to move tape backwards c idel=1+Iabs(idel) D TYPE *,' Move Tape Backwards ',idel,' Blocks' call extmt(5,idel) go to 8000 7000 idel=idel-1 d type *,' Move Tape Forwards ',idel,' Blocks' call extmt(4,idel) 8000 recn=new call extmt(1,4096,buffer,long) if(long.eq.0) go to 9999 9000 continue nptr=(nextbk-8*(recn-3))*256+1 d type *,' Block ',nextbk,' is Record ', d *recn,' and pointer',nptr return 9999 type *,' Unexpected EOF in loadbk at ',recn call exit end subroutine cop(buffer,numdir) integer buffer(2048),begin,entrys(7),dblk(4),dk logical*1 inbuff(20) d logical*1 outbuf(20) data dk/3RDK / do 5000 i=1,numdir read(1) begin,entrys,(inbuff(k),k=1,20) d type 1000,begin,entrys(5),inbuff d1000 format(' Restoring from ',i5,' length ',i5,5x,20a1) type 1001,inbuff 1001 format(' Working on :',20a1) ichan=igetc() if(ichan.lt.0) go to 9999 c c now unpack the file name c icolon=index(inbuff,':') idot=index(inbuff,'.') ilong=len(inbuff) dblk(1)=dk dblk(2)=0 dblk(3)=0 dblk(4)=0 if(icolon.eq.0) go to 2100 c c here to get the device name c if((icolon.eq.3).or.(icolon.eq.4)) go to 2110 type 2109,inbuff 2109 format(' Illegal Device Name:',20a1) call exit 2110 iz=irad50(icolon-1,inbuff,dblk(1)) 2100 continue if(idot.eq.0) go to 9998 if((ilong-idot).eq.0) go to 2200 iz=irad50(ilong-idot,inbuff(idot+1),dblk(4)) 2200 continue if((idot-icolon).le.1) go to 9996 iz=irad50(idot-icolon-1,inbuff(icolon+1),dblk(2)) d call r50asc(12,dblk,outbuf) d outbuf(13)=0 d type 2203,outbuf d2203 format(' Output File :',12a1) iz=ienter(ichan,dblk,entrys(5)) if(iz.eq.-4) type *, *' A Protected File by That Name Already Exists!!' if(iz.eq.-4) go to 6789 if((iz.lt.0).and.(iz.gt.-6)) go to 9993 iend=begin+entrys(5)-1 nb=0 do 4000 nextbk=begin,iend next=nextbk call loadbk(buffer,next,nptr) iz=iwritw(256,buffer(nptr),nb,ichan) nb=nb+1 4000 continue call iclose(ichan) 6789 call ifreec(ichan) 5000 continue return 9993 if((iz.eq.-1).or.(iz.eq.-5)) type *,' IENTER error ',iz if(iz.eq.-2) type *, *' Not Enough Space on the Output Device for the File!!' if(iz.eq.-3) type *, *' Output Device was Already in Use!!' 9990 type *,' ' call exit 9996 type 9995,inbuff 9995 format(' Illegal File Name :',20a1) go to 9990 9998 type 9997,inbuff 9997 format(' Illegal File Extension :',20a1) go to 9990 9999 type *,' IGETC error',ichan go to 9990 end