brudir.ftn/-au=brudir.ftn;1 -4,8 -14 C x01.01 December 1981 - Correct behaviour for multi-reel input C tapesets. Note only one deck is used for input. C c Changes made to allow use with call from MCR or DCL. c 02.00 March 1986, Dan L. Eisner c c New command format is run $brudir/cmd="mt:/-sp/-rw 1600 list temp.dru" c The parameters are with two possible switches c /spool or /-sp c /rewind or /-rewind c 1600 or 800 c BRIEF or LIST or FULL c c c The above parameters are delimited by spaces. Or what ever but change c the parameter 'char' to change the delimiter c c This version has a bug when a large file crosses over two data sections c and there are no directory sections in between. c The error message can be ignored since the directory data will be there c c C slow version of BRUDIR, Uses a workfile to cater for 10000 files on disk C -29 byte cmdbuf(82), idens(10) integer * 2 ids, index, cmdlen integer * 2 ix, iden, istat -35 parameter char = 32 ! The space delimiter logical * 2 lre, found, find, rewind, spool -39,62 istat = 1 ! Preset the error status call getmcr(cmdbuf, ids) ! Fetch the command line cmdlen = ids index = 1 c if no command line then prompt for the input if (ids .le. 0) then found = .false. write(unit=5, fmt='('' ** BRU Directory listing 02.00'')') end if d if (ids .gt. 0) write(unit=5, fmt='(1x,80a1)')(cmdbuf(iz),iz=1,ids) found = find(char, cmdlen, cmdbuf, index, temp, iq) c test if there was any input data? if not then prompt. if (.not. found) then write(unit=5, fmt='(''$Input Tapedeck:'')') lre = .false. read(unit=5, fmt='(q,40a1)',end=1000)iq,temp lre = .true. 1000 if(.not. lre) call exit end if d write(unit=5, fmt='(1x,80a1)')(temp(iz),iz=1,iq) IF (TEMP(1).GT.'Z')TEMP(1)=TEMP(1)-32 IF (TEMP(2).GT.'Z')TEMP(2)=TEMP(2)-32 if (temp(3) .lt. '0' .or. temp(3) .gt. '9') then iunit =0 else iunit = temp(3) - '0' end if spool = .true. rewind = .true. c test if we inputed the switches??? if (iq .gt. 4) then do 2000 ix = 4,iq if ( temp(ix) .eq. '/' .and. temp(ix+ 1) .eq. '-' 1 .and. (temp(ix + 2) .eq.'R' 2 .or. temp(ix+2) .eq. 'r')) then rewind = .false. end if if ( temp(ix) .eq. '/' .and. temp(ix+ 1) .eq. '-' 1 .and. (temp(ix + 2) .eq.'S' 2 .or. temp(ix+2) .eq. 's')) then spool = .false. end if 2000 continue end if c ok set up the input device CALL ASNLUN(6,TEMP,IUNIT,IDS) IF(IDS.NE.1) then write(unit=5, fmt='('' Input ASNLUN failed: '',o4)')IDS call exst(ids) end if found = find(char, cmdlen, cmdbuf, index, idens, iq) c test if there was any input data? if not then prompt. if (.not. found) then write(unit=5, fmt='(''$Density (800/1600):'')') lre = .false. read(unit=5, fmt='(q,10a1)',end = 1010)iq, idens lre = .true. 1010 if(.not. lre) call exit end if d write(unit=5, fmt='(1x,80a1)')(idens(iz),iz=1,iq) decode(iq, 1011, idens)iden 1011 format(i4) PRL(1)="4004 !1600 or coredump if (iden .eq. 800) prl(1) = 4 CALL WTQIO("1400,6,6) !attach if (rewind) CALL WTQIO("2400,6,6) !rewind CALL WTQIO("2500,6,6,,IOSB,PRL) !set density found = find(char, cmdlen, cmdbuf, index, temp, iq) c test if there was any input data? if not then prompt. if (.not. found) then write(unit=5, fmt='(''$Listing format (FULL,BRIEF,LIST):'')') lre = .false. read(unit=5, fmt='(q,40a1)',end=1020)iq, temp lre = .true. 1020 if(.not. lre) call exit end if d write(unit=5, fmt='(1x,80a1)')(temp(iz),iz=1,iq) -67,77 found = find(char, cmdlen, cmdbuf, index, temp, ilen) c test if there was any input data? if not then prompt. if( .not. found) then write(unit=5, fmt='(''$Output file:'')') lre = .false. read(unit=5, fmt='(q,40a1)',end = 1030)ilen, temp lre = .true. 1030 if(.not. lre) call exit end if d write(unit=5, fmt='(1x,80a1)')(temp(iz),iz=1,ilen) IF(ILEN.EQ.0) then CALL ASNLUN(4,'TI',0) !default TTY output OPEN(UNIT=4,NAME='TI:',CARRIAGECONTROL='LIST', 1 TYPE='NEW') else CALL ASNLUN(4,'SY',0) TEMP(ILEN+1)=0 OPEN(UNIT=4,NAME=TEMP,CARRIAGECONTROL='LIST', 1 TYPE='NEW') end if -87,117 c C start with the volume label. c cxz CALL GETADR(PRL,IBUFF) PRL(2)=4144 if (rewind) then CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE.1) then TYPE*,'Error on volume label read',IOSB istat = -1 goto 9000 end if IF(IOSB(2).NE.80) then TYPE*,'Unexpected length at BOT',IOSB istat = -1 goto 9000 end if IF(IBUFF(1).NE.'VO'.OR.IBUFF(2).NE.'L1') then TYPE*,'Not VOL1 at BOT' istat = -1 goto 9000 end if WRITE(4,1060)(BBUFF(I),I=5,10),IDEN 1060 FORMAT('Volume label = "',6A1,'" Density ',I4) CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(2).NE.512) then TYPE*,'Boot block error - Prob not BRU tape' istat = -1 goto 9000 end if C C this is the point where we expect a new backupset or eot C end if 1070 CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).EQ."366)GOTO 8060 IF(IOSB(1).NE.1) then TYPE*,'Tape error ',IOSB,' on HDR1' istat = iosb(1) goto 9000 end if IF(IOSB(2).NE.80) then TYPE*,'Expected HDR1 found ',IOSB istat = -1 goto 9000 end if IF(IBUFF(1).NE.'HD'.OR.IBUFF(2).NE.'R1') then TYPE*,'Not HDR1 when expected' istat = -1 goto 9000 end if 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') then TYPE*,'Not HDR2 when expected' istat = -1 goto 9000 end if CALL WTQIO("1000,6,6,,IOSB,PRL) IF(IOSB(1).NE."366) then TYPE*,'Tape mark expected' istat = iosb(1) goto 9000 end if CALL WTQIO("1000,6,6,,IOSB,PRL) !now backup descriptor IF(IOSB(2).NE.80) then TYPE*,'Backupset descriptor expected' istat = -1 goto 9000 end if WRITE(4,1090)IBUFF(7),(BBUFF(I),I=1,12),(BBUFF(I),I=15,26), / (BBUFF(I+62),I=1,13) -124,124 CALL WTQIO("1000,6,6,,IOSb,PRL) !read boot block -143,143 1120 IF(IOSB(2).NE.80) then TYPE*,'Unexpected Sentinel length ',IOSB istat = -1 goto 9000 end if -163 -178 -194,194 IF(ICOUNT.GT.10000) STOP ' Directory buffer full' -198 -204 -230 -236 -244,254 IF(IFORMT.NE.2)then IF(IFORMT.eq.1) then WRITE(4,1186)IGRP,IMEM,FILE,IDIR(8),IUSED, 1 (BBUFF(I*2+K),K=72,84) 1186 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,I7,'. ' / ,2A1,'-',3A1,'-',2A1,' ',2A1,':',2A1,':',2A1) goto 1189 end if end if IF(IBUFF(I+29).EQ.1) then 1187 WRITE(4,1188)IGRP,IMEM,FILE,IDIR(8),IUSED,IALLOC, -259,263 else WRITE(4,1184)IGRP,IMEM,FILE,IDIR(8),IUSED,IALLOC, / IDIR(1),IDIR(2),(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,' (',I4,')') end if -273,275 WRITE(unit = 4, fmt = '(''*-End of Volume-*'')') CALL WTQIO("2540,6,6) !unload input tape -289,301 8040 WRITE(unit = 4, fmt = '(''**** End of Backupset. ****'')') DO 8001 I=1,ICOUNT IF(DIRFID(I).ne.0) then READ(3'I)IDIR CALL R50ASC(12,IDIR(4),FILE) !convert to the file in ascii IUFD=IDIR(3) IGRP=IAND(ISHFT(IUFD,-8),"377) IMEM=IAND(IUFD,"377) WRITE(4,8002)IGRP,IMEM,FILE,IDIR(8),IDIR(1),IDIR(2) 8002 FORMAT('[',O3,',',O3,']',9A1,'.',3A1,';',O4,' (',O5,',',O5, / ')') end if 8001 CONTINUE -307,313 8060 WRITE(unit = 4, fmt ='(''**** EOT ****'')') if ( .not. found ) TYPE*,'*EOT*' istat = 1 c error entry 9000 continue if( spool) then if( istat .eq. 1) then close(unit=4, dispose='PRINT') else close(unit = 4, dispose = 'DELETE') end if else CLOSE(UNIT=4) end if if (rewind) CALL WTQIO("2400,6,6) !rewind again CALL WTQIO("2000,6,6) !and detach CALL exst(istat) -326 c Find function c This function scans an input buffer and returns the parsed buffer logical * 2 function find(char, cmdlen, cmdbuf, index, temp, iq ) byte char(1) ! The delimiter character byte cmdbuf(1) ! The buffer of data to scan byte temp(1) ! The buffer of data to return integer * 2 cmdlen ! The length of the input buffer integer * 2 index ! The pointer to the input buffer data integer * 2 iq ! The length of the data found integer * 2 ix ! A counter and pointer logical * 2 txtfnd ! A flag for the scanner c on entry: c An example is "mt:/-sp 1600 list dm:rsxsp86.dru" = contents of cmdbuf c ^ = pointer index c char(1) = 32 = the delimiter c 32 = contents of cmdlen c c On exit: c An example is "mt:/-sp 1600 list dm:rsxsp86.dru" = contents of cmdbuf c ^ = pointer index c mt:/-sp = contents of temp c 7 = contents of iq c iq = 0 ! Set up a character counter c does the input line contain anything? if( cmdlen .le. 0 .or. cmdlen .eq. index ) 1 goto 110 ! If not then why scan it c Preset that there is not any text txtfnd = .false. c scan the line looking for a delimiter and setting up the output c buffer at the same time. do 100 ix = index,cmdlen c if the command buffer( index) is not a delimiter then if (cmdbuf(ix) .ne. char(1)) then txyfnd = .true. ! Set that we found some text iq = iq + 1 ! Bump character counter temp ( iq ) = cmdbuf(ix) ! Place data into output buffer else ! We found a delimiter if (txtfnd) then ! If there is text... index = ix ! ... Set the character count goto 110 ! Exit end if end if 100 continue ! End of scan loop index = cmdlen ! All of the text was from the command buffer c Exit point 110 continue if (iq .ne. 0) then ! Did we put some data into the buffer? find = .true. ! Yes then say we found data else find = .false. ! Else say we did not find any text end if return ! Exit end /