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
/