C R J D Kirkman. 1981 - A program to produce directory listings of C BRU format tapes. C C x01.01 December 1981 - Correct behaviour for multi-reel input C tapesets. Note only one deck is used for input. C C Mod to differentiate between IAS & RSX tapes, F. Borger, June 2 1983 C C slow version of BRUDIR, Uses a workfile to cater for 10000 files on disk C C Program to list a directory of a BRU format tape, C encompassing all the images on the tape, in any of C BReif, LIst (default) or FUll formats. C The listing is output to a user specified file. C PROGRAM BRUDIR C C Reader data buffer C INTEGER IBUFF(2072) BYTE BBUFF(4144) INTEGER*4 LONG,IALLOC,IMAX,IUSED INTEGER*4 KFIL,KUSD,KALL C C qio parameters ... C INTEGER PRL(6),IOSB(2) C C directory info save buffer C C INTEGER DIRFID(10000) C INTEGER IDIR(8) LOGICAL*1 RADGRO(3),RADUSR(3) C C C variables C BYTE FILE(12),TEMP(40),LASTFL(12) EQUIVALENCE(IBUFF(1),BBUFF(1)) C C setup for processing C TYPE*,'** BRU Directory listing x01.00' TYPE1000 1000 FORMAT('$Input Tapedeck:') ACCEPT1010,TEMP 1010 FORMAT(40A1) IF (TEMP(1).GT.'Z')TEMP(1)=TEMP(1)-32 IF (TEMP(2).GT.'Z')TEMP(2)=TEMP(2)-32 IUNIT=TEMP(3)-'0' IF(IUNIT.GT.7.OR.UNIT.LT.0)IUNIT=0 IF(TEMP(5).EQ.':')IUNIT=IUNIT*8+TEMP(4)-48 !'0' CALL ASNLUN(6,TEMP,IUNIT,IDS) IF(IDS.NE.1)TYPE*,'ASNLUN fails ',IDS IF(IDS.NE.1)CALL EXIT 1013 TYPE1015 1015 FORMAT(' IASV3.1/LATER RSX (1)'/ 1' EARLY RSX (2)'/ 2'$ OR IASV3.2 (3) ? ') ACCEPT*,IAS IF (IAS.LT.1.OR.IAS.GT.3) GOTO 1013 TYPE1020 ACCEPT*,IDENS 1020 FORMAT('$Density (800/1600):') PRL(1)="4004 !1600 or coredump IF(IDENS.EQ.800)PRL(1)=4 CALL WTQIO("1400,6,6) !attach CALL WTQIO("2400,6,6) !rewind CALL WTQIO("2500,6,6,,IOSB,PRL) !set density TYPE1030 1030 FORMAT('$Listing format (FULL,BRIEF,LIST):') ACCEPT1010,TEMP IFORMT=1 !list IF(TEMP(1).GE.'a'.AND.TEMP(1).LE.'z')TEMP(1)=TEMP(1)-32 IF(TEMP(1).EQ.'B')IFORMT=0 IF(TEMP(1).EQ.'F')IFORMT=2 TYPE1040 1040 FORMAT('$Output file:') ACCEPT1050,ILEN,TEMP 1050 FORMAT(Q,40A1) IF(ILEN.EQ.0)CALL ASNLUN(4,'TI',0) !default TTY output IF(ILEN.NE.0)CALL ASNLUN(4,'SY',0) TEMP(ILEN+1)=0 IF(ILEN.NE.0)OPEN(UNIT=4,NAME=TEMP,CARRIAGECONTROL='LIST', / TYPE='NEW') IF(ILEN.EQ.0)OPEN(UNIT=4,NAME='TI:',CARRIAGECONTROL='LIST', / TYPE='NEW') C C at this point we should be at BOT with the tapedeck on LUN 6 C the listing file open on LUN 4. C the terminal for errors/comments on lun 5 C C C open a scratch file for directory entries C C OPEN(UNIT=3,RECORDSIZE=4,ACCESS='DIRECT',TYPE='SCRATCH') C start with the volume label. CALL GETADR(PRL,IBUFF) PRL(2)=4144 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE.1)TYPE*,'Error on volume label read',IOSB IF(IOSB(2).NE.80)TYPE*,'Unexpected length at BOT',IOSB IF(IBUFF(1).NE.'VO'.OR.IBUFF(2).NE.'L1')TYPE*, / 'Not VOL1 at BOT' WRITE(4,1060)(BBUFF(I),I=5,10),IDENS 1060 FORMAT('Volume label = "',6A1,'" Density ',I4) CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(2).NE.512)TYPE*,'Boot block error - Prob not BRU tape' C C this is the point where we expect a new backupset/ of eot C GOTO 6539 1070 CONTINUE WRITE (4,6522)KFIL,KUSD,KALL 6539 CONTINUE CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).EQ."366)GOTO 8060 IF(IOSB(1).NE.1)TYPE*,'tape error',IOSB,' on HDR1' IF(IOSB(2).NE.80)TYPE*,'Expected HDR1 found ',IOSB IF(IBUFF(1).NE.'HD'.OR.IBUFF(2).NE.'R1')TYPE*, / 'Not HDR1 when expected' WRITE(4,1080)(BBUFF(I+4),I=1,17) 1080 FORMAT('Ansi file label = "',17A1,'"') CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IBUFF(1).NE.'HD'.OR.IBUFF(2).NE.'R2')TYPE*,'HDR2 expected' CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE."366)TYPE*,'Tape mark expected' CALL WTQIO("1000,6,6,,IOSB,PRL) !now backup descriptor IF(IOSB(2).NE.80)TYPE*,'Backupset descriptor expected' C C Handle dump date differently if Early RSX or IAS/Later RSX C IF (IAS.NE.2) WRITE(4,1090)IBUFF(7),(BBUFF(I),I=1,12), / (BBUFF(I),I=15,26),(BBUFF(I+62),I=1,13) IF (IAS.EQ.2) WRITE(4,1090)IBUFF(7),(BBUFF(I),I=1,12), / (BBUFF(I),I=15,26),(BBUFF(I+56),I=1,13) 1090 FORMAT('VOL',I1,' Backupset ="',12A1,'" Disc label ="',12A1,'"', / ' Dump taken at ',2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1) WRITE(4,1100)IBUFF(27),IAND("77777777,LONG(IBUFF(25))), / IBUFF(22),LONG(IBUFF(23)) 1100 FORMAT('Device type = ',A2,' Size =',I8,' Indexfile size =',I6 / ' MFD size = ',I7) CALL WTQIO("1000,6,6,,IOSB,PRL) !read boot block CALL WTQIO("1000,6,6,,IOSB,PRL) !read home block I=IBUFF(6) IF(I.EQ.0)I='??' IMAX=IBUFF(4) !is unisgned int IF(IMAX.LT.0)IMAX=IMAX+65536 !correct that WRITE(4,1101)IBUFF(1),LONG(IBUFF(2)),IMAX,IBUFF(5),IBUFF(7),I 1101 FORMAT('Bitmap size = ',I6,' Starts at lbn=',I10, / ' Maximum files = ',I6/ / 'Cluster factor =',I6,' Structure level =',O6,' Disk type "', / A2,'"') C IF (IAS.EQ.3) CALL WTQIO("1000,6,6,,IOSB,PRL) !read ? block C C ICOUNT=0 !there are no stored entries yet C WRITE (4,6522)KUSD,KFIL,KALL 6522 FORMAT(' Total Files in set ',I7,' Space Used/Alloc', 1 I7,'/',I7) KUSD=0 KALL=0 !ALLOCATED SPACE TOTAL KFIL=0 !FILES C DO 2221 IJK=1,12 2221 LASTFL(IJK)=0 C C here we expect a type record. C If this is a continuation tape only then it need not be C the UFD record, but may be HEAD or DATA C 1110 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).EQ."366)GOTO 8000 !eof 1120 IF(IOSB(2).NE.80)TYPE*,'unexpected Sentinel length',IOSB IF(IBUFF(1).NE.'DA')GOTO 1140 C C normally we might do something else, however for a directory C we simply skip the data blocks we fall over C C------- C compress the directory entries C - No longer since they are in a file C C IPTR=ICOUNT !end of buffer used C ICOUNT=0 !assert empty now C DO 1131 I=0,IPTR-1,8 !scan all buffer C IF(IDIR(I+1).EQ.0)GOTO 1131 C DO 1132 J=1,8 C IDIR(ICOUNT+J)=IDIR(I+J) C1132 CONTINUE C IDIR(I+1)=0 C ICOUNT=ICOUNT+8 C1131 CONTINUE C TYPE*,'Directory compressed from ',IPTR/8,' to',ICOUNT/8 1130 CALL WTQIO("1000,6,6,,IOSB,PRL) !look for something else. IF(IOSB(1).EQ."366)GOTO 8000 !deal with eof IF(IOSB(2).NE.80)GOTO 1130 !get more entries GOTO 1120 !work out what new sentinel 1140 IF(IBUFF(1).NE.'UF')GOTO 1160 !not a UFD C C enter a UFD record, get current UIC value C C IUFD=0 C IF(IBUFF(11).EQ.1)IUFD=IBUFF(14)!get owning uic (bin) C C MODIFIED, Directory uic owner not always the directory, so C Save RAD50 version of UIC which is the correct one CALL R50ASC(3,IBUFF(6),RADGRO) CALL R50ASC(3,IBUFF(7),RADUSR) CALL UFDCON(RADGRO,RADUSR,IUFD) 1150 CALL WTQIO("1000,6,6,,IOSB,PRL) !read another block IF(IOSB(1).EQ."366)GOTO 8000 !eof IF(IOSB(2).EQ.80)GOTO 1120 !find what this is C Here should be a block of a directory C DO 1151 I=0,IOSB(2)/2-1,8 !number of 8 word entries C SINCE we find extra entries at end, assume for now that BRU C compresses directories, see if first zero FID is end of directory C was GOTO 1151 to skip individual entry C C IF(IBUFF(I+1).EQ.0)GOTO 1150 !deleted entry C DO 1152 J=1,8 C IDIR(J)=IBUFF(I+J) C1152 CONTINUE C IDIR(3)=IUFD C C have made an entry with C C ICOUNT=ICOUNT+1 C DIRFID(ICOUNT)=IDIR(1) C WRITE(3'ICOUNT)IDIR C IF(ICOUNT.GT.10000)STOP ' Directory buffer full' C IF(IFORMT.NE.0)GOTO 1151 C CALL R50ASC(12,IBUFF(I+4),FILE) !convert to the file in ascii C IGRP=IAND(ISHFT(IUFD,-8),"377) C IMEM=IAND(IUFD,"377) C WRITE(4,1153)IGRP,IMEM,FILE,IBUFF(I+8),IBUFF(I+1),IBUFF(I+2) C1153 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, C / ')') C1151 CONTINUE GOTO 1150 !read another 1160 IF(IBUFF(1).NE.'HE')GOTO 1190 !if not unrecognised C C here process headers and corresponding UFD records C C the directory entries are already buffered. For each header C read in, find the entry, and print it out. C after finding zero the entry for later compression, to occur C when he hit the DATA sentinel. C 1170 CALL WTQIO("1000,6,6,,IOSb,PRL) !read ufd block IF(IOSB(1).EQ."366)GOTO 8000 !eof IF(IOSB(2).NE.80)GOTO 1180 IF(IBUFF(1).NE.'UF')GOTO 1120 !dispatch this C IUFD=0 C IF(IBUFF(11).EQ.1)IUFD=IBUFF(14)!get owning uic (bin) C C MODIFIED, Directory uic owner not always the directory, so C Save RAD50 version of UIC which is the correct one CALL R50ASC(3,IBUFF(6),RADGRO) CALL R50ASC(3,IBUFF(7),RADUSR) CALL UFDCON(RADGRO,RADUSR,IUFD) C The above allows us to do a 3 word match, thus accounting C for synonyms. C GOTO 1170 1180 CONTINUE !here with a block of headers DO 1181 I=0,IOSB(2)/2-1,256 !each header in the buffer C DO 1182 J=1,ICOUNT !scan up directory buffer C C fileid, seq are at offsets 2,3 current ufd is IUFD C C IF(IUFD.EQ.IDIR(J+3).AND.IDIR(J+1).EQ.IBUFF(I+2).AND. C / IDIR(J+2).EQ.IBUFF(I+3))GOTO 1183 C IF(DIRFID(J).EQ.IBUFF(I+2))GOTO 1183 C1182 CONTINUE !with scan C CALL R50ASC(12,IBUFF(I+24),FILE) C WRITE(4,999)IBUFF(I+2),IBUFF(I+3),IBUFF(I+5),FILE,IBUFF(I+28) C999 FORMAT('FID',O6,':',O6,O7,' ',9A1,'.',3A1,';',O4) C GOTO 1181 !some how we lost this one C1183 READ(3'J)IDIR CALL R50ASC(12,IBUFF(I+24),FILE) C DO 3333 IJK=1,12 IF(FILE(IJK).NE.LASTFL(IJK)) GOTO 3334 3333 CONTINUE GOTO 1189 C 3334 IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) IUSED=LONG(IBUFF(I+12)) IF(IBUFF(I+14).EQ.0)IUSED=IUSED-1 IALLOC=LONG(IBUFF(I+10)) KFIL=KFIL+1 KUSD=KUSD+IUSED KALL=KALL+IALLOC IF(IFORMT.NE.2)GOTO 1185 IF(IBUFF(I+29).EQ.1)GOTO 1187 WRITE(4,1184)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,IALLOC, / IBUFF(I+2),IBUFF(I+3),(BBUFF(I*2+K),K=72,84) / ,(BBUFF(I*2+K),K=59,71),IBUFF(I+29) 1184 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I6,'./',I6,'. ', / '(',O6,',',O6,') ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1,' ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1,' (',I5,')') GOTO 1189 1187 WRITE(4,1188)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,IALLOC, / IBUFF(I+2),IBUFF(I+3),(BBUFF(I*2+K),K=72,84) 1188 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I6,'./',I6,'. ', / '(',O6,',',O6,') ',2A1,'-',3A1,'-',2A1,' ',2A1,':', / 2A1,':',2A1) GOTO 1189 1185 IF(IFORMT.NE.1)GOTO 2222 WRITE(4,1186)IGRP,IMEM,FILE,IBUFF(I+28),IUSED,(BBUFF(I*2+K),K=72,84) 1186 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I7,'. ' / ,2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1) GOTO 1189 2222 IF(IFORMT.NE.0)GOTO 1189 CALL R50ASC(12,IBUFF(I+24),FILE) !convert to the file in ascii IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) WRITE(4,1153)IGRP,IMEM,FILE,IBUFF(I+28),IBUFF(I+2),IBUFF(I+3) 1153 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, / ')') C1189 DIRFID(J)=0 1189 DO 3335 IJK=1,12 3335 LASTFL(IJK)=FILE(IJK) 1181 CONTINUE GOTO 1170 1190 STOP 'Unexpected sentinel block' C C deal with end of backupset. C 8000 CALL WTQIO("1000,6,6,,IOSB,PRL) !read EOF1/EOV1 IF(BBUFF(3).EQ.'F')GOTO 8040 !was eof1 WRITE(4,8010) 8010 FORMAT(' *-End of Volume-*') CALL WTQIO("2540,6,6) !unload input tape 8020 CALL WTQIO("2520,6,6,,IOSB) !sense characteristics IF(IAND(IOSB(2),"1400).EQ.0)GOTO 8030 !wait until a new tape CALL WAIT(1,2) !wait 1 second GOTO 8020 !and look again C C now have seen a tape on the deck C 8030 PRL(1)=1 CALL WTQIO("2440,6,6,,IOSB,PRL) !skip 1 to get to header CALL GETADR(PRL,IBUFF) ! PRL(2)=4144 CALL WTQIO("1000,6,6,,IOSB,PRL) !after skipping Backupset header GOTO 1110 8040 WRITE(4,8050) 8050 FORMAT(' End of Backupset.') C DO 8001 I=1,ICOUNT C IF(DIRFID(I).EQ.0)GOTO 8001 C READ(3'I)IDIR C CALL R50ASC(12,IDIR(4),FILE) !convert to the file in ascii C IUFD=IDIR(3) C IGRP=IAND(ISHFT(IUFD,-8),"377) C IMEM=IAND(IUFD,"377) C WRITE(4,8002)IGRP,IMEM,FILE,IDIR(8),IDIR(1),IDIR(2) C8002 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, C / ')') C8001 CONTINUE PRL(1)=1 !setup to skip eof labels CALL WTQIO("2440,6,6,,IOSB,PRL) ! CALL GETADR(PRL,BBUFF) PRL(2)=4144 GOTO 1070 8060 WRITE(4,8070) 8070 FORMAT('*EOT*') CLOSE(UNIT=4) TYPE*,'*EOT*' CALL WTQIO("2400,6,6) !rewind again CALL WTQIO("2000,6,6) !and detach CALL EXIT END C C files 11 I*4 is the opposite to Fortran I*4 INTEGER*4 FUNCTION LONG(ID) INTEGER*2 ID(2),IT(2) INTEGER*4 IJ EQUIVALENCE(IJ,IT(1)) IT(1)=ID(2) IT(2)=ID(1) LONG=IJ RETURN END C C SPECIAL function to convert ascii uic to octal C SUBROUTINE UFDCON(RADGRO,RADUSR,IUFD) LOGICAL*1 RADGRO(3),RADUSR(3) DECODE (3,100,RADGRO) I DECODE (3,100,RADUSR) J 100 FORMAT (O3) IUFD=IAND(ISHFT(I,8),"177400) IUFD=IOR(IUFD,J) RETURN END