Google
 

Trailing-Edge - PDP-10 Archives - integ_tools_tops20_v7_30-apr-86_dumper - tools/10backup_v2_2/10backup.bas
There are 8 other files named 10backup.bas in the archive. Click here to see a list.
1 %title '10BACKUP Program To Read DECsystem 10 Backup Tapes'
  %ident '10BACKUP v2.2'
  !
  !
  !
  ! 10BACKUP was written at LaTrobe University when it was realised
  ! that after our aging KI10 processor was decommissioned, there
  ! would still be a large number of user tapes around that had been
  ! written by the DECsystem-10 BACKUP utility. 10BACKUP solves this
  ! problem by allowing these tape to be read directly onto the VAX,
  ! even after the DECsystem-10 is gone.
  !
  ! This version of 10BACKUP was set up and tested under VMS V4.1 using
  ! a TE16 attached to a VAX 11/780 processor. All test tapes were
  ! produced using BACKUP under TOPS-10 6.03A using a TU40 attached
  ! to a KI10 processor.
  !
  !
  !
  !
  ! DEC-10 backup tapes contain fixed length 2720 byte records
  ! written in DEC-10 core dump format. This program is an attempt
  ! at understanding the format of these records.
  !
  ! This program uses interchange mode (ignores Disk and UFD info)
  ! to read DEC-10 backup tapes. (and maybe TOPS-20 Dumper tapes.)
  ! If you have any suggestions or would like any program changes
  ! then please drop me a line to let me know. I would appreciate
  ! any feedback so send SPR's to:-
  !				Paul Nankervis
  !				Computer Centre
  !				La Trobe University
  !				BUNDOORA, 3083
  !				AUSTRALIA
  !
  ! This program can read its tape input from an RMS file or
  ! from a foreign mounted tape. If the input is found to be from
  ! a foreign mounted tape then QIO's are used otherwise RMS is
  ! called to do the input. The module BIO handles all the tape
  ! input. For performance BIO multi-buffers its input when using
  ! QIO's.
  !
  ! Normally the program would directly access the tape using QIO's:-
  !
  !		$ MOUNT/FOREIGN MSA0: 68SURVEY MYTAPE
  !		$ RUN 10BACKUP
  !		/TAPE MYTAPE:
  !		/DIRECTORY  ALPHA.*,*YZ.FOR
  !		 .....
  !		/REWIND
  !		/SSNAME "My Save Set"
  !		/DIR *.DAT,*.FOR
  !		 .....
  !		/REWIND
  !		/RESTORE AB*YZ.FOR
  !		/EXIT
  !		$
  !
  !
  ! The program can read its input from an RMS file if need be. This
  ! is normally only useful for debugging the program:-
  !
  !		$ MOUNT/FOREIGN MTA0:/BLOCK=2720/RECORD=2720
  !		$ COPY MTA0: 10TAPE.DAT
  !		$ RUN 10BACKUP
  !		/TAPE 10TAPE.DAT
  !		/DIR
  !		 .....
  !		/REWIND
  !		/RESTORE *MN*.FOR
  !		/EXIT
  !		$
  !
  !
  ! When the program reaches the end of input during the processing
  ! of a save set it assumes that another tape volume must follow.
  ! In this case it will prompt the user for the name of the next
  ! tape device if running as an interactive job or reading from an
  ! RMS file. If reading from a tape in a batch job a message will
  ! be sent via OPCOM asking the operators to load the next volume.
  !
  ! 10BACKUP prompts for its commands using a '/'. The commands may
  ! be in lower case and may be abbreviated. They must be seperated
  ! from any parameters by at least one space or tab character.
  ! Parameters may be enclosed in double quotes (") in order to preserve
  ! any special spacing or lowercase characters.
  !
  ! Normally when running 10BACKUP the TAPE command is used as the first
  ! command to set up access to the tape. After that option setting
  ! commands such as SSNAME, SIXBIT, OUTPUT_DEFAULT would be used to set
  ! up any special options. Then RESTORE or DIRECTORY commands may be
  ! used to actually access the tape.
  !
  ! The commands implemented are:-
  !
  !	TAPE  device-name
  !	DIR  [file-names]
  !	RESTORE  [file-names]
  !	EXIT
  !	SSNAME  [save-set-name]
  !	OUTPUT_DEFAULT  [output-default-file-spec]
  !	REWIND
  !	HELP  [topic...]
  !	SKIP  file-count
  !	SIXBIT  record-size
  !
  !
  ! When running in SIXBIT mode 10BACKUP will produce fixed length
  ! output records containing the ASCII equivalent of assumed SIXBIT
  ! input. Each DEC-10 word is broken up into six sixbit characters
  ! which are converted to ASCII by adding decimal 32. In this way
  ! every bit of the DEC-10 words can be captured in a VAX file. Naturally
  ! any binary information in the file which was not SIXBIT would have
  ! to be converted to the desired format by a user program.
  !
  !
  !
  ! The source modules that make up the 10BACKUP program are:-
  !
  !	10BACKUP.BAS	the main line program.
  !	BIO.MAR		contains tape and file IO routines.
  !	BUR.MAR		is a set of macro utility routines.
  !	C36.MAR		contains 36 bit conversion routines.
  !	BMS.MSG		contains the error message definitions.
  !	10BACKUP.RNH	Runoff input to build the help library.
  !
  ! The program can be compiled and linked in the following manner:-
  !
  !		$ BASIC 10BACKUP
  !		$ MACRO BIO
  !		$ MACRO BUR
  !		$ MACRO C36
  !		$ MESSAGE BMS
  !		$ LINK/NOTRACE 10BACKUP,BIO,BUR,C36,BMS
  !		$ RUNOFF 10BACKUP.RNH
  !		$ LIBRARY/CREATE/HELP 10BACKUP 10BACKUP
  !
  !
  !
  !
  ! There are a couple of extensions that can be made to this program.
  ! Some favourites include:
  !	a) Use VAX CLI command interface.
  !	b) Handle DATE-75 dates.
  !	c) Handle device formats other than TM10 (see module C36).
  !	d) Write of backup tapes?
  !	e) Better file wildcarding.
  !	f) Check command parameters better.
  !
  !
  !
  !
  !
  !
  !
  !
  !
  %page
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  !
  ! This is 10BACKUP's mainline to get commands and decide what
  ! to do with them.
  !
  ! The magic variable in the program is tape_status. It defines
  ! what state the tape is in according to the following table:-
  !
  !		tape_status	condition
  !
  !		    -1		the tape device is not open for access
  !		     0		tape is normal and ready for reads
  !		     1		reserved
  !		     2		retryable error detected (internal to process_tape)
  !		     3		fatal error occured in last tape access
  !		     4		have reached the end of the tape
  !
  !
	option type = explicit		!This helps debugging.
  !
  !
  ! First declare a couple of important constants:-
  !
	declare string constant					&
		program_version = "10BACKUP v2.2",		&
		help_library = "SYSPUB:10BACKUP.HLB",		&
		command_prompt = "/"
  !
  !
  ! Declare error status codes:-
  !
	external long constant					&
		rms$_eof,	bms_unrecmd,	bms_notape,	&
		bms_sixbitsize,	bms_endorerr,	bms_helperr
  !
  !
  ! Declare external functions:-
  !
	external long function					&
		lib$get_input,	ots$cvt_ti_l,	process_tape,	&
		bur_get_help,	bio_tape_init,	bio_tape_rewind,&
		bio_tape_skip,	bio_tape_close
  !
  ! Declare local variables:-
  !
	declare					&
		long finished,			&
		long status_code,		&
		long tape_status,		&
		long sixbit_size,		&
		long skip_count,		&
		long cmd_verb_size,		&
		string select_ssnm,		&
		string output_default,		&
		string cmd_input,		&
		string cmd_parameters
  !
  !
  !
  ! Now for some code,
  !
  ! First initialise everything:-
  !
	nomargin #0%		! Rotten BASIC and it's margins.
	print program_version	! Who are we?
	print
	tape_status = -1%	! No tape device (yet).
	sixbit_size = 0%	! Use ascii restore mode (not sixbit).
	select_ssnm = ''	! No particular save set (ie all save sets).
	output_default = ''	! No special output defaults.
  !
  !
  ! Now loop around executing commands:-
  !
	finished = 0%
  !
	    until finished
	    
	    status_code = lib$get_input( cmd_input, command_prompt )

	    if status_code and 1% then
		
		! Seperate command from parameters.

		cmd_input = edit$(cmd_input,441%)
		cmd_verb_size = instr(1%,cmd_input,' ')
		if cmd_verb_size then		!extract parameters
		    cmd_parameters = right(cmd_input,cmd_verb_size+1%)
		    if left(cmd_parameters,1%) = '"' then
			cmd_parameters = right(cmd_parameters,2%)
			if right(cmd_parameters,len(cmd_parameters)) = '"' then
			    cmd_parameters = left(cmd_parameters,len(cmd_parameters)-1%)
			end if
		    end if
		    cmd_verb_size = cmd_verb_size - 1%
		else
		    cmd_parameters = ''
		    cmd_verb_size = len(cmd_input)
		end if

		! Check to see what command we got.

		select left(cmd_input,cmd_verb_size)

		    case ''			! Ignore nothing.

		    case left('TAPE',cmd_verb_size)
			if tape_status >= 0% then
			    call bur_chkerr( bio_tape_close )
			end if
			status_code = bio_tape_init(cmd_parameters)
			if status_code and 1% then
			    tape_status = 0%
			else
			    tape_status = -1%
			    call bur_wrtmsg( status_code )
			end if

		    case left('DIRECTORY',cmd_verb_size)
			if tape_status = 0% then
			    call bur_chkerr( process_tape( tape_status, 0%, &
				sixbit_size, select_ssnm,		&
				edit$(cmd_parameters,511%), output_default ) )
			else
			    if tape_status < 0% then
				call bur_wrtmsg( bms_notape )
			    else
				call bur_wrtmsg( bms_endorerr )
			    end if
			end if

		    case left('RESTORE',cmd_verb_size)
			if tape_status = 0% then
			    call bur_chkerr( process_tape( tape_status, -1%, &
				sixbit_size, select_ssnm,		&
				edit$(cmd_parameters,511%), output_default ) )
			else
			    if tape_status < 0% then
				call bur_wrtmsg( bms_notape )
			    else
				call bur_wrtmsg( bms_endorerr )
			    end if
			end if

		    case left('EXIT',cmd_verb_size)
			finished = -1%

		    case left('REWIND',cmd_verb_size)
			if tape_status >= 0% then
			    call bur_chkerr( bio_tape_rewind )
			    tape_status = 0%
			else
			    call bur_wrtmsg( bms_notape )
			end if

		    case left('SSNAME',cmd_verb_size)
			select_ssnm = cmd_parameters

		    case left('OUTPUT_DEFAULT',cmd_verb_size)
			output_default = cmd_parameters

		    case left('HELP',cmd_verb_size)
			status_code = bur_get_help( cmd_parameters, help_library, -1% )
			if (status_code and 1%) = 0% then
			    call bur_wrtmsg( bms_helperr, help_library )
			    call bur_wrtmsg( status_code )
			end if

		    case left('SKIP',cmd_verb_size)
			if tape_status = 0% then
			    status_code = ots$cvt_ti_l( cmd_parameters, skip_count )
			    if status_code and 1% then
				status_code = bio_tape_skip( skip_count )
				if status_code and 1% then
				    tape_status = 0%
				else
				    if status_code = rms$_eof then
					tape_status = 4%
				    else
					tape_status = 3%
					call bur_wrtmsg( status_code )
				    end if
				end if
			    else
				call bur_wrtmsg( status_code )
			    end if
			else
			    if tape_status < 0% then
				call bur_wrtmsg( bms_notape )
			    else
				call bur_wrtmsg( bms_endorerr )
			    end if
			end if

		    case left('SIXBIT',cmd_verb_size)
			status_code = ots$cvt_ti_l( cmd_parameters, sixbit_size )
			if status_code and 1% then
			    if sixbit_size < 0% or sixbit_size > 32763% then
			    call bur_wrtmsg( bms_sixbitsize )
			    sixbit_size = 0%	! Use ASCII mode then.
			    end if
			else
			    call bur_wrtmsg( status_code )
			end if

		    case else			! What was that?
			call bur_wrtmsg( bms_unrecmd )

		end select			! Command is processed.
	!
	! otherwise we got an error reading the command, is it EOF?
	!
	    else
		if status_code = rms$_eof then
		    finished = -1%
		else		! Unexpected status
		    call bur_chkerr( status_code )
		end if
	    end if
	    next
	!
	! We have finished, close the tape if it is still open.
	!
	if tape_status >= 0% then
	    call bur_chkerr( bio_tape_close )
	    tape_status = -1%
	end if
  !
  !	Exit with the worst program status code encountered.
  !
	call bur_exit
	end					! End of mainline.











