PROGRAM BUPRES c program to handle BUP magnetic tapes c logical*1 buffer(4096),yesno(80),yes,no,dir,query,file integer*2 BUFF2(2048),FNAME(3) INTEGER*2 DBLK(4),ERRBLK(4) common/zips/ IRECNO,IBEGIN,NUMDIR,ICHAN,IERADR common/ctl/ IOUT,FNAME,dir,query,file equivalence (buffer(1),BUFF2(1)) DATA DBLK/3RMS ,0,0,0/, ERRBLK/0,0,0,0/ data IVOL1/'VO'/,IVOL2/'L1'/,IHDR1/'HD'/,IHDR2/'R1'/ data yes/'Y'/,no/'N'/ data dir/.false./,file/.false./,query/.false./ DATA IDAT/3RDAT/ FNAME(1)=0 FNAME(2)=0 FNAME(3)=IDAT IOUT=5 ICHAN=IGETC() IF(ICHAN.LT.0) STOP 'NO CHANNEL AVAILABLE' IF(IFETCH(DBLK).NE.0) STOP 'BAD FETCH' IF(LOOKUP(ICHAN,DBLK,-1).NE.0) STOP 'BAD LOOKUP' IERADR=IADDR(ERRBLK) c rewind the tape IFUNC="373 IERR=ISPFNW(IFUNC,ICHAN,0,0,IERADR) IRECNO=1 IFUNC="370 IERR=ISPFNW(IFUNC,ICHAN,2048,BUFF2,IERADR) IF(IERR.EQ.1) GOTO 9999 if(BUFF2(1).NE.IVOL1 .OR. BUFF2(2).NE.IVOL2) go to 9997 type 10,(buffer(j),j=5,10) 10 format(' Magnetic Tape Volume Label : ',6a1) IRECNO=2 IFUNC="370 IERR=ISPFNW(IFUNC,ICHAN,2048,BUFF2,IERADR) IF(IERR.EQ.1) GOTO 9999 if(BUFF2(1).NE.IHDR1 .OR. BUFF2(2).NE.IHDR2) go to 9995 type 20,(buffer(j),j=5,21) 20 format(' Magnetic Tape Header Label : ',17a1) IRECNO=3 IFUNC="370 IERR=ISPFNW(IFUNC,ICHAN,2048,BUFF2,IERADR) IF(IERR.EQ.1) GOTO 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 directory listing on an output device',/, * ' FILE, Enter a file name to be restored',/, * ' 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? (or TT:) ',A1) call gtlin(yesno) if(len(yesno).eq.0) go to 6000 if(index(yesno,'TT:').eq.1) go to 6000 IOUT=2 iz=len(yesno) call assign(2,yesno,iz,'NEW','CC') WRITE(IOUT,30) (buffer(j),j="1731,"1744) WRITE(IOUT,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)) 6000 continue c c now copy the directory to a disk file c call assign(1,'DK:TMP.TMP',10,'SCR','NC') numseg=BUFF2(1537) c total number of directory segments c nxtseg=BUFF2(1538) c next logical segment number c lstseg=BUFF2(1539) c last directory segment c longde=14+BUFF2(1540) c length in bytes of directory entry c IBEGIN=BUFF2(1541) c first data block in this segment c call putseg(BUFF2(1542),longde) 1000 if(nxtseg.le.0) go to 8000 nextbk=4+nxtseg*2 call loadbk(buffer,nextbk,nptr) NXTSEG=BUFF2(NPTR+1) IBEGIN=BUFF2(NPTR+4) CALL PUTSEG(BUFF2(NPTR+5),LONGDE) GO TO 1000 8000 continue if(NUMDIR.eq.0) GO TO 8999 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 ',IRECNO call exit end subroutine putseg(dir,long) logical*1 dir(long,1) common/zips/ IRECNO,IBEGIN,NUMDIR,ICHAN,IERADR 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/ IRECNO,IBEGIN,NUMDIR,ICHAN,IERADR common/ctl/ IOUT,FNAME,dir,query,file integer FNAME(3) logical*1 done,prot,outbuf(10),inbuff(80),dir,query,file logical*1 DATES(9),FILNAM(10) real*4 months(12) data months/'Jan','Feb','Mar','Apr','May','Jun','Jul', * 'Aug','Sep','Oct','Nov','Dec'/ if(entrys(1).ne."4000) go to 1000 done=.true. return 1000 ISIZE=entrys(5) iend=IBEGIN+ISIZE-1 call r50asc(9,entrys(2),outbuf) prot=' ' do 1001 i=1,9 1001 DATES(i)=' ' ENCODE(10,1005,FILNAM) 1005 FORMAT('< UNUSED >') if((entrys(1).eq."400).or.(entrys(1).eq."1000)) go to 6000 if(entrys(1).eq."102000) go to 2000 if(entrys(1).eq."2000) go to 3000 type 1500,entrys,IBEGIN,iend 1500 format(' Illegal Directory Entry',/, *1x,7o10,/,1x,2i10) call exit 2000 prot='P' 3000 ENCODE(10,3005,FILNAM) (outbuf(j),j=1,9) 3005 FORMAT(6A1,'.',3A1) 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 ENCODE(11,3021,DATES) IDAY,MONTHS(IMONTH),IYEAR 3021 FORMAT(I2,'-',A3,'-',I2) 3300 IF(.NOT.QUERY) GO TO 5000 type 3500,FILNAM,DATES,"200 3500 format('0'/' Restore?: ',10A1,2X,'(',9A1,')', * ' (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,10 3601 inbuff(i)=FILNAM(i) inbuff(11)=0 4000 continue write(1) IBEGIN,entrys,(inbuff(k),k=1,20) GO TO 9000 5000 IF(.NOT.FILE) GO TO 6000 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 C C GET HERE FOR DIRECTORY OUTPUT C 6000 IF(.NOT. DIR) GOTO 9000 WRITE(IOUT,5002) FILNAM,ISIZE,prot,DATES,IBEGIN 5002 FORMAT(' ',10A1,I6,A1,1X,9A1,I6) 9000 IBEGIN=iend+1 return end SUBROUTINE loadbk(buffer,nextbk,nptr) INTEGER BUFFER(2048) common/zips/ IRECNO,IBEGIN,NUMDIR,ICHAN,IERADR new=3+nextbk/8 if(new.eq.IRECNO) go to 9000 idel=new-IRECNO 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) IFUNC="375 IERR=ISPFNW(IFUNC,ICHAN,IDEL,0,IERADR) go to 8000 C C MOVE TAPE FORWARDS IDEL BLOCKS C 7000 idel=idel-1 IFUNC="376 IERR=ISPFNW(IFUNC,ICHAN,IDEL,0,IERADR) C C TAPE IS NOW POSITIONED PROPERLY C 8000 IRECNO=new IFUNC="370 IERR=ISPFNW(IFUNC,ICHAN,2048,BUFFER,IERADR) IF(IERR.EQ.1) GOTO 9999 9000 continue nptr=(nextbk-8*(IRECNO-3))*256+1 return 9999 type *,' Unexpected EOF in loadbk at ',IRECNO call exit end subroutine cop(buffer,NUMDIR) integer buffer(2048),entrys(7),dblk(4),dk logical*1 inbuff(20) data dk/3RDK / do 5000 i=1,NUMDIR read(1) IBEGIN,entrys,(inbuff(k),k=1,20) 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)) 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=IBEGIN+entrys(5)-1 nb=0 do 4000 nextbk=IBEGIN,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