mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-24 08:54:17 +00:00
Upload
Digital Research
This commit is contained in:
310
CONTRIBUTIONS/z80em86/support/dosdir.pas
Normal file
310
CONTRIBUTIONS/z80em86/support/dosdir.pas
Normal file
@@ -0,0 +1,310 @@
|
||||
(*************************************************************************)
|
||||
(* *)
|
||||
(* DOSDIR v1.00 (c) Copyright S.J.Kay 24th April 1995 *)
|
||||
(* *)
|
||||
(* Displays a directory of DOS disks *)
|
||||
(* *)
|
||||
(*************************************************************************)
|
||||
|
||||
{ WARNING - Make sure the END address is lowered to say about $5000 }
|
||||
{ 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 }
|
||||
|
||||
type
|
||||
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;
|
||||
|
||||
String14 = string[14];
|
||||
String127 = string[127];
|
||||
|
||||
var
|
||||
R : registers;
|
||||
DTA : array [0..42] of byte; { Data Transfer Area Buffer }
|
||||
DirSpc : array [0..126] of byte;
|
||||
DirPrm : String127;
|
||||
DirPth : String127;
|
||||
DirMsk : String127;
|
||||
DirDrv : byte;
|
||||
DirChr : char;
|
||||
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;
|
||||
|
||||
|
||||
procedure TestExtendedError;
|
||||
begin
|
||||
if odd(R.FLAGS) then
|
||||
begin
|
||||
R.AH := $59;
|
||||
R.BX := $00;
|
||||
Msdos(R);
|
||||
if (R.AL <> 0) and (R.AL <> 18) then
|
||||
begin
|
||||
Error := R.AL;
|
||||
writeln;
|
||||
case Error of
|
||||
3 : writeln('Path not found');
|
||||
15 : writeln('Invalid drive specification');
|
||||
83 : writeln('Failed on DOS int 24H (critical error)')
|
||||
else
|
||||
writeln('Error occurred, code: ', Error, ' (dec)')
|
||||
end
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
function EntryFound (FstDir : boolean; AtrTyp : byte) : boolean;
|
||||
begin
|
||||
if FstDir then
|
||||
R.AH := $4E { search for first function }
|
||||
else
|
||||
R.AH := $4F; { search for next function }
|
||||
R.CX := AtrTyp; { attribute type }
|
||||
R.DS := seg(DirSpc);
|
||||
R.DX := ofs(DirSpc);
|
||||
Msdos(R);
|
||||
EntryFound := not odd(R.Flags);
|
||||
TestExtendedError
|
||||
end;
|
||||
|
||||
|
||||
procedure ExtractName (var FleNme : String14);
|
||||
var
|
||||
SubTyp, VolTyp : boolean;
|
||||
i : integer;
|
||||
begin
|
||||
SubTyp := (DTA[$15] and $10) <> 0;
|
||||
VolTyp := (DTA[$15] and $08) <> 0;
|
||||
i := 0;
|
||||
if not SubTyp then
|
||||
FleNme := ''
|
||||
else
|
||||
FleNme := '[';
|
||||
while (i < 12) and (DTA[$1E+i] <> 0) do
|
||||
begin
|
||||
if (chr(DTA[$1E+i]) = '.') and VolTyp then
|
||||
i := i + 1
|
||||
else
|
||||
begin
|
||||
FleNme := FleNme + chr(DTA[$1E+i]);
|
||||
i := i + 1
|
||||
end
|
||||
end;
|
||||
if SubTyp then
|
||||
FleNme := FleNme + ']'
|
||||
end;
|
||||
|
||||
|
||||
procedure VolumeLabel;
|
||||
var
|
||||
FleNme : String14;
|
||||
TmpStr : String127;
|
||||
begin
|
||||
writeln;
|
||||
TmpStr := DirChr + ':\*.*'; { look in the root directory }
|
||||
move(TmpStr[1], DirSpc, length(TmpStr));
|
||||
DirSpc[length(TmpStr)] := 0;
|
||||
if (EntryFound(true, $08)) and (Error = 0) then
|
||||
begin
|
||||
ExtractName(FleNme);
|
||||
writeln(' Volume in drive ', DirChr, ' is ', FleNme);
|
||||
writeln
|
||||
end
|
||||
else
|
||||
if Error = 0 then
|
||||
begin
|
||||
writeln(' Volume in drive ', DirChr, ' has no label ');
|
||||
writeln
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
procedure CheckFileOrSubdir;
|
||||
begin
|
||||
if (pos('*', DirMsk) = 0) and (pos('?', DirMsk) = 0) then
|
||||
begin
|
||||
move(DirPrm[1], DirSpc, length(DirPrm));
|
||||
DirSpc[length(DirPrm)] := 0;
|
||||
if EntryFound(true, $10) and (Error = 0) then
|
||||
begin
|
||||
if (DTA[$15] and $10) <> 0 then
|
||||
DirPrm := DirPrm + '\*.*'
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
procedure DiskDetails (FleCnt : integer);
|
||||
var
|
||||
Free : real;
|
||||
FreStr : string[20];
|
||||
i, x : integer;
|
||||
begin
|
||||
R.AH := $36; { get disk free space }
|
||||
R.DL := DirDrv; { drive number A=1, B=2, etc }
|
||||
Msdos(R); { get disk info }
|
||||
Free := (R.AX * 1.0) * (R.CX * 1.0) * (R.BX * 1.0);
|
||||
str(Free:11:0, FreStr);
|
||||
i := length(FreStr);
|
||||
x := 0;
|
||||
while (i > 0) and (FreStr[i] <> ' ') do
|
||||
begin
|
||||
x := x + 1;
|
||||
if ((x mod 3) = 0) and (FreStr[i-1] <> ' ') then
|
||||
insert(',', FreStr, i);
|
||||
i := i - 1
|
||||
end;
|
||||
writeln;
|
||||
writeln(FleCnt:9, ' file(s)', '':15-length(FreStr),
|
||||
FreStr, ' bytes free')
|
||||
end;
|
||||
|
||||
|
||||
procedure DosDir;
|
||||
var
|
||||
FstDir : boolean;
|
||||
FleCnt : integer;
|
||||
FleNme : String14;
|
||||
begin
|
||||
VolumeLabel;
|
||||
if Error = 0 then
|
||||
CheckFileOrSubdir;
|
||||
if Error = 0 then
|
||||
begin
|
||||
move(DirPrm[1], DirSpc, length(DirPrm));
|
||||
DirSpc[length(DirPrm)] := 0;
|
||||
writeln(' Directory of ', DirPrm);
|
||||
writeln;
|
||||
FleCnt := 0;
|
||||
FstDir := true;
|
||||
while EntryFound(FstDir, $10) and (Error = 0) do
|
||||
begin
|
||||
FstDir := false;
|
||||
FleCnt := FleCnt + 1;
|
||||
ExtractName(FleNme);
|
||||
write(FleNme, '':16-length(FleNme))
|
||||
end
|
||||
end;
|
||||
if Error = 0 then
|
||||
begin
|
||||
if (FleCnt mod 5) <> 0 then
|
||||
writeln;
|
||||
if FstDir then
|
||||
writeln(' No files found');
|
||||
DiskDetails(FleCnt)
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
i : integer;
|
||||
begin
|
||||
Error := 0;
|
||||
DirPrm := ComLne;
|
||||
while pos(' ', DirPrm) = 1 DO
|
||||
delete(DirPrm, 1, 1);
|
||||
DirMsk := DirPrm;
|
||||
DirPth := DirPrm;
|
||||
i := length(DirPth);
|
||||
while (i > 0) and (not (DirPth[i] in [':', '\'])) do
|
||||
i := i - 1;
|
||||
DirPth[0] := chr(i);
|
||||
delete(DirMsk, 1, i);
|
||||
if pos(':', DirPth) = 2 then
|
||||
DirDrv := ord(upcase(DirPth[1])) - 64
|
||||
else
|
||||
begin
|
||||
R.AH := $19; { get current drive number }
|
||||
Msdos(R); { get default drive }
|
||||
DirDrv := R.AL + 1;
|
||||
DirPth := chr(DirDrv + 64) + ':' + DirPth
|
||||
end;
|
||||
if pos('\', DirPth) = 0 then
|
||||
begin
|
||||
R.AH := $47;
|
||||
R.DL := DirDrv;
|
||||
R.DS := seg(DirPth[3]);
|
||||
R.SI := ofs(DirPth[3]);
|
||||
Msdos(R);
|
||||
TestExtendedError;
|
||||
if Error = 0 then
|
||||
begin
|
||||
i := 1;
|
||||
while DirPth[i] <> #0 do
|
||||
i := i + 1;
|
||||
DirPth[0] := chr(i-1);
|
||||
if pos('\', DirPth) <> 3 then
|
||||
insert('\', DirPth, 3)
|
||||
end
|
||||
end;
|
||||
if Error = 0 then
|
||||
begin
|
||||
DirChr := chr(DirDrv + 64);
|
||||
if DirPth[length(DirPth)] <> '\' then
|
||||
DirPth := DirPth + '\';
|
||||
if DirMsk = '' then
|
||||
DirMsk := '*.*';
|
||||
DirPrm := DirPth + DirMsk;
|
||||
R.AX := $1A00; { function used to set the DTA }
|
||||
R.DS := seg(DTA); { store the parameter segment in DS }
|
||||
R.DX := ofs(DTA); { " " " offset in DX }
|
||||
Msdos(R); { set DTA location }
|
||||
DosDir
|
||||
end
|
||||
end.
|
||||
Reference in New Issue
Block a user