PROGRAM ANSI C C READ A (POSSIBLY) CORRUPTED ANSI MAGTAPE. C C C J Doran, Sira Ltd., South Hill, Chislehurst, Kent, BR7 5EH, England. C Tel: 01 467 2636 Telex: 896649 C C This program will read an unmounted ANSI magtape block by block, C allowing user intervention if the block read was not what it expected. C C Version: X0.12 Date: 8-Apr-82 C C Task-build as: C C >TKB C TKB>ANSITAPE,ANSITAPE/-SP=ANSITAPE,RENAME,LB:[1,1]F4POTS/LB C TKB>/ C ENTER OPTIONS: C TKB>MAXBUF=512 C TKB>// C C See "Multi-tasker" Vol 10, No 4, pp87-88 for RENAME. C BYTE ANS,ILLBYT(27) INTEGER*4 J,A(128),BLKTYP(11) INCLUDE 'ANSICOM.F4P' EQUIVALENCE (A,B) C Normal sequence of block types (repeats at HDR1): DATA BLKTYP/'VOL1','HDR1','HDR2','MARK','FILE','EOF1', * 'EOF2','MARK','EOV1','EOV2','????'/ DATA ILLBYT/' ','-','-',' ','i','n','v','a','l','i','d',' ', * 'b','y','t','e',' ','c','o','u','n','t',' ',0,0,0,0/ C C Suppress count conversion error in DECODE: CALL ERRSET(64,.TRUE.,.FALSE.,.TRUE.,.FALSE.) 1 TYPE 1000 1000 FORMAT('$Magtape device [ddu]: ') ACCEPT 1010,IDEV,IUNIT 1010 FORMAT(1A2,I1) CALL ASNLUN(1,IDEV.AND."57537,IUNIT,IDS) IF(IDS.EQ.ISSUC) GOTO 2 TYPE *,'Invalid device or unit' GOTO 1 2 CALL GETCHR('Written by RT-11',16,ANS,'YN',2,I) RT11=I.EQ.1 TYPE 1030 1030 FORMAT('$Start at block (<=0 for current) = ') ACCEPT *,NBLOCK IF(NBLOCK.LT.0) NBLOCK=0 IEXPCT=UNKNWN IF(NBLOCK.EQ.0) GOTO 5 CALL MTQIO(IORWD) ! Rewind tape IEXPCT=VOL1 ! First block type NBLOCK=NBLOCK-1 ! Blocks to space out IF(ISB(1).NE.ISSUC .OR. NBLOCK.EQ.0) GOTO 5 C Space to first block required. Have to do one block at a time because C a multiple space block instruction fails on tape marks. IPR(1)=1 DO 4 J=1,NBLOCK 3 CALL MTQIO(IOSPB) IF(ISB(1).EQ.IEEOF) GOTO 3 ! Don't count tape marks IF(ISB(1).NE.IEEOV) GOTO 4 ! Ignore errors CALL GETCHR('End of volume mark. Continue',28,ANS,'YN',2,I) IF(I.EQ.2) GOTO 9999 4 CONTINUE IEXPCT=UNKNWN ! Could begin with anything 5 COPY=.FALSE. ! Copy this file flag COPYAL=.FALSE. ! Copy all files flag FILOPN=.FALSE. ! File not open SLOWLY=.FALSE. ! Don't query each file block MODE=0 ! Unknown record format, except: IF(RT11) MODE='F' ! all RT-11 files are ANSI F CALL GETADR(IPR,A) ! Set up buffer pointer C C Come here for a new tape block. 10 NBLOCK=NBLOCK+1 DO 20 I=1,128 20 A(I)=0 IPR(2)=512 CALL MTQIO(IORLB) ! Read tape block DISPLD=.FALSE. ! Not displayed yet C Handle read errors. IF(ISB(1).EQ.ISSUC) GOTO 100 ! Successful read IF(ISB(1).EQ.IEEOF) GOTO 200 ! Tape mark IF(ISB(1).NE.IEBBE) GOTO 30 CALL TYPBLK(' is bad',7) GOTO 100 ! Process it anyway 30 IF(ISB(1).NE.IEDAO) GOTO 50 CALL TYPBLK(' -- data overrun',16) GOTO 100 ! Ditto 50 IF(ISB(1).NE.IEVER) GOTO 60 CALL TYPBLK(' -- unrecoverable error',24) GOTO 100 60 TYPE 1060,ISB(1),NBLOCK 1060 FORMAT(' Error ',O3,' on block ',I6,'.') 70 CALL GETCHR('Continue',8,ANS,'YN',2,I) GOTO (10,9999),I C C Block read. If RSX, should be 80 or 512 bytes. 80-byte blocks are file C headers etc, 512 byte blocks are data. All RT-11 blocks are 512 bytes, C so check everything. 100 CONTINUE IF(ISB(2).EQ.0) GOTO 10 ! Ignore empty block IF(RT11) GOTO 105 IF(ISB(2).GT.80) GOTO 500 ! Not 80, try file data IF(ISB(2).NE.80) CALL TYPBLK(' is short header block',22) C Find header type. Ask on TI: if unknown. 105 J=A(1) 110 DO 115 ITYPE=1,EOV2 IF(J.EQ.BLKTYP(ITYPE)) GOTO 130 115 CONTINUE IF(.NOT.RT11) GOTO 117 IF(IEXPCT.EQ.FILE) GOTO 500 TYPE 1100,NBLOCK,BLKTYP(IEXPCT),BLKTYP(FILE) 117 CALL TYPBLK(' is invalid header block',26) TYPE 1080 1080 FORMAT('$Enter type [VOL1/HDR1-2/FILE/EOF1-2/EOV1-2/QUIT/cr * to ignore]: ') ACCEPT 1090,J 1090 FORMAT(A4) IF(J.EQ.' ') GOTO 10 ! = ignore totally J=J.AND."17727657537 ! Strip parity & LC bits IF((J.AND."17700000000).GE."14100000000) J=J.AND."13727657537 IF(J.EQ.'QUIT') GOTO 9998 ! Close file and exit IEXPCT=UNKNWN GOTO 110 C Valid header block, see if we expected it (if anything in particular). 130 IF(ITYPE.NE.IEXPCT .AND. IEXPCT.NE.UNKNWN .AND. * .NOT.(ITYPE.EQ.EOV1 .AND. IEXPCT.EQ.EOF1)) * TYPE 1100,NBLOCK,BLKTYP(IEXPCT),BLKTYP(ITYPE) 1100 FORMAT(' Block',I6,'. Expecting ',A4,', read ',A4,'.') C Process according to what we got anyway. GOTO (140,150,170,200,500,180,190,200,300,310),ITYPE C VOL1 header, just print name of tape. 140 TYPE 1110,NBLOCK,(B(I),I=5,10) 1110 FORMAT(' Block ',I6,'. Volume label: ',6A1) IEXPCT=HDR1 ! Next should be file header GOTO 10 C HDR1 defines filename. See if it's wanted, unless copy all flag set. 150 IEXPCT=HDR2 IF(.NOT.FILOPN) GOTO 152 CALL CLSFIL TYPE *,'No EOF block, file closed anyway.' 152 TYPE 1120,NBLOCK,(B(I),I=5,21) 1120 FORMAT(' Block ',I6,'. Start of file ',17A1) DO 165 I=5,21 ! Save filename string 165 FNAME(I-4)=B(I) FNAME(18)=0 COPY=.TRUE. IF(.NOT.RT11) GOTO 10 ! RT-11 doesn't write HDR2's C HDR2. Open file if required, in appropriate mode (D or F). 170 IEXPCT=MARK IF(.NOT.COPY) GOTO 10 IF(.NOT.RT11) MODE=B(5) CALL OPNFIL ! Open file GOTO 10 C EOF1. Close file if open. 180 IEXPCT=EOF2 IF(SLOWLY) TYPE 1140,NBLOCK,(B(I),I=5,21) 1140 FORMAT(' Block ',I6,'. End of file ',17A1) IF(.NOT.RT11) GOTO 195 ! RT11 omits EOF2's -- expect NEWF C EOF2. Close file again, in case EOF1 missed. 190 IEXPCT=NEWF ! Expect mark & new file 195 CALL CLSREN ! Close, possibly renaming GOTO 10 C C Tape mark found. End-of-volume if we had one last time too. 200 NBLOCK=NBLOCK-1 ! Don't count it as a block IF(SLOWLY) TYPE *,'Tape mark after block',NBLOCK,'.' IF(ITYPE.NE.MARK) GOTO 205 TYPE *,'End of volume mark.' GOTO 70 205 ITYPE=MARK ! Remember in case a second GOTO (240,240,209,210,230,240,219,220,240,240,240),IEXPCT 209 TYPE 1100,NBLOCK,BLKTYP(HDR1),BLKTYP(MARK) ! { HDR2 -> } 210 IEXPCT=FILE ! mark -> file GOTO 10 219 TYPE 1100,NBLOCK,BLKTYP(EOF1),BLKTYP(MARK) ! { EOF2 -> } 220 IEXPCT=HDR1 ! mark -> HDR1 GOTO 10 230 IEXPCT=EOF1 ! file -> mark -> EOF1 GOTO 10 240 TYPE 1100,NBLOCK,BLKTYP(IEXPCT),BLKTYP(MARK) IEXPCT=UNKNWN GOTO 10 C C EOV1. End of file and volume in a multi-volume set. 300 IEXPCT=EOV2 302 CALL CLSREN ! Close file, with possible rename TYPE *,'End of volume block.' GOTO 70 C C EOV2. Second end-of-volume block. If expected, user is reading past it. 310 IF(IEXPCT.NE.EOV2) GOTO 302 IEXPCT=UNKNWN ! Anything could follow GOTO 10 C C Process file record if copying. Note file may not yet be open. 500 IF(IEXPCT.NE.FILE .AND. IEXPCT.NE.UNKNWN) * TYPE 1100,NBLOCK,BLKTYP(IEXPCT),4HFILE 505 ITYPE=FILE IF(IEXPCT.EQ.FILE .AND. (.NOT.COPY)) GOTO 10 IEXPCT=FILE CALL OPNFIL ! Open file if not done already IF(.NOT.(FILOPN.AND.COPY)) GOTO 10 IF(ISB(2).NE.512) TYPE *,ISB(2),' byte file block!' IF(.NOT.SLOWLY) GOTO 509 CALL TYPBLK(' ',1) CALL GETCHR('Copy block',10,ANS,'YNQFI',5,I) GOTO (509,10,9998,508,506),I 506 COPY=.FALSE. ! Ignore rest of this file GOTO 10 508 SLOWLY=.FALSE. ! continue copying, Fast 509 IF(MODE.EQ.'D') GOTO 510 C Not D must be F, write 512 byte block. WRITE(2'NREC) B GOTO 10 C Decompose D type block into records. Format is 4 bytes of ASCII byte C count, followed by the ASCII bytes themselves. '^' as the first byte C of the count means end of block. 510 L=0 520 L=L+1 IF(L.GE.512 .OR. B(L).EQ.'^') GOTO 10 DECODE(4,1170,B(L),ERR=525) M 1170 FORMAT(I4) M=L+M-1 IF(M.LE.512) GOTO 530 C Illegal byte count. Report and write out rest of record as is. 525 ILLBYT(24)=B(L) ! Complete message ILLBYT(25)=B(L+1) ILLBYT(26)=B(L+2) ILLBYT(27)=B(L+3) CALL TYPBLK(ILLBYT,27) M=512 L=L-4 ! Write illegal count too 530 WRITE(2,1180) (B(I),I=L+4,M) 1180 FORMAT(4(64A1)) NREC=NREC+1 L=M GOTO 520 C C End of program. GOTO 9998 to close file first on Quit. 9998 CALL CLSFIL 9999 END C C Open file, if it isn't open already. Ask for name if FILE is empty. SUBROUTINE OPNFIL INCLUDE 'ANSICOM.F4P' IF(FILOPN) RETURN IF(COPYAL) GOTO 706 COPY=.FALSE. SLOWLY=.FALSE. CALL GETCHR('Copy file',9,ANS,'YNGQS',5,I) GOTO (706,750,704,700,702),I 700 CALL EXIT ! Quit 702 SLOWLY=.TRUE. ! copy Slowly -- block by block GOTO 706 704 COPYAL=.TRUE. ! Go -- copy all 706 COPY=.TRUE. ! Yes, copy IF(FNAME(1).NE.0) GOTO 710 TYPE 3000 3000 FORMAT('$File name: ') ACCEPT 3010,FNAME 3010 FORMAT(36A1) FNAME(36)=0 710 CALL TSTCHR('Record format',13,MODE,'DF',2,I) CALL ASNLUN(2,'SY',0) ! Reset default O/P device GOTO (730,720),I C Open fixed length records file (task etc.), 128*4=512 bytes. 720 OPEN(UNIT=2,NAME=FNAME,FORM='UNFORMATTED',RECORDSIZE=128, * TYPE='NEW',ACCESS='DIRECT',ASSOCIATEVARIABLE=NREC,ERR=750) GOTO 740 C Open variable length records file (ASCII or binary). 730 OPEN(UNIT=2,NAME=FNAME,FORM='FORMATTED',TYPE='NEW', * CARRIAGECONTROL='LIST',RECORDSIZE=512,ERR=750) 740 FILOPN=.TRUE. NREC=1 ! Output record counter 750 RETURN END C C Close file. Allow user to rename it if the name in the EOF block C is different to that with which it was opened. SUBROUTINE CLSREN INCLUDE 'ANSICOM.F4P' IF(.NOT.FILOPN) GOTO 780 IF(NREC.EQ.1) GOTO 770 DO 760 I=1,17 IF(FNAME(I).NE.B(I+4)) GOTO 765 760 CONTINUE GOTO 770 765 TYPE 3020,(B(I),I=5,21),(FNAME(I),I=1,35) 3020 FORMAT(' File ',17A1,' was opened as: ',35A1) CALL GETCHR('Rename',6,ANS,'YN',2,I) IF(I.NE.1) GOTO 770 CALL ASSIGN(3,B(5),17) IDS=1 CALL RENAME(2,3,IDS) IF(IDS.LT.0) TYPE 3030,IDS 3030 FORMAT(' Rename failed ',O3) C C Enter here to close without rename option. ENTRY CLSFIL 770 IF(.NOT.FILOPN) GOTO 780 IF(NREC.NE.1) GOTO 775 TYPE 3040,FNAME 3040 FORMAT(' !! Deleting empty file: ',36A1) CLOSE(UNIT=2,DISPOSE='DELETE') GOTO 780 775 CLOSE(UNIT=2) 780 FNAME(1)=0 IF(.NOT.RT11) MODE=0 FILOPN=.FALSE. COPY=.FALSE. RETURN END C C Type out current block. SUBROUTINE TYPBLK(TITLE,LT) INCLUDE 'ANSICOM.F4P' BYTE TITLE(LT) DATA MASK/"177/ 800 TYPE 4000,NBLOCK,TITLE,ISB(2) 4000 FORMAT(' Block',I6,A1,'.',I5,' bytes.') IF(DISPLD .OR. ISB(2).EQ.0) RETURN IWIDTH=80 IF(ISB(2).NE.80) IWIDTH=64 C MAX0 call replaces control chars by spaces. TYPE 4010,(MAX0(MASK.AND.B(I),"40),I=1,ISB(2)) 4010 FORMAT(' Contents:',/,8(X,A1,/,:)) DISPLD=.TRUE. ! Don't display again RETURN END C C Issue magtape function QIO. SUBROUTINE MTQIO(IFUNC) INCLUDE 'ANSICOM.F4P' CALL WTQIO(IFUNC,1,6,,ISB,IPR,IDS) IF(IDS.NE.ISSUC) TYPE 4050,IDS 4050 FORMAT(' WTQIO rejected, $DSW = ',O3) IF(ISB(1).EQ.IEEOT) STOP 'Physical end of tape' RETURN END C C Print PROMPT at TI:, and get a single-character reply to ANS (UC only). C Look up CHAR in string REPLYS, containing valid answers, and return C index number in INDX if found. If not, repeat prompt until ANS is valid. SUBROUTINE GETCHR(PROMPT,LP,ANS,REPLYS,LR,INDX) BYTE PROMPT(LP),ANS,REPLYS(LR) 900 TYPE 5000,PROMPT,REPLYS 5000 FORMAT('$',A1,' [',(A1,'/'),A1,']? ') ACCEPT 5010,ANS 5010 FORMAT(A1) C Enter here if character is already in ANS. ENTRY TSTCHR(PROMPT,LP,ANS,REPLYS,LR,INDX) ANS=ANS.AND."137 ! Strip parity & LC bit DO 910 INDX=1,LR IF(ANS.EQ.REPLYS(INDX)) RETURN 910 CONTINUE GOTO 900 ! (Re)prompt if invalid END