subroutine rpl

C.. RPL - Replace File Copy.
C..
C.. Copyright (c) 1987, Richard A. Holmes (aka Holmes Compleat Computing)
C.. 4845 San Sebastian Avenue
C.. Las Vegas, Nevada 89121
C.. (702) 458-4933
C..
C.. Public domain.  Permission is hereby granted for non-commercial use
C.. and distribution of this program.  No warranties, guarantees or promises
C.. are made as to its functioning.  It works for me.  If you find it 
C.. useful, you may feel free to send $5.00 to the above address.
C..
C.. This program is used to copy a disk file to another disk file.
C.. If the destination file already exists, it will be overwritten with
C.. the new one.  It is neither first deleted and then created, nor is 
C.. any renaming performed.  This is useful to copy new versions of 
C.. programs onto a carefully laid out disk.  If the new file is longer
C.. than the old one, first (nominally) 4K of disk space is reserved
C.. (presumably on the inner tracks) and then the new sectors will
C.. come from CP/Ms standard allocation of disk space.  If the old file
C.. is longer than the new file, unused sectors will exist at the end
C.. of the file.

C.. If you modify this code, please don't use REAL variables or
C.. any sort of FORTRAN Reads or Writes.

	include rpl.dcl
	integer fcount
	include rpl.blk
	data fcount /0/, nomore /.false./

C.. Say hi.
	call strout('RPL - Replace Copy V1.0 $')
	call strend('   (c) 1987, Holmes Compleat Computing$')
C.. General program initialization.
	call inirun
C.. Copy the file(s).
100	continue
	call setfil(nomore)
	if (nomore) go to 200
	call cpyini
	call copy
	fcount = fcount + 1
	if (ambig) go to 100

C.. That's all folks.
200	continue
	call endrun
	end


	subroutine copy

C.. This feller does the copying of the file.

	integer size,inrec,outrec,maxsec,curptr,cur1,cursec
	byte rsectr,stat,wsectr
	include rpl.dcl
	include rpl.blk

C.. Open the input file.
	call setusr(iuser)
	call opin
C.. Open the output file.
	call setusr(ouser)
	call opout
C.. Initialize the counters.
	maxsec = 100
	inrec = -1
	outrec = -1
90	continue
	call setusr(iuser)
	curptr = -128
	cursec = 0
100	continue
	curptr = curptr + 128
	if (curptr.ge.12800) go to 110
	inrec = inrec + 1
	stat = rsectr(curptr,inrec)
	if (stat.lt.0) go to 900
	if (stat.gt.0) go to 800
	cursec = cursec + 1
	go to 100

C.. The buffer filled up.  Write it to disk.
110	continue
	call setusr(ouser)
	curptr = -128
	do 120 i = 1,maxsec
	outrec = outrec + 1
	curptr = curptr + 128
	stat = wsectr(curptr,outrec)
	if (stat.ne.0) go to 700
115	continue
120	continue
	go to 90

C.. Error on writing.
700	continue
	call ioerr(stat)
	call chrout(10)
	call chrout(13)
	call strout (' Unknown I/O error $')
	call decbyt(stat)
	call strout(' in writing sector $')
	call decint(outrec)
	call strend('$')
	call endrun

C.. Error on reading.
800	continue
	call ioerr(stat)
	call strout (' Unknown I/O error $')
	call decbyt(stat)
	call strout(' in reading sector $')
	call decint(outrec)
	call strend('$')
	call endrun

C.. End of file on input.  Flush out the buffer.
900	continue
	call setusr(ouser)
	inrec = inrec - 1
	if (curptr.le.0) go to 920
	curptr = -128

	do 910 i = 1,cursec
	curptr = curptr + 128
	outrec = outrec + 1
	stat = wsectr(curptr,outrec)
	if (stat.ne.0) go to 700
910	continue

C.. Close the output file.
920	continue
	call setusr(ouser)
	call clout
C.. Report on status of copy.
	if (insize.eq.osize) go to 930
	call strout('  --  $')
	if (insize.gt.osize) go to 940
	if ((osize-insize).ne.1) go to 925
	call strend('1 unused sector exists.$')
	go to 990

925	continue	
	call decint(osize - insize)
	call strend(' unused sectors exist.$')
	go to 990

C.. Both files had the same size.
930	continue
	if (insize.ne.0) go to 935
	call strend('  --  File is vacuous.$')
	go to 990

935	continue
	call strend('$')
	go to 990

940	continue
	if (insize-osize.ne.1) go to 950
	call strend('1 new sector written.$')
	go to 990

950	continue
	call decint(insize-osize)
	call strend(' new sectors written.$')
990	continue
	return
	end


	subroutine ioerr(stat)

C.. Show what an I/O error means.  End program if code is known.
C.. Return otherwise.

	byte stat

	if ((stat.lt.1).or.(stat.gt.6)) return
	call chrout(13)
	call chrout(10)
	call strout(' I/O error - $')
	if (stat.eq.1) call strend
     +	        ('reading unwritten data.$')
	if (stat.eq.2) call strend
     +		('disk is full.$')
	if (stat.eq.3) call strend
     +		('cannot close current extent.$')
	if (stat.eq.4) call strend
     +		('seek to unwritten extent.$')
	if (stat.eq.5) call strend
     +		('directory space exhaused.$')
	if (stat.eq.6) call strend
     +		('seek past physical end of disk.$')
	call endrun
	end


	subroutine inirun

C.. Parse the command string.

	include rpl.dcl
	byte blank,peek,sfirst,status,str(7),stat
	byte svfile(11)
	integer start,maxpos,ksize,fsize,reserv
	logical iambig,oambig,badopt
	common /svfile/svfile /reserv/ reserv
	include rpl.blk

	include rpl.dat
	data blank /1h /
	data str /6*1h ,1h$/
	data ambig /.false./

C.. Start picking characters from 82H in memory.
	start = x'82'

C.. Set the maximum position to be examined.
	maxpos = peek(x'80')
	maxpos = maxpos + 128
C.. Get the output file specification.
	call fspec(outfil,outdev,start,maxpos,ouser,oambig)
	if (oambig) go to 80
	if ((outdev.eq.0).and.(outfil(1).eq.blank)) go to 80
C.. Get the input file specifications.
	call fspec(infile,indev,start,maxpos,iuser,iambig)
	if (.not.iambig) go to 60
	if (outfil(1).ne.blank) go to 80
	ambig = .true.
	do 50 i = 1,11
	svfile(i) = infile(i)
50	continue

C.. The source file may not be omitted.
60	continue
	if (infile(1).ne.blank) go to 90
C.. Give mini-help on syntax type errors.
80	continue
	call help
	call endrun

C.. If the destination file was omitted, copy the input file spec.
90	continue
	if (outfil(1).ne.blank) go to 200
	do 100 i = 1,11
	outfil(i) = infile(i)
100	continue

C.. Check out the options.

200	continue
	badopt = .false.
   	call setopt(start,maxpos,badopt)
	if (badopt) go to 80
	if (ambig) call makres(reserv)
	return
	end


	subroutine cpyini

C.. Initialize for a file copy.

	byte status,sfirst
	integer fsize,reserv
	include rpl.dcl
	common /reserv/ reserv
	include rpl.blk

C.. See if the input file exists.
200	continue
	call setusr(iuser)
	status = sfirst(indev,infile)
	if (status.eq.-1) call error(' No files matched.$')

300	continue
	osize = 0
	insize = fsize(indev,infile)

C.. Determine how big the output file is now.
	call setusr(ouser)
	status = sfirst(outdev,outfil)
	if (status.eq.-1) go to 350
	osize = fsize(outdev,outfil)
350	continue
	call strout(' ($')
	call decint((insize+7)/8)
	call strout('k)$')
C.. Reserve space if necessary.
	if ((.not.ambig).and.(insize.gt.osize)) call makres(reserv)
	return
	end


	subroutine fspec(filnam,device,start,maxpos,usrnum,ambig)

C.. This routine will extract a file specification from the command line.

	byte filnam(11),device,peek,equals,blank,dot,aa,char,colon
	byte usrnum,aster,hook
	integer start,pos,maxpos
	logical ambig
	data equals,blank,dot /1h=,1h ,1h./, aa /1hA/, colon /1h:/
	data aster,hook /1h*,1h?/

	ambig = .false.
	do 50 i = 1,11
	filnam(i) = blank
50	continue

C.. POS will reflect the current position in the command line.
	pos = start
C.. Get the device and user number.
	call getdu(device,usrnum,pos,maxpos)
	if (pos.gt.maxpos) go to 600
C.. Gather up the file name.
	do 300 i = 1,9
	char = peek(pos)
C.. Check for ambiguous file name.
	if (char.eq.hook) ambig = .true.
	if (char.ne.aster) go to 70
	do 60 ii = i,8
	filnam(ii) = hook
60	continue
	ambig = .true.
	go to 80

C.. Blanks and equals terminate the file name.
70	continue
	if ((char.eq.blank).or.(char.eq.equals)) go to 500
C.. Dots start the extension.
	if (char.eq.dot) go to 400
	filnam(i) = char
80	continue
	pos = pos + 1
	if (pos.gt.maxpos) go to 600
300	continue
	call error(' File name is too long.$')
C.. Put together the file extension.
400	continue
	pos = pos + 1
	if (pos.gt.maxpos) go to 600
	do 450 i = 1,3
	char = peek(pos)
	if (char.eq.hook) ambig = .true.
	if (char.ne.aster)go to 420
	do 410 ii = i,3
	filnam(ii+8) = hook
410	continue
	ambig = .true.
	go to 430

420	continue
	if ((char.eq.blank).or.(char.eq.equals)) go to 500
	filnam(i+8) = char
430	continue
	pos = pos + 1
	if (pos.gt.maxpos) go to 600
450	continue

C.. The end of the file spec was found.
500	continue
600	continue
	pos = pos + 1
510	continue
	start = pos
	return
	end


	subroutine getdu(device,usrnum,pos,maxpos)

C.. Get device and usernumber of a file.

	byte device,usrnum,char,peek,char0,char9,chara,charp,colon
	integer pos,maxpos
	data char0,char9,chara,charp,colon /1h0,1h9,1hA,1hP,1h:/

C.. Default drive.
	call getdev(device)
C.. Get current user number.
	call getusr(usrnum)
	if (pos.gt.maxpos) go to 900
C.. We should see a colon in the first four characters.
	do 10 i = 0,3
	if (peek(pos+i).eq.colon) go to 20
10	continue
	go to 900

C.. Get the user number and device.
20	continue
	if (pos.gt.maxpos)go to 900
	char = peek(pos)
	pos = pos + 1
	if (char.eq.colon) go to 900
	if (char.lt.char0) go to 40
	if (char.gt.char9) go to 30
	usrnum = usrnum*10 + (char-char0)
	go to 20

30	continue
	if ((char.ge.chara).and.(char.le.charp)) go to 50
40	continue
	call error('Bad device/user specified.$')

50	continue
	device = char - chara + 1
	go to 20

900	continue
	if ((usrnum.gt.15).or.(usrnum.lt.0))
     +		call error (' User number is out of range.$')
	return
	end


	subroutine encdxx(string,positn,value)

C.. This routine will encode the provided VALUE into a decimal
C.. string of characters, stored in STRING, with the leftmost
C.. in column POSITN.  Leading blanks are used.  Three digitss
C.. are always used.  VALUE is treated as an unsigned, integer
C.. value.  Value are obviously limited to 0 through 999.

	byte string(1),positn,zero,blank,d1,d2,d3
	byte ascii(10)
	integer int,value
	data zero,blank /1h0,1h /,ascii/1h0,1h1,1h2,1h3,1h4,
     +		1h5,1h6,1h7,1h8,1h9/

C.. Isolate the individual digits.
	int = value
	d1 = int / 100
	d2 = (int - d1*100) / 10
	d3 = int / 10
	d3 = int - (d2*10) - (d1*100)
C.. Convert the digits to ASCII characters.
	d1 = ascii(d1+1)
	d2 = ascii(d2+1)
	d3 = ascii(d3+1)
C.. Blank fill the leading zeros.
	if (d1.ne.ascii(1)) go to 100
	d1 = blank
	if (d2.ne.ascii(1)) go to 100
	d2 = blank
100	continue
C.. Fill the characters in the user area.
	string(positn) = d1
	string(positn+1) = d2
	string(positn+2) = d3
	return

	end


	subroutine encod6(string,pos,value)

C.. This routine will convert a integer value to
C.. ASCII for displaying.  It is like ENCODE, but
C.. uses six character positions.

	byte string(1),pos,chzero,blank,pos1
	integer value,part1,part2
	data chzero,blank/1h0,1h /

C.. Isolate the two parts. (The base routine can handle
C.. exactly three digits.)
	part1 = value / 1000
	part2 = value - (part1 * 1000)
	pos1 = pos + 5
C.. Clear out the whole message area.
	do 100 i = pos,pos1
	string(i) = blank
100	continue
C.. Fill in the bottom three characters.
	call encdxx(string,pos+3,part2)
C.. If the top three digits are all zero, we are done.
	if (part1.eq.0) go to 900
C.. Change leading blanks in the bottom three positions
C.. to zeros.
	if (string(pos+4).eq.blank) string(pos+4) = chzero
	if (string(pos+3).eq.blank) string(pos+3) = chzero
C.. Now do the top three digits.
	call encdxx(string,pos,part1)
900	continue
	return
	end


	subroutine decint(value)

C.. Show integer in decimal form.

	integer value
	byte str(7),blank
	data str /6*1h ,1h$/,blank /1h /

	call encod6(str,1,value)
	do 100 i = 1,6
	if (str(i).ne.blank) go to 200
100	continue
200	continue
	call strout(str(i))
	return
	end
	

	subroutine decbyt(byte)

C.. Show byte in decimal form.

	byte byte
	integer value,mask
	data mask /x'00ff'/

	value = byte
	value = value.and.mask
	call decint(value)
	return
	end


	subroutine setfil(nomore)

C.. This routine will set up the input and output FCBs 
C.. from the next file found which matches the ambiguous
C.. specification from the user.  When no more match, 
C.. NOMORE is returned true.

	include rpl.dcl
	logical nomore,first
	integer dirptr,fcount,reserv
	byte amb1st,ambnxt,code,nofile,blank,chara,status,sfirst
	byte svfile(11),fcb(36),dirsec(128)
	include rpl.blk
	common /svfile/svfile /reserv/ reserv

	data first /.true./,nofile /x'ff'/
	data fcb /36*0/,blank /1h /,chara /1hA/

	nomore = .false.
	if (ambig) go to 10
C.. This is not an ambiguous run.  Allow only one pass through here.
	nomore = .true.
	if (.not.first) return
	nomore = .false.
	first = .false.
C.. Make sure that the file exists.
	call setusr(iuser)
	status = sfirst(indev,infile)
	if (status.ne.-1) go to 500
	call strend('Input file does not exist.$')
	call chrout(7)
	call endrun

C.. This is an ambiguous run.  The source file had wildcards.
10	continue
	if (.not.first) go to 400
C.. On the first call, scan through the directory for the specified
C.. user and build a list of matching file names.  Up to 255 are allowed.
	call setusr(iuser)
	do 50 i = 1,11
	fcb(i+1) = svfile(i)
50	continue
	fcb(1) = indev
	first = .false.
	fcount = 0
C.. Find the first file using the ambiguous specification.
	code = amb1st(fcb)
	go to 200

C.. Find the next file.
100	continue
	code = ambnxt(fcb)
200	continue
	if (code.ne.nofile) go to 250
	go to 350

C.. A file was found.  Copy the file name from the directory sector.
250	continue
	dirptr = code*32
	do 300 i = 1,11
	infile(i) = peek(x'81'+dirptr)
	dirptr = dirptr + 1
300	continue
C.. Stash the file name in the list.
	call putfil(infile)
	fcount = fcount + 1
	go to 100

C.. If more than one file matched, tell ahead of time how many
C.. files will be processed.
350	continue
	if (fcount.eq.0) go to 360
	if (fcount.eq.1) go to 370
	call strout(' $')
	call decint(fcount)
	call strend(' files will be processed.$')
	go to 400

C.. No files found in an wildcard specification.
360	continue
	call strend('No such file.$')
	call endrun

370	continue
CCC	call strend(' 1 file will be processed.$')

C.. Reserve the saved space now.
380	continue
	call makres(reserv)

C.. This run used ambiguous filespec.  The file list has been build.
C.. Extract the next file name.
400	continue
	call getfil(infile)
	do 450 i = 1,11
	outfil(i) = infile(i)
450	continue
	if (infile(1).ne.0) go to 500
	nomore = .true.
	return

C.. Make sure we don't copy back onto ourself.  This works ok but
C.. is senseless.
500	continue
	if (indev.ne.outdev) go to 550
	if (ouser.ne.iuser) go to 550
	do 520 i = 1,11
	if (outfil(i).ne.infile(i)) go to 550
520	continue
	call error (' Identity copy ignored.$')

C.. Tell what is going on.
550	continue
	call strout(' Copying $')
	call chrout(outdev + chara-1)
	call decbyt(ouser)
	call chrout(':')
	call shofil(outfil)
	call strout(' <-- $')
	call chrout(indev + chara-1)
	call decbyt(iuser)
	call strout(':$')
	call shofil(infile)
	return
	end


	subroutine shofil(name)

C.. This routine sends a file spec to the display.

	byte name(11),blank 
	data blank /1h /

	do 100 i = 1,8
	if (name(i).ne.blank) call chrout(name(i))
100	continue
	if ((name(9).eq.blank).and.(name(10).eq.blank).and.
     +		(name(11).eq.blank)) return
	call chrout('.')
	do 200 i = 9,11
	if (name(i).ne.blank) call chrout(name(i))
200	continue
	return
	end


	subroutine setopt(start,maxpos,error)

C.. This routine parses the options following the source file spec.
C.. If I knew how to do it, I would allow "T" to indicate trimming
C.. off of extra sectors.  "-T" would turn off trimming.  If you come
C.. up with a good way to do it, please let me know.

	byte ch0,ch9,cht,dash,chk,blank,dollar
	byte peek,char
	integer reserv,pos,start,maxpos,defres
	logical trim,error

	common /trim/ trim
	common /reserv/ reserv

	data ch0,ch9,chk,cht,dash,blank,dollar
     +			 /1h0,1h9,1hK,1hT,1h-,1h ,1h$/
	data trim /.true./
C.. Change DEFRES on the next line for a new default reserve size.
	data reserv /0/,defres/4/

	pos = start
	error = .false.
C.. See if we are already beyond the end of line
	if (pos.gt.maxpos) go to 800
C.. Ignore leading blanks and wait for a dollar sign.
10	continue
	if (peek(pos).ne.blank) go to 20
	pos = pos + 1
	if (pos.gt.maxpos) go to 800
20	continue
	if (peek(pos).ne.dollar) go to 900
C.. We have the dollar sign.  Check out what is after it.
100	continue
	pos = pos + 1
	if (pos.gt.maxpos) go to 800
	char = peek(pos)
CCC	if (char.eq.cht) go to 200
CCC	if (char.eq.dash) go to 300
	if ((char.ge.ch0).and.(char.le.ch9)) go to 400
	if (char.eq.chk) go to 100
	go to 900

C.. T - set trim status active (the default).
CCC200	continue
CCC	go to 100

C.. minus sign, turn off trim.
CCC300	continue
CCC	trim = .false.
CCC	go to 100

C.. Number.  Build up the reserve space amount.
400	continue
	reserv = reserv*10 + (char - ch0)
	go to 100

800	continue
	if (reserv.eq.0) reserv = defres
	return

C.. Invalid something was found.
900	continue
	error = .true.
	return
	end