3000	function long process_tape( long tape_status, long restore_flag, &
		long sixbit_size, string select_ssnm, string select_files, &
		string output_default )
  !
  !
  ! This module does the actual tape processing. It searches the tape
  ! for the correct save-set and prints directory information for and
  ! optionally restores selected files. It is the workhorse of 10BACKUP.
  !
	option type = explicit	! Our little debugging aid.
  !
  !
  ! Declare status codes.
  !
	external long constant					&
		rms$_eof,	ss$_normal,	ss$_parity,	&
	 	ss$_dataoverun,					&
		bms_nossend,	bms_nosstart,	bms_ssnotfound,	&
		bms_endnoss,	bms_endssfile,	bms_fileinfile,	&
		bms_midfile,	bms_eofnofile,	bms_noname,	&
		bms_seqerr,	bms_gotrptblk,	bms_norptblk,	&
		bms_ignrptblk,	bms_excesserrors,bms_chksumerr,	&
		bms_baddatasize,bms_badblocktype,bms_badrecsize,&
		bms_filerdwerr,	bms_noopen
  !
  ! Declare some external routines.
  !
	external long function					&
		lib$get_input,	sys$fao,	select_file,	&
		bur_flag_set,	bio_tape_init,	bio_tape_rewind,&
		bio_tape_read,	bio_tape_close,	bio_tape_skip,	&
		bio_next_volume,bio_file_init
		
	external string function				&
		bur_get_date,	bur_get_ascii,	bur_get_sixbit

  !
  !
  ! Now set up the parameters describing a BACKUP block,
  ! these were gleaned from our documentation on BACKUP
  ! (which was written in 1976 for TOPS-10 6.03A).
  !
  ! Set valid codes for record types (for g$type):-
  !
	declare integer constant		&
		t$lbl = 1%,			&
		t$beg = 2%,			&
		t$end = 3%,			&
		t$fil = 4%,			&
		t$ufd = 5%,			&
		t$eov = 6%,			&
		t$com = 7%,			&
		t$con = 8%,			&
		t$max = 8%
  !
  !
  !
  ! Set up g$flag bit definitions:-
  !
	declare integer constant		&
		gf$eof = 0%,			&
		gf$rpt = 1%,			&
		gf$nch = 2%,			&
		gf$sof = 3%
  !
  !
  !
  ! Set up overhead block types:-
  !
	declare integer constant		&
		o$name = 1%,			&
		o$file = 2%,			&
		o$dirt = 3%,			&
		o$sysn = 4%,			&
		o$ssnm = 5%
  !
  !
  ! Define tape block data locations:-
  ! (Each 36 bit word is stored in a quadword)
  !
  ! WRDSIZ describes how many of our BASIC integers it
  ! takes to map out a quadword.
  !
	declare integer constant wrdsiz = 2%
  !
	declare integer constant		&
		g$type	= 0%,			&
		g$seq	= g$type + wrdsiz,	&
		g$rtnm	= g$seq + wrdsiz,	&
		g$flag	= g$rtnm + wrdsiz,	&
		g$chk	= g$flag + wrdsiz,	&
		g$siz	= g$chk + wrdsiz,	&
		g$lnd	= g$siz + wrdsiz,	&
		g$future= g$lnd + wrdsiz,	&
		g$cust	= g$future + 4% * wrdsiz, &
		g$vary	= g$cust + wrdsiz,	&
		g$data	= g$vary + 20% * wrdsiz
  !
  !
  !
  ! Set up t$lbl varying word definitions:-
  !
	declare integer constant		&
		l$date	= g$vary,		&
		l$fmt	= l$date + wrdsiz,	&
		l$bver	= l$fmt + wrdsiz,	&
		l$mon	= l$bver + wrdsiz,	&
		l$sver	= l$mon + wrdsiz,	&
		l$apr	= l$sver + wrdsiz,	&
		l$dev	= l$apr + wrdsiz,	&
		l$mtch	= l$dev + wrdsiz,	&
		l$rlnm	= l$mtch + wrdsiz,	&
		l$dstr	= l$rlnm + wrdsiz
  !
  !
  !
  ! Set up t$beg, t$con, and t$end varying word definitions:-
  !
	declare integer constant		&
		s$date	= g$vary,		&
		s$fmt	= s$date + wrdsiz,	&
		s$bver	= s$fmt + wrdsiz,	&
		s$mon	= s$bver + wrdsiz,	&
		s$sver	= s$mon + wrdsiz,	&
		s$apr	= s$sver + wrdsiz,	&
		s$dev	= s$apr + wrdsiz,	&
		s$mtch	= s$dev + wrdsiz
  !
  !
  !
  ! Set up t$fil varying word definitions:-
  !
	declare integer constant		&
		f$pchk	= g$vary,		&
		f$rdw	= f$pchk + wrdsiz,	&
		f$pth	= f$rdw + wrdsiz
  !
  !
  !
  ! Set up o$file block offsets:-
  !
	declare integer constant		&
		a$fhln = wrdsiz,		&
		a$flgs = a$fhln + wrdsiz,	&
		a$writ = a$flgs + wrdsiz,	&
		a$alls = a$writ + wrdsiz,	&
		a$mode = a$alls + wrdsiz,	&
		a$leng = a$mode + wrdsiz,	&
		a$bsiz = a$leng + wrdsiz,	&
		a$vers = a$bsiz + wrdsiz
  !
  !
  ! Declare local functions:-
  !
	declare long function			&
		sb_search, print_sys
	declare string function sb_text
	declare					&
		long sb_type,			&
		long sb_length
  !
  !
  ! Declare local variables:-
  !
	declare					&
		long sel_ss,			&
		long in_ss,			&
		long in_file,			&
		long write_file,		&
		long done,			&
		long status_code,		&
		long rms_status,		&
		long b_wrd(1087),		&
		string ss_name,			&
		string file_name,		&
		string file_type,		&
		long file_size,			&
		long file_rdw,			&
		long file_alq,			&
		long attr_sb,			&
		long name_sb,			&
		long name_sblen,		&
		long retries,			&
		long block_seq,			&
		long block_length,		&
		long block_address,		&
		long block_chk(1),		&
		long block_chksum(1),		&
		long print_length,		&
		string operator_reply
  !
  ! Map out fixed length print buffer.
  !
	map (print_buffer)			&
		string print_buffer = 132
  !
  !
  !
  ! First thing to do is to initialize the local variables.
  !
	in_ss = 0%		!Not yet inside a save set.
	in_file = 0%		!Not yet inside a file.
	write_file = 0%
	if select_ssnm = '' then
	    sel_ss = -1%	!By default select all save sets.
	else
	    sel_ss = 0%		!Only want particular save sets.
	end if
  !
  !
	done = 0%
	    until done		!Loop until done.
  !
  ! Read a tape block then decide what to do with it.
  !
	    gosub read_tape
  !
  ! First check to see if we got a block OK:
  !
	    if tape_status then
		if in_ss then
		    if tape_status = 4% then
			gosub next_volume
		    else
			call bur_wrtmsg( bms_nossend )
			gosub end_ss
			done = -1%
		    end if
		else
		    done = -1%
		end if
  !
  ! OK, we got a block, decide what to do with it:
  !
	    else
		if block_length > 0% then
		    select b_wrd(g$type)
			case t$fil
			    if sel_ss then
				if in_ss = 0% then
				    call bur_wrtmsg( bms_nosstart )
				    block_seq = b_wrd(g$seq)
				    in_ss = -1%
			        end if
				gosub check_seq
				gosub t$fil_block
			    end if
			case t$beg
			    if in_ss then
				call bur_wrtmsg( bms_nossend )
				gosub end_ss
			    end if
			    if done = 0% then
				gosub start_ss
			    end if
			case t$con
			    if in_ss then
				gosub check_seq
				gosub ss_block
			    else
				gosub start_ss
			    end if
			case t$end
			    if sel_ss then
				if in_ss = 0% then
				    call bur_wrtmsg( bms_endnoss )
				else
				    gosub check_seq
				    gosub end_ss
				end if
				gosub ss_block
			    end if
			case t$lbl
			    if sel_ss then
				if in_ss then
				    gosub check_seq
				end if
				print
				print "Volume"; b_wrd(g$rtnm); " of tape: "; &
					bur_get_sixbit( 1%, b_wrd(l$rlnm) )
				status_code = print_sys( l$date, l$dev, l$mtch )
				print
			    end if
			case else
			    if sel_ss then
				if in_ss then
				    gosub check_seq
				end if
			    end if
		    end select
		else
		    if sel_ss then
			print
			print "*** Tape Mark ***"
			print
		    end if
		end if
	    end if
 	!
	    next
	!
	! Well that was easy, we are finished.
	!
	process_tape = ss$_normal
	exit function





 start_ss: !
  !
  ! Handle block containing the start of save set.
  ! Decide whether we want the save set etc:
  !
	ss_name = sb_text( o$ssnm, g$data, b_wrd(g$lnd) )
	if select_ssnm = '' or ss_name = select_ssnm then
	    gosub ss_block
	    block_seq = b_wrd(g$seq)
	    in_ss = -1%
	    sel_ss = -1%
	else
	    status_code = bio_tape_skip( 1% )
	    if (status_code and 1%) = 0% then
		done = 0%
		if status_code = rms$_eof then
		    tape_status = 4%
		    call bur_wrtmsg( bms_ssnotfound )
		else
		    tape_status = 3%
		    call bur_wrtmsg( status_code )
		end if
	    end if
	end if
  !
	return



 end_ss: !
  !
  ! End of save set detected.
  ! Finish with the save set, check we are not
  ! still processing a file etc:
  !
	if in_file then
	    call bur_wrtmsg( bms_endssfile )
	    gosub end_file
	end if
  !
	in_ss = 0%
	if select_ssnm <> '' then
	    sel_ss = 0%
	    done = -1%
	end if
  !
	return



 t$fil_block: !
  !
  !
  ! Handle a t$fil block. If block contains start of file then set up
  ! the file. Next check for any file data and finally check for end of
  ! file. A file can start, contain data, and end all in the same tape
  ! block. The bits in g$flag describe whats going on:
  !
  !
  !
  !
  !					  Check for start of file.
	if bur_flag_set( b_wrd(g$flag), gf$sof by value ) then
	    if in_file then		! New file - check if expected.
		call bur_wrtmsg( bms_fileinfile )
		gosub end_file
	    end if
	    gosub new_file		! Go find file name - attributes etc.
	end if
  !
  !
  !
	if b_wrd(g$siz) > 0% then		! If data in block use it.
	    if in_file = 0% then
		call bur_wrtmsg( bms_midfile )
		gosub new_file
	    end if
	    if b_wrd(f$rdw) <> file_rdw then
		call bur_wrtmsg( bms_filerdwerr )
	    end if
	    file_rdw = b_wrd(f$rdw) + b_wrd(g$siz)
	    if write_file then	! Write data to file.
		    if sixbit_size > 0% then
			call bur_write_sixbit( b_wrd(g$siz),		&
				b_wrd(g$data+b_wrd(g$lnd)*wrdsiz), sixbit_size )
		    else
			call bur_write_ascii( b_wrd(g$siz),		&
				b_wrd(g$data+b_wrd(g$lnd)*wrdsiz) )
		    end if
	    end if
	end if
  !
  !
  !
  !					  Check for end of file.
	if bur_flag_set( b_wrd(g$flag), gf$eof by value ) then
	    if in_file then		! File end - check we have a file.
		gosub end_file
	    else
		call bur_wrtmsg( bms_eofnofile )
	    end if			! File end but no file?
	end if
  !
  !
  !
	return





 new_file: !
  !
  !
  ! Have got a t$fil record containing start of file:-
  ! Extract file name and attributes from block and
  ! see if file is to be selected.
  !
  !
	name_sb = sb_search( o$name, g$data, b_wrd(g$lnd) )
	if name_sb >= 0% then		! Find name block and get name.
	    name_sblen = sb_length - 1%
	    file_name = sb_text( 2%, name_sb+wrdsiz, name_sblen )
	    file_type = sb_text( 3%, name_sb+wrdsiz, name_sblen )
	else
	    file_name = ''			! Oops, no name block?
	    file_type = ''
	    call bur_wrtmsg( bms_noname )
	end if
  !
  !
  ! Now see if the file is on our list of files to select:-
  !
	in_file = -1%
	file_rdw = 0%
	write_file = 0%		! Assume not restoring file.
	if select_file( file_name, file_type, select_files ) then
	    gosub print_dir
	    if sixbit_size > 0% then
		file_alq = ( (file_size+4%)/5%*6% + 511% ) / 512%
	    else
		file_alq = ( file_size + 511% ) / 512%
	    end if
	    if file_alq < 0% then
		file_alq = 0%	! Check initial file size looks valid.
	    end if
	    if restore_flag then
		status_code = bio_file_init( file_name+'.'+file_type,	&
				output_default, file_alq, rms_status )
		if status_code and 1% then
		    write_file = -1%	! We are restoring this file.
		else
		    call bur_wrtmsg( bms_noopen, file_name+'.'+file_type )
		    call bur_wrtmsg( status_code, rms_status )
		end if
	    end if
	end if
  !
  !
	return



 print_dir: !
  !
  ! Get file attributes and print directory information.
  !
  !
  !
	attr_sb = sb_search( o$file, g$data, b_wrd(g$lnd) )
	if attr_sb >= 0% then	! Find attribute block and get atributes.
	    file_size = b_wrd(attr_sb+a$leng)
	    if b_wrd(attr_sb+a$mode) > 1% then  ! .IOASL
		file_size = file_size * 5%
	    end if
	    call bur_chkerr( sys$fao( '!10AS.!4AS !10UL !17AS',		&
		print_length, print_buffer, file_name, file_type,	&
		(file_size+639%)/640% by value,				&
		bur_get_date( b_wrd(attr_sb+a$writ) ) ) )
	else
	    file_size = 0%
	    call bur_chkerr( sys$fao( '!10AS.!4AS *** no attribute information ***', &
		print_length, print_buffer, file_name, file_type ) )
	end if
	print left$(print_buffer,print_length)	! Print directory information.
  !
  !
	return


 end_file: !
  !
  ! Finish with the current file.
  !
	if write_file then
	    call bio_file_close	! Tidy up and close current file.
	end if
	in_file = 0%
  !
	return




 check_seq: !
  !
  !
  ! Increment & check sequence number. If wrong sequence number
  ! in a save set record then something has gone wrong.
  !
	block_seq = block_seq + 1%	! Increment sequence number.
	if b_wrd(g$seq) <> block_seq then
	    call bur_wrtmsg( bms_seqerr )
	    block_seq = b_wrd(g$seq)
	end if
  !
	return





 ss_block: !
  !
  !
  ! Print info from a t$beg, t$con or t$end record.
  !
	print
	select b_wrd(g$type)
	    case t$beg
		print "Start of Save Set: "; ss_name
	    case t$con
		print "Continuation of Save Set: "; ss_name
	    case t$end
		print "End of Save Set: "; ss_name
	    end select
	print "Volume"; b_wrd(g$rtnm);"written by System: ";	&
		sb_text( o$sysn, g$data, b_wrd(g$lnd) )
	status_code = print_sys( s$date, s$dev, s$mtch )
	print
  !
  !
	return








	    

 read_tape: !
  !
  !
  ! Read tape blocks until we get a goodun:-
  !		(or give up)
  ! This means if we get an error we should keep reading until
  ! we get a good block which must have its repeat block flag set.
  !
	retries = 0%
	tape_status = 2%
	    until tape_status <> 2%
	    gosub read_a_block
	    select tape_status
		case 0%
		    if retries > 0% then
			if block_length > 0% and &
				bur_flag_set( b_wrd(g$flag), gf$rpt by value ) then
			    call bur_wrtmsg( bms_gotrptblk )
			else
			    call bur_wrtmsg( bms_norptblk )
			end if
		    else
			if bur_flag_set( b_wrd(g$flag), gf$rpt by value ) then
			    call bur_wrtmsg( bms_ignrptblk )
			    tape_status = 2%
			end if
		    end if
		case 2%
		    call bur_wrtmsg( status_code )
		    retries = retries + 1%
		    if retries > 4% then
			call bur_wrtmsg( bms_excesserrors )
			tape_status = 3%
		    end if
		case 3%
		    call bur_wrtmsg( status_code )
	    end select
	    next
  !
	return



 read_a_block: !
  !
  !
  ! Read a tape block. Check that it seems Ok, unpack it etc.
  ! Returned is tape_status containing one of:-
  !	   -1		tape device is not open for access
  !	    0		normal, tape is open for reading
  !	    1 *		reserved
  !	    2 *		retryable error detected
  !	    3		fatal (or unknown) error detected
  !	    4		reached end of tape
  !	      * not returned from this routine
  !
	status_code = bio_tape_read( block_length, block_address )
  !
	if status_code and 1% then
	    if block_length = 2720% then

		call c36_unpack( 544% by value, block_address by value, b_wrd(0%) )
		call bio_tape_free_buff		! Allow tape buffer to be reused.
		if b_wrd(g$type) >= 0% and b_wrd(g$type) <= t$max then
		    if b_wrd(g$lnd) >= 0% and b_wrd(g$siz) >= 0% and		&
					b_wrd(g$lnd)+b_wrd(g$siz) <= 512% then
			if bur_flag_set( b_wrd(g$flag), gf$nch by value ) then
			    tape_status = 0%
			else
			    block_chk(0%) = b_wrd(g$chk)
			    block_chk(1%) = b_wrd(g$chk+1%)
			    b_wrd(g$chk), b_wrd(g$chk+1%) = 0%
			    call c36_chksum( 544% by value, b_wrd(0%), block_chksum(0%) )
			    if block_chksum(0%) = block_chk(0%) and		&
					block_chksum(1%) = block_chk(1%) then
				tape_status = 0%
			    else
				status_code = bms_chksumerr
				tape_status = 2%
			    end if	! Crummy check sum.
			end if
		    else
			status_code = bms_baddatasize
			tape_status = 2%
		    end if		! g$lnd or g$siz is bad.
		else
		    status_code = bms_badblocktype
		    tape_status = 2%
		end if		! g$type is bad.

	    else
		if block_length = 0% then
		    tape_status = 0%
		else
		    status_code = bms_badrecsize
		    tape_status = 2%
		end if		! Tape block size is bad.
	    end if
	else
	    select status_code
		case rms$_eof
		    tape_status = 4%
		case ss$_parity, ss$_dataoverun
		    tape_status = 2%
		case else
		    tape_status = 3%
	    end select
	end if
  !
	return


 

 next_volume: !
  !
  ! We have reached the end of the tape and are still inside
  ! a Save Set. The best thing to do is ask for another tape
  ! volume:-
  !
  !
	print
	print "*** End of Tape ***"
	print
	print "Another tape volume is required to continue processing of Save Set"
	operator_reply = ""
	status_code = bio_next_volume( tape_status, operator_reply )
	if operator_reply <> "" then
	    print "Operator Reply: "; operator_reply
	end if
	if status_code and 1% then
	    print "10BACKUP is continuing processing of Save Set on new tape volume"
	else
	    if status_code <> rms$_eof then
		call bur_wrtmsg( status_code )
	    else
		if tape_status >= 0% then
		    tape_status = 3%
		end if
	    end if
	    call bur_wrtmsg( bms_nossend )
	    gosub end_ss
	    done = -1%
	end if
	!
	!
	return







  !
  !
  ! Function to print date written, system name, device name etc.
  !
  !
	def long print_sys( long o_date, long o_dev, long o_mtch )
  !
	call bur_chkerr( sys$fao( 'Written on: !AS at: !17AS using: !AS BPI', &
		print_length, print_buffer,			&
		bur_get_sixbit( 1%, b_wrd(o_dev) ),		&
		bur_get_date( b_wrd(o_date) ), 			&
		mid(' 200 556 80016006250',(b_wrd(o_mtch) and 7%)*4%-3%,4%) ) )
	print left$(print_buffer,print_length)
  !
	end def



  !
  !
  ! Function to get ascii text from a particular overhead block:-
  ! Locate the overhead block and pass its contents back as an
  ! ascii string.
  !
	def string sb_text( long sb_find, long sb_position, long sb_words )
	sb_position = sb_search( sb_find, sb_position, sb_words )
	if sb_position > 0% then		! Get text from block.
	    sb_text = bur_get_ascii( sb_length-1%, b_wrd(sb_position+wrdsiz) )
	else
	    sb_text = ''		! Could not find block.
	end if
  !
	end def






  !
  !
  ! Function to locate a particular sub-block:-
  ! Sub-blocks contain overhead information written into
  ! the data area of the block. eg an o$name block.
  ! If the sub-block is found we return its location and implicitly
  ! return sb_length to say how big it is. If sub-the block is not
  ! found we return -1.
  !
	def long sb_search( long sb_find, long sb_position, long sb_words )
	    while sb_words > 0%		! Loop until we give up.
	    call c36_hfwd( b_wrd(sb_position), sb_type, sb_length )
	    if sb_type = sb_find then
		sb_search = sb_position	! Found the block, say where.
		sb_words = 0%
	    else
		if sb_length > 0% then
		    sb_words = sb_words - sb_length
		    if sb_words > 0% then
			sb_position = sb_position + sb_length * wrdsiz
		    else
			sb_search = -1%	! Sub-Block not found.
		    end if
		else
		    sb_search = -1%	! Sub-Block not found.
		    sb_words = 0%
		end if
	    end if
	    next
  !
	end def

	end function











5000	function long select_file( string file_name, string file_type,	&
						string select_files )
  !
  !
  ! This module checks to see if a particular file should be selected.
  ! If the file is to be selected 1 is returned, otherwise 0.
  ! Basically the file name and type are search for in the selected files
  ! list. Function PATTERN_MATCH is called to see if the file name or
  ! file type matches any of the names and types in the select_files
  ! list.
  !
	option type = explicit
  !
  !
  ! Declare internal functions:-
  !
	declare long function pattern_match
	declare					&
		long data_pos,			&
		long pattern_pos,		&
		long star_pos
  !
  !
  ! Declare internal variables:-
  !
	declare					&
		long name_pos,		&
		long name_end,		&
		long type_pos
  !
  !
	if select_files = '' then		! Select specific files?
	    select_file = 1%
	else
	    select_file = 0%
	    name_pos = 1%			! Start position of search.
		until name_pos > len(select_files)
		name_end = pos(select_files,',',name_pos)
		if name_end = 0% then
		    name_end = len(select_files) + 1%
		end if
		type_pos = pos(select_files,'.',name_pos)
		if type_pos = 0% or type_pos > name_end then
		    type_pos = name_end
		end if
		if name_pos >= type_pos-1% then
		    if type_pos = name_end then
			select_file = 1%
			name_end = len(select_files)
		    else
			if pattern_match(file_type,seg$(select_files,type_pos+1%,name_end-1%)) then
			    select_file = 1%
			    name_end = len(select_files)
			end if
		    end if
		else
		    if pattern_match(file_name,seg$(select_files,name_pos,type_pos-1%)) then
			if type_pos = name_end then
			    select_file = 1%
			    name_end = len(select_files)
			else
			    if pattern_match(file_type,seg$(select_files,type_pos+1%,name_end-1%)) then
				select_file = 1%
			        name_end = len(select_files)
			    end if
			end if
		    end if
		end if
		name_pos = name_end + 1%
		next				! Have decided about the file.
	end if
  !
  !
	exit function


  !
  !
  !
  ! Function to handle wildcard pattern matches for file names.
  ! If the match_data matches the pattern then a 1 is returned
  ! otherwise a 0 is returned. This routine is given some data
  ! and a pattern to match. The pattern may contain any number
  ! of * characters for wildcarding. Examples are:
  !
  !		Pattern		Data		Match
  !		=======		====		=====
  !
  !		BILL		FRED		 No
  !		  *		FRED		 Yes
  !		  *ED		FRED		 Yes
  !		BI*ED		FRED		 No
  !		FR*ED		FRED		 Yes
  !		*b*d*f		bdf		 Yes
  !		*b*d*f		abcdef		 Yes
  !		*b*d*f		adcbef		 No
  !
  !
  !
	def long pattern_match( string match_data, string pattern )
  !
	    pattern_match = 0%
	    star_pos = pos( pattern, '*', 1% )
	    if star_pos then
		if left( pattern, star_pos-1% ) = left( match_data, star_pos-1% ) then
		    data_pos = star_pos
		    pattern_pos = star_pos + 1%
			while star_pos
			star_pos = pos( pattern, '*', pattern_pos )
			if star_pos then
			    data_pos = pos( match_data, seg$( pattern, pattern_pos, star_pos-1% ), data_pos )
			    if data_pos then
				data_pos = data_pos + ( star_pos - pattern_pos - 1% )
				pattern_pos = star_pos + 1%
			    else
				star_pos = 0%
			    end if
			else
			    if len(match_data) - data_pos >= len(pattern) - pattern_pos then
				if right(match_data,len(match_data)-len(pattern)+pattern_pos) = right(pattern,pattern_pos) then
				    pattern_match = 1%
				end if
			    end if
			end if
		    next
		end if
	    else
		if pattern = match_data then
		    pattern_match = 1%
		end if
	    end if
  !
  !
	end def

	end function