FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:11 PAGE 001 0001 program bupres c c program to do directory of bup magnetic tapes c 0002 logical*1 buffer(4096),yesno(80),yes,no,dir,query,file 0003 real buff2(1024) 0004 integer recn,buff3(2048),begin,out,fname(3) 0005 common/zips/ recn,begin,numdir 0006 common/ctl/ out,fname,dir,query,file 0007 equivalence (buffer(1),buff2(1)),(buffer(1),buff3(1)) 0008 data vol1/4hVOL1/,hdr1/4hHDR1/ 0009 data yes/'Y'/,no/'N'/ 0010 data dir/.false./,file/.false./,query/.false./ 0011 data out/5/ 0012 data fname/0,0,3RDAT/ 0013 call extmt(7) c rewind the tape 0014 recn=1 0015 call extmt(1,4096,buffer,long) 0016 if(long.eq.0) go to 9999 0018 if(buff2(1).ne.vol1) go to 9997 0020 type 10,(buffer(j),j=5,10) 0021 10 format(' Magnetic Tape Volume Label : ',6a1) 0022 recn=2 0023 call extmt(1,4096,buffer,long) 0024 if(long.eq.0) go to 9999 0026 if(buff2(1).ne.hdr1) go to 9995 0028 type 20,(buffer(j),j=5,21) 0029 20 format(' Magnetic Tape Header Label : ',17a1) 0030 recn=3 0031 call extmt(1,4096,buffer,long) 0032 if(long.eq.0) go to 9999 0034 type 30,(buffer(j),j="1731,"1744) 0035 30 format(' Volume Name of Backed Up Disk: ',13a1) 0036 type 40,(buffer(j),j="1745,"1760) 0037 40 format(' Owner Name of Backed Up Disk : ',12a1) 0038 50 type 49,"200 0039 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) 0040 call gtlin(yesno) 0041 if(index(yesno,'QUIT').eq.1) GO TO 8999 0043 if(index(yesno,'DIR').eq.1) go to 2000 0045 if(index(yesno,'FILE').eq.1) go to 3000 0047 if(index(yesno,'QUERY').ne.1) go to 50 0049 QUERY=.TRUE. 0050 go to 6000 0051 2000 continue 0052 DIR=.true. 0053 type 2001,"200 0054 2001 format(' Directory Output File Name? (Valid File Name or TT:)', FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:11 PAGE 002 *a1) 0055 call gtlin(yesno) 0056 if(len(yesno).eq.0) go to 6000 0058 if(index(yesno,'TT:').eq.1) go to 6000 0060 out=2 0061 iz=len(yesno) 0062 call assign(2,yesno,iz,'NEW','CC') 0063 WRITE(OUT,30) (buffer(j),j="1731,"1744) 0064 WRITE(OUT,40) (buffer(j),j="1745,"1760) 0065 go to 6000 0066 3000 continue 0067 FILE=.true. 0068 3002 type 3001,"200 0069 3001 format(' File Name To Be Restored?',a1) 0070 call gtlin(yesno) 0071 iz=len(yesno) 0072 if(iz.eq.0) go to 3002 0074 idot=index(yesno,'.') 0075 if(idot.eq.0) idot=iz+1 0077 ip=irad50(idot-1,yesno,fname) 0078 if(idot.gt.iz) go to 6000 0080 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) 0081 6000 continue c c now copy the directory to a disk file c 0082 call assign(1,'sy:tmp.tmp',10,'scr','nc') 0083 numseg=buff3(1537) d type *,' numseg=',numseg c total number of directory segments c 0084 nxtseg=buff3(1538) d type *,' next segment=',nxtseg c next logical segment number c 0085 lstseg=buff3(1539) d type *,' last segment = ',lstseg c last directory segment c 0086 longde=14+buff3(1540) d type *,' directory entry length',longde c length in bytes of directory entry c 0087 begin=buff3(1541) d type *,' first data block is',begin c first data block in this segment c 0088 call putseg(buff3(1542),longde) 0089 1000 if(nxtseg.le.0) go to 8000 0091 nextbk=4+nxtseg*2 0092 call loadbk(buffer,nextbk,nptr) FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:11 PAGE 003 0093 NXTSEG=BUFF3(NPTR+1) 0094 BEGIN=BUFF3(NPTR+4) 0095 CALL PUTSEG(BUFF3(NPTR+5),LONGDE) 0096 GO TO 1000 0097 8000 continue 0098 if(numdir.eq.0) GO TO 8999 0100 endfile 1 0101 rewind 1 c c now copy the files c 0102 call cop(buffer,numdir) 0103 8999 type *,' ' 0104 call exit 0105 9995 type 9996,(buffer(j),j=1,21) 0106 9996 format(' Illegal HDR1 label : ',21a1) 0107 call exit 0108 9997 type 9998,(buffer(j),j=1,11) 0109 9998 format(' Illegal VOL1 label : ',11a1) 0110 call exit 0111 9999 type *,' Unexpected E-O-F Encountered in record number ',recn 0112 call exit 0113 end FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:20 PAGE 001 0001 subroutine putseg(dir,long) 0002 logical*1 dir(long,1) 0003 common/zips/ recn,begin,numdir 0004 integer recn,begin 0005 logical*1 done 0006 done=.false. 0007 num=1 0008 1000 call putsg(dir(1,num),done) 0009 if(done) return 0011 num=num+1 0012 go to 1000 0013 end FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:21 PAGE 001 0001 subroutine putsg(entrys,done) 0002 integer entrys(7) 0003 common/zips/ recn,begin,numdir 0004 common/ctl/ out,fname,dir,query,file 0005 integer recn,begin,out,fname(3) 0006 logical*1 done,prot,outbuf(10),inbuff(80),dir,query,file 0007 logical*1 DATES(12) 0008 real*4 months(12) 0009 data months/3hJAN,3HFEB,3HMAR,3HAPR,3HMAY,3HJUN,3HJUL, *3HAUG,3HSEP,3HOCT,3HNOV,3HDEC/ c type 67,entrys c67 format(1x,7o8) 0010 if(entrys(1).ne."4000) go to 1000 0012 done=.true. 0013 return 0014 1000 iend=begin+entrys(5)-1 0015 if((entrys(1).eq."400).or.(entrys(1).eq."1000)) go to 9000 0017 prot=.false. 0018 if(entrys(1).eq."102000) go to 2000 0020 if(entrys(1).eq."2000) go to 3000 0022 type 1500,entrys,begin,iend 0023 1500 format(' Illegal Directory Entry',/, *1x,7o10,/,1x,2i10) 0024 call exit 0025 2000 prot=.true. 0026 3000 continue 0027 call r50asc(9,entrys(2),outbuf) 0028 IDAY=(ENTRYS(7).AND."1740)/32 0029 IMONTH=(ENTRYS(7).AND."36000)/1024 0030 IYEAR=(ENTRYS(7).AND."37) 0031 IP=IYEAR.AND."20 0032 IF(IP.NE.0) IYEAR=IYEAR.OR."37740 0034 IYEAR=IYEAR+"110+1900 D TYPE *,IDAY,IMONTH,IYEAR 0035 ENCODE(11,3021,DATES) IDAY,MONTHS(IMONTH),IYEAR 0036 3021 FORMAT(I2,'-',A3,'-',I4) 0037 DATES(12)=0 0038 3300 IF(.NOT.QUERY) GO TO 5000 0040 type 3500,(outbuf(j),j=1,9),(DATES(JJ),JJ=1,11),"200 0041 3500 format(1h-,'Restore?: ',6a1,'.',3a1,2X, *'(',11A1,')',' (Yes or No)',a1) 0042 call gtlin(inbuff) 0043 if(len(inbuff).eq.0) go to 9000 0045 if(index(inbuff,'N').eq.1) go to 9000 0047 if(index(inbuff,'Y').ne.1) go to 3300 0049 3550 numdir=numdir+1 0050 type 3600,"200 0051 3600 format(20x,' Output file name?',a1) 0052 call gtlin(inbuff) 0053 log=len(inbuff) 0054 if(log.ne.0) go to 4000 0056 do 3601 i=1,6 0057 3601 inbuff(i)=outbuf(i) 0058 inbuff(7)='.' FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:21 PAGE 002 0059 do 3602 i=7,9 0060 3602 inbuff(i+1)=outbuf(i) 0061 inbuff(11)=0 0062 4000 continue d log=len(inbuff) 0063 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) 0064 GO TO 9000 0065 5000 IF(.NOT.DIR) GO TO 6000 C HERE FOR DIRECTORY OUTPUT C 0067 WRITE(OUT,5002) (outbuf(j),j=1,9),(DATES(JJ),JJ=1,11), *ENTRYS(5) 0068 5002 FORMAT(1X,6A1,'.',3A1,5X,11A1,5X,I5) 0069 GO TO 9000 0070 6000 IF(.NOT.FILE) GO TO 9000 0072 IF(ENTRYS(2).NE.FNAME(1)) GO TO 9000 0074 IF(ENTRYS(3).NE.FNAME(2)) GO TO 9000 0076 IF(ENTRYS(4).NE.FNAME(3)) GO TO 9000 0078 GO TO 3550 0079 9000 begin=iend+1 0080 return 0081 end FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:28 PAGE 001 0001 SUBROUTINE loadbk(buffer,nextbk,nptr) 0002 INTEGER BUFFER(2048) 0003 common/zips/ recn,begin,numdir 0004 integer recn,begin 0005 new=3+nextbk/8 0006 if(new.eq.recn) go to 9000 0008 idel=new-recn 0009 if(idel.eq.1) go to 8000 0011 if(idel.gt.1) go to 7000 c c if to move tape backwards c 0013 idel=1+Iabs(idel) D TYPE *,' Move Tape Backwards ',idel,' Blocks' 0014 call extmt(5,idel) 0015 go to 8000 0016 7000 idel=idel-1 d type *,' Move Tape Forwards ',idel,' Blocks' 0017 call extmt(4,idel) 0018 8000 recn=new 0019 call extmt(1,4096,buffer,long) 0020 if(long.eq.0) go to 9999 0022 9000 continue 0023 nptr=(nextbk-8*(recn-3))*256+1 d type *,' Block ',nextbk,' is Record ', d *recn,' and pointer',nptr 0024 return 0025 9999 type *,' Unexpected EOF in loadbk at ',recn 0026 call exit 0027 end FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:30 PAGE 001 0001 subroutine cop(buffer,numdir) 0002 integer buffer(2048),begin,entrys(7),dblk(4),dk 0003 logical*1 inbuff(20) d logical*1 outbuf(20) 0004 data dk/3RDK / 0005 do 5000 i=1,numdir 0006 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) 0007 type 1001,inbuff 0008 1001 format(' Working on :',20a1) 0009 ichan=igetc() 0010 if(ichan.lt.0) go to 9999 c c now unpack the file name c 0012 icolon=index(inbuff,':') 0013 idot=index(inbuff,'.') 0014 ilong=len(inbuff) 0015 dblk(1)=dk 0016 dblk(2)=0 0017 dblk(3)=0 0018 dblk(4)=0 0019 if(icolon.eq.0) go to 2100 c c here to get the device name c 0021 if((icolon.eq.3).or.(icolon.eq.4)) go to 2110 0023 type 2109,inbuff 0024 2109 format(' Illegal Device Name:',20a1) 0025 call exit 0026 2110 iz=irad50(icolon-1,inbuff,dblk(1)) 0027 2100 continue 0028 if(idot.eq.0) go to 9998 0030 if((ilong-idot).eq.0) go to 2200 0032 iz=irad50(ilong-idot,inbuff(idot+1),dblk(4)) 0033 2200 continue 0034 if((idot-icolon).le.1) go to 9996 0036 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) 0037 iz=ienter(ichan,dblk,entrys(5)) 0038 if(iz.eq.-4) type *, *' A Protected File by That Name Already Exists!!' 0040 if(iz.eq.-4) go to 6789 0042 if((iz.lt.0).and.(iz.gt.-6)) go to 9993 0044 iend=begin+entrys(5)-1 0045 nb=0 0046 do 4000 nextbk=begin,iend 0047 next=nextbk 0048 call loadbk(buffer,next,nptr) 0049 iz=iwritw(256,buffer(nptr),nb,ichan) FORTRAN IV V02.5-13 Tue 14-Feb-84 09:21:30 PAGE 002 0050 nb=nb+1 0051 4000 continue 0052 call iclose(ichan) 0053 6789 call ifreec(ichan) 0054 5000 continue 0055 return 0056 9993 if((iz.eq.-1).or.(iz.eq.-5)) type *,' IENTER error ',iz 0058 if(iz.eq.-2) type *, *' Not Enough Space on the Output Device for the File!!' 0060 if(iz.eq.-3) type *, *' Output Device was Already in Use!!' 0062 9990 type *,' ' 0063 call exit 0064 9996 type 9995,inbuff 0065 9995 format(' Illegal File Name :',20a1) 0066 go to 9990 0067 9998 type 9997,inbuff 0068 9997 format(' Illegal File Extension :',20a1) 0069 go to 9990 0070 9999 type *,' IGETC error',ichan 0071 go to 9990 0072 end