mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 00:14:25 +00:00
311 lines
8.5 KiB
ObjectPascal
311 lines
8.5 KiB
ObjectPascal
(*************************************************************************)
|
|
(* *)
|
|
(* 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.
|