PROGRAM ATTRIB C C W P Helman, "The Multi-Tasker", V11 No 2 April 1979. C C Restore file attributes C C 1. When run the device must not be logically mounted C for RSX11M system, or mounted /FOREIGN for RSX-11M-PLUS C of VAX/VMS. C 2. The block mumber asked for is the logical block number C from the HEADER program for the file named. C BYTE B(512), NAME(21), EXT(3), BBLK(4), BVERS(3) LOGICAL*1 VAXVMS INTEGER A(256), IPR(6), ISB(2), NBLK(2), C(256), BLK(4) INTEGER*4 NBLOCK C EQUIVALENCE (NBLOCK,NBLK), (A,B), (NBLOCK,BBLK) EQUIVALENCE (NAME(11),EXT(1)), (NAME(15),BVERS(1)) DATA IPR(2)/512/ DATA NAME(10)/'.'/, NAME(14)/';'/, NAME(21)/0/ C DATA IFNAM,IFTYP,IFVER/"30,"33,"34/ ! File ID pointers <*> DATA IEFNU,IEFSQ,IRTRV/"60,"61,"64/ ! by word <*> DATA ICHA,IUFAT,IHDHD/7,"10,"20/ ! <*> DATA JESQN,JUSE,JUIC2,JUIC1/"135,"145,"11,"12/ ! by byte <*> C CALL GETTSK(A) VAXVMS=A(15).EQ.5 CALL GETADR(IPR,C) ! Connect to file header TYPE 100 100 FORMAT('$Recovery device: ') ACCEPT 101,IDEV 101 FORMAT(1A2) TYPE 102 102 FORMAT('$Unit No. = ') ACCEPT *,IUNIT CALL ASNLUN(1,IDEV,IUNIT) C OPEN (UNIT=3,NAME='COPY.DAT',TYPE='OLD',READONLY) 10 READ(3,11,END=70) (A(I), I=1,IFVER) ! Correct file attributes 11 FORMAT( 64A2) C CALL R50ASC(9,A(IFNAM),NAME) CALL R50ASC(3,A(IFTYP),EXT) IVERS=A(IFVER) C 12 FORMAT(/X,21A1,2X,'[',O3,',',O3,']') IF (.NOT.VAXVMS) ENCODE(6,13,BVERS) IVERS ! octal 13 FORMAT(O6) IF (VAXVMS) ENCODE(6,14,BVERS) IVERS ! decimal 14 FORMAT(I6) TYPE 12,NAME,B(JUIC1),B(JUIC2) ! Identify file 20 TYPE 21 21 FORMAT('$File No. = ') ACCEPT *,NBLOCK IF(NBLOCK) 70,10,22 ! -ve=stop, 0=don't recover 22 IPR(5)=NBLK(1) IPR(4)=NBLK(2) CALL WTQIO("1000,1,1,,ISB,IPR,IDS) ! Read file header IF(ISB(1).NE.1) TYPE 23,ISB,IDS IF(C(IUFAT+5).LT.A(IUFAT+3)) GOTO 50 ! Too few blocks copied C 23 FORMAT(8O7) C DO 30 I=IFNAM,IFVER ! Check file names IF(A(I).NE.C(I)) GOTO 60 30 CONTINUE DO 40 I=ICHA+4,ICHA+IHDHD ! Reset file attrivbutes 40 C(I)=A(I) C(ICHA)=A(ICHA) C(ICHA+1)=A(ICHA+1) C ICKSM=0 DO 45 I=1,255 45 ICKSM=ICKSM+C(I) C(256)=ICKSM ! Reset header checksum C CALL WTQIO("400,1,1,,ISB,IPR,IDS) ! Update header IF(ISB(1).NE.1) TYPE 23,ISB,IDS GOTO 10 C 50 TYPE 51,A(IUFAT+5),C(IUFAT+5),C(IUFAT+3) 51 FORMAT(5X,'<>',3O7) GOTO 20 ! Do not change attributes C 60 CALL R50ASC(9,C(IFNAM),NAME) CALL R50ASC(3,C(IFTYP),EXT) ENCODE(3,13,BVERS) C(IFVER) TYPE 61,(NAME(I),I=1,18) GOTO 20 61 FORMAT(5X,'<>'/,5X,18A1) C 70 END