mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 16:34:07 +00:00
380 lines
10 KiB
ObjectPascal
380 lines
10 KiB
ObjectPascal
(*************************************************************************)
|
|
(* *)
|
|
(* DOS-TO-CPM v1.00 (c) Copyright S.J.Kay 18th April 1995 *)
|
|
(* *)
|
|
(* Copys DOS files to CP/M *)
|
|
(* *)
|
|
(*************************************************************************)
|
|
|
|
{ WARNING - Make sure the END address is lowered to say about $8000 }
|
|
{ before compiling to disk otherwise it will crash when used from }
|
|
{ within a SUBMIT file. This happens to any TURBO v2.00a compiled }
|
|
{ program because it does not check the TPA size !. }
|
|
|
|
{ As TURBO v2.00a compiled programs overwrite part of the command }
|
|
{ line parameters (only 1st 31 characters are intact) make sure that }
|
|
{ FIXTURBO.COM is run on this compiled program to allow full access }
|
|
{ to command line parameters. }
|
|
|
|
{$C-} { turn off ^C and ^S checking }
|
|
|
|
const
|
|
ComLne : string[127] = 'PARAMETERS'; { filled in by patch code }
|
|
|
|
ENDBUF = $3FFF; { 16 K copy buffer }
|
|
TMPFLE = 'DOSTOCPM.$$$';
|
|
|
|
type
|
|
String13 = string[13];
|
|
String127 = string[127];
|
|
|
|
registers = record
|
|
case boolean of
|
|
true : (AL, AH, BL, BH, CL, CH, DL, DH : byte);
|
|
false : (AX, BX, CX, DX,
|
|
BP, SI, DI, DS, ES, FLAGS : integer)
|
|
end;
|
|
|
|
|
|
var
|
|
R : registers;
|
|
F : file;
|
|
Buffer : array [0..ENDBUF] of byte;
|
|
DTA : array [0..42] of byte;
|
|
DirSpc : array [0..79] of byte;
|
|
FleSpc : array [0..79] of byte;
|
|
DirMsk : String127;
|
|
DOSPth : String127;
|
|
CPMPth : String127;
|
|
|
|
Quiet : boolean;
|
|
ChkWrt : boolean;
|
|
OvrWrt : boolean;
|
|
FleHnd : integer;
|
|
Error : integer;
|
|
|
|
|
|
procedure ProcZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer);
|
|
begin
|
|
inline
|
|
(
|
|
$3A/Fn/ { ld a,(Fn) }
|
|
$32/* + 17/ { ld (FNCNMB),a }
|
|
$3A/Ax/ { ld a,(Ax) }
|
|
$ED/$4B/BCx/ { ld bc,(BCx) }
|
|
$ED/$5B/DEx/ { ld de,(DEx) }
|
|
$2A/HLx/ { ld hl,(HLx) }
|
|
$D3/$FF { out (FNCNMB),a }
|
|
)
|
|
end;
|
|
|
|
|
|
procedure Intr (Int : byte; var R : registers);
|
|
begin
|
|
ProcZ80($A1, Int, $AA55, $55AA, addr(R))
|
|
end;
|
|
|
|
|
|
procedure Msdos (var R : registers);
|
|
begin
|
|
Intr($21, R)
|
|
end;
|
|
|
|
|
|
function Seg (var Dummy) : integer;
|
|
const
|
|
SegAdr : integer = 0;
|
|
begin
|
|
ProcZ80($A0, 0, 0, 0, addr(SegAdr));
|
|
Seg := SegAdr
|
|
end;
|
|
|
|
|
|
function Ofs (var VarTyp) : integer;
|
|
begin
|
|
Ofs := addr(VarTyp)
|
|
end;
|
|
|
|
|
|
function FileFound (FstDir : boolean) : boolean;
|
|
begin
|
|
R.AH := $1A; { set DTA function }
|
|
R.DS := seg(DTA);
|
|
R.DX := ofs(DTA);
|
|
Msdos(R);
|
|
if FstDir then
|
|
R.AH := $4E { search for first function }
|
|
else
|
|
R.AH := $4F; { search for next function }
|
|
R.CX := 0;
|
|
R.DS := seg(DirSpc);
|
|
R.DX := ofs(DirSpc);
|
|
Msdos(R);
|
|
FileFound := not odd(R.Flags);
|
|
if FstDir and odd(R.Flags) then
|
|
writeln('No files found to match: ', DirMsk)
|
|
end;
|
|
|
|
|
|
procedure OpenFiles (FleNme : String13);
|
|
var
|
|
TmpStr : String127;
|
|
UsrRes : string[1];
|
|
Result : integer;
|
|
begin
|
|
if not Quiet then
|
|
writeln('Copying: ', FleNme);
|
|
TmpStr := DOSPth + FleNme;
|
|
move(TmpStr[1], FleSpc, length(TmpStr));
|
|
FleSpc[length(TmpStr)] := 0;
|
|
R.AH := $3D; { open file function }
|
|
R.AL := $00; { read access }
|
|
R.DS := seg(FleSpc);
|
|
R.DX := ofs(FleSpc);
|
|
Msdos(R); { open DOS file for reading }
|
|
Error := R.Flags and 1;
|
|
if Error = 0 then
|
|
begin
|
|
FleHnd := R.AX; { file handle }
|
|
OvrWrt := true;
|
|
{$I-}
|
|
if ChkWrt then
|
|
begin
|
|
assign(F, CPMPth + FleNme);
|
|
reset(F); { does file exist ? }
|
|
if ioresult = 0 then
|
|
begin
|
|
close(F);
|
|
Result := ioresult;
|
|
write('Overwrite ', CPMPth, FleNme, ' ? (y/n): ');
|
|
readln(UsrRes);
|
|
OvrWrt := (UsrRes = 'y') or (UsrRes = 'Y')
|
|
end
|
|
end;
|
|
if OvrWrt then
|
|
begin
|
|
assign(F, CPMPth + TMPFLE);
|
|
rewrite(F); { open temporary CP/M file for writing }
|
|
Error := ioresult;
|
|
if Error <> 0 then
|
|
writeln('Error CP/M disk directory full')
|
|
end
|
|
{$I+}
|
|
end
|
|
else
|
|
writeln('Error opening DOS file for reading')
|
|
end;
|
|
|
|
|
|
procedure CloseFiles (FleNme : String13);
|
|
var
|
|
Result : integer;
|
|
begin
|
|
R.AH := $3E; { close file function }
|
|
R.BX := FleHnd; { file handle }
|
|
Msdos(R); { close DOS file }
|
|
Error := R.Flags and 1;
|
|
if Error <> 0 then
|
|
writeln('Error closing DOS source file');
|
|
if OvrWrt and (Error = 0) then
|
|
begin
|
|
{$I-}
|
|
close(F); { close temporary CP/M file }
|
|
Error := ioresult;
|
|
if Error = 0 then
|
|
begin
|
|
assign(F, CPMPth + FleNme);
|
|
erase(F);
|
|
Result := ioresult;
|
|
assign(F, CPMPth + TMPFLE);
|
|
rename(F, CPMPth + FleNme);
|
|
Error := ioresult;
|
|
if Error <> 0 then
|
|
writeln('Error renaming temporary CP/M file')
|
|
end
|
|
else
|
|
writeln('Error closing temporary CP/M file')
|
|
end
|
|
{$I+}
|
|
end;
|
|
|
|
|
|
procedure CopyFile (FleNme : String13);
|
|
var
|
|
EndFle : boolean;
|
|
Blocks : integer;
|
|
begin
|
|
repeat
|
|
R.AH := $3F; { read file or device function }
|
|
R.BX := FleHnd; { file handle }
|
|
R.CX := ENDBUF+1; { bytes to read }
|
|
R.DS := seg(Buffer);
|
|
R.DX := ofs(Buffer);
|
|
Msdos(R); { read data from DOS file }
|
|
Error := R.Flags and 1;
|
|
if Error = 0 then
|
|
begin
|
|
Blocks := (R.AX + 127) div 128;
|
|
EndFle := R.AX < (ENDBUF + 1);
|
|
if EndFle then
|
|
Buffer[R.AX] := ord(^Z);
|
|
{$I-}
|
|
blockwrite(F, Buffer, Blocks); { write to CP/M file }
|
|
Error := ioresult;
|
|
if Error <> 0 then
|
|
writeln('Error CP/M disk full')
|
|
{$I+}
|
|
end
|
|
else
|
|
writeln('Error reading DOS file')
|
|
until EndFle or (Error <> 0)
|
|
end;
|
|
|
|
|
|
procedure TransferFiles;
|
|
var
|
|
FstDir, Found : boolean;
|
|
FleNme : String13;
|
|
i : integer;
|
|
begin
|
|
DOSPth := DirMsk;
|
|
i := length(DOSPth);
|
|
while (i > 0) and (not (DOSPth[i] in ['\', ':'])) do
|
|
i := i - 1;
|
|
DOSPth[0] := chr(i);
|
|
move(DirMsk[1], DirSpc, length(DirMsk));
|
|
DirSpc[length(DirMsk)] := 0;
|
|
FstDir := true;
|
|
while FileFound(FstDir) and (Error = 0) do
|
|
begin
|
|
FstDir := false;
|
|
i := 0;
|
|
FleNme := '';
|
|
while (i < 13) and (DTA[$1E+i] <> 0) do
|
|
begin
|
|
FleNme := FleNme + chr(DTA[$1E+i]);
|
|
i := i + 1
|
|
end;
|
|
OpenFiles(FleNme);
|
|
if OvrWrt and (Error = 0) then
|
|
CopyFile(FleNme);
|
|
if Error = 0 then
|
|
CloseFiles(FleNme)
|
|
end
|
|
end;
|
|
|
|
|
|
function ParmCount : integer;
|
|
var
|
|
i, PrmCnt, PrmLen : integer;
|
|
begin
|
|
i := 1;
|
|
PrmCnt := 0;
|
|
PrmLen := length(ComLne);
|
|
while i <= PrmLen do
|
|
begin
|
|
while (i <= PrmLen) and (ComLne[i] = ' ') do
|
|
i := i + 1;
|
|
if i <= PrmLen then
|
|
PrmCnt := PrmCnt + 1;
|
|
if ComLne[i] = '/' then
|
|
i := i + 1;
|
|
while (i <= PrmLen) and (not(ComLne[i] in [' ', '/'])) do
|
|
i := i + 1
|
|
end;
|
|
ParmCount := PrmCnt
|
|
end;
|
|
|
|
|
|
function ParamStr (PrmNmb : integer) : String127;
|
|
var
|
|
i, PrmCnt, PrmLen : integer;
|
|
PrmStr : string[127];
|
|
begin
|
|
i := 1;
|
|
PrmCnt := 0;
|
|
PrmStr := '';
|
|
PrmLen := length(ComLne);
|
|
while (i <= PrmLen) and (PrmCnt < PrmNmb) do
|
|
begin
|
|
while (i <= PrmLen) AND (ComLne[i] = ' ') do
|
|
i := i + 1;
|
|
if i <= PrmLen then
|
|
PrmCnt := PrmCnt + 1;
|
|
if ComLne[i] = '/' then
|
|
begin
|
|
PrmStr := '/';
|
|
i := i + 1
|
|
end
|
|
else
|
|
PrmStr := '';
|
|
while (i <= PrmLen) and (not (ComLne[i] in [' ', '/'])) do
|
|
begin
|
|
PrmStr := PrmStr + ComLne[i];
|
|
i := i + 1
|
|
end
|
|
end;
|
|
ParamStr := PrmStr
|
|
end;
|
|
|
|
|
|
function ScanForSwitches (PrmNmb : integer) : integer;
|
|
var
|
|
SwtStr : String127;
|
|
SwtPos, i : integer;
|
|
begin
|
|
repeat
|
|
SwtStr := ParamStr(PrmNmb);
|
|
SwtPos := pos('/', SwtStr);
|
|
if Swtpos <> 0 then
|
|
begin
|
|
PrmNmb := PrmNmb - 1;
|
|
delete(SwtStr, 1, 1);
|
|
for i := 1 to length(SwtStr) do
|
|
SwtStr[i] := upcase(SwtStr[i]);
|
|
if SwtStr = 'Q' then
|
|
Quiet := true;
|
|
if SwtStr = 'F' then
|
|
ChkWrt := false
|
|
end
|
|
until SwtPos = 0;
|
|
ScanForSwitches := PrmNmb
|
|
end;
|
|
|
|
|
|
procedure ShowUsage;
|
|
begin
|
|
writeln;
|
|
writeln('DOS-TO-CPM v1.00 (c) Copyright S.J.Kay 18th April 1995');
|
|
writeln;
|
|
writeln('Use:- dostocpm (d:\path\files) (d:\path\files)... c: [/f/q]');
|
|
writeln;
|
|
writeln('d:\path\files = DOS drive, path and files');
|
|
writeln(' c: = CP/M drive path');
|
|
writeln(' /f = force overwriting of existing file(s)');
|
|
writeln(' /q = quiet, no display of file names')
|
|
end;
|
|
|
|
|
|
var
|
|
PrmTot, PrmNmb : integer;
|
|
SwtStr : String127;
|
|
begin
|
|
Quiet := false;
|
|
ChkWrt := true;
|
|
Error := 0;
|
|
PrmNmb := 1;
|
|
PrmTot := ScanForSwitches(ParmCount);
|
|
CpmPth := ParamStr(PrmTot);
|
|
if PrmTot > 1 then
|
|
begin
|
|
repeat
|
|
DirMsk := ParamStr(PrmNmb);
|
|
PrmNmb := PrmNmb + 1;
|
|
TransferFiles
|
|
until (PrmNmb >= PrmTot) or (Error <> 0)
|
|
end
|
|
else
|
|
ShowUsage
|
|
end.
|