Category : File Managers
Archive   : TD.ZIP
Filename : TD.PAS

 
Output of file : TD.PAS contained in archive : TD.ZIP
{$C-}
program td;

{
*****************************************************
* *
* TD Version 0.12 *
* *
* Copyright 1984 *
* John D. Falconer *
* (415) 521-7245 *
* CIS 72435,1617 *
* *
* All commercial rights reserved. *
* *
* Requires MS-DOS/PC-DOS Ver. 2.0 or higher. *
* [to run] *
* *
* Requires Borland Turbo Pascal Ver. 2.0 or higher. *
* [to compile] *
* *
*****************************************************


Ver. 0.12 - 01/23/85 - added code to display "No Files" when
empty directories are encountered in
wide and normal modes, changed the
handling of a "quit" during a listing
so that summary data will be shown.
0.11 - 01/07/85 - added the return of NAM, changed the
environment handling to use a single
external function, changed the names
of /b variables to three letters to
conserve environment space
0.10 - 01/02/85 - changed environment routines to use
generic exernal routines, making it
easy to add other return variables from
TD (e.g. free space, found size)
0.09 - 12/26/84 - determined .COM file patches to defeat
Turbo's clearing of the screen
at the start of execution, and its
positioning the cursor at the bottom-
left of the screen at the end of
execution. Warning!!!! These patches
are relying on absolute code locations
in the Turbo run-time library, and will
probably not be valid for different versions
of the compiler (although they are OK
for both 8088 and 8088/7 versions now.
The patches are:

Affects: Location Was Becomes
-------- -------- --- -------
ClearScrn CSEG:02FC INT 10 NOP
NOP

FloorCrsr CSEG:0330 CALL 334 MOV DX,FFFF
0332 RET NOP

0.08 - 12/15/84 - added sorting of subdirectories;
further cleaned up screen display
in /t mode; added environment check
0.07 - 12/12/84 - improved the /t option by filling
in the missing lines on the display;
added an indicator in the /t mode to
show the currently logged directory
0.06 - 12/07/84 - increased com_str length to allow
formatting of large numbers; consoli-
dated code in volume change routine
0.05 - 12/05/84 - added sort by name, ext, size, date
0.04 - 12/01/84 - added /w option
0.03 - 11/30/84 - modified fil_str routine to add a
leading '*' if an extension only was
entered
0.02 - 11/29/84 - added comma format for summary sizes
0.01 - 11/28/84 - added pause, omit_vol and quiet options
0.00 - 9/18/84 - conception and first coding


*********************** NOTE ************************

This source code is written to minimize the size of the
generated code file ... it does not particularly follow
good structured Pascal programming practice. Wide use
is made of side-effects and global or shared variables.
Some clarity has been sacrificed (e.g. use of "with"
statements has been limited) because using the more
transparent constructs generated extra code. If you
are a beginning Pascal programmer, please don't look at
this code for guidance in your programming.

*******************************************************



}

const normal = 0;
hidden = 2;
system = 4;
vname = 8;
subdir = 16;

type registers = record
ax, bx, cx, dx, bp, si, di, ds, es, flags: integer
end;

s12 = string[12];
s64 = string[64];
sort_method = (none, by_name, by_ext, by_size, by_date);

var DTA : packed array[0..127] of char; { we'll set our own }
cmd_line : s64 absolute cseg:$0080; { MS-DOS command line }
env_name : s12;
env_value : s64;
regs : registers;
sort_switch : sort_method;
error_level,
pos_name,
pos_ext,
pos_size,
pos_date,
pos_time,
std_outptr,
screen_outptr,
search_mode,
century : integer;
add_vol,
batch,
change_vol,
data_file,
done,
help,
log_dir,
omit_vol,
pause,
quiet,
show_subs,
tree,
wide : boolean;
hyphen : string[1];


procedure std_out( ch: char );
external 'stdout.com';


function use_env(set_value: boolean; var name: s12; var value: s64): boolean;
external 'useenv.com';


procedure clr_regs;
begin
fillchar(regs, sizeof(registers), 0)
end;


function user_done: boolean;
var ch: char;
i : integer;
begin
conoutptr := screen_outptr;
write('Press to quit, any other key to continue ');
read(kbd, ch);
user_done := upcase(ch) = 'Q';
for i := 45 downto 1 do write(chr(8));
clreol;
conoutptr := std_outptr
end;


procedure set_DTA;
begin
clr_regs;
regs.ax := $1A00;
regs.ds := seg(DTA);
regs.dx := ofs(DTA);
msdos(regs)
end;


procedure init_main;
begin
set_DTA;
screen_outptr:= conoutptr;
std_outptr := ofs(std_out);
textcolor(yellow);
add_vol := false;
batch := false;
change_vol := false;
century := 0;
data_file := false;
done := true;
help := false;
hyphen := '-';
log_dir := false;
omit_vol := true;
pause := true;
quiet := false;
search_mode := normal;
show_subs := true;
sort_switch := by_name;
tree := false;
wide := false
end;


procedure check_environment;
begin
env_name := 'TD';
if use_env(false, env_name, env_value) then
if env_value[1] = '+' then
begin
delete(env_value, 1, 1);
cmd_line := cmd_line + env_value
end
else
if cmd_line = '' then cmd_line := env_value
end;


{
compress the command line, check for switch chars, and delete
everything beyond the file spec
}

procedure set_switches;
var i,j,k,l : integer;
begin
l := length(cmd_line);
if l > 0 then
begin
i := 0; j := 0; k := 0;
while i < l do
begin
i := i + 1;
if cmd_line[i] <> ' ' then
begin
j := j + 1;
cmd_line[j] := upcase(cmd_line[i]);
if k > 0 then
case cmd_line[j] of
'A': add_vol := true;
'B': batch := true;
'C': done := false;
'D': sort_switch := by_date;
'E': sort_switch := by_ext;
'H': search_mode := search_mode + hidden + system;
'L': log_dir := true;
'N': sort_switch := by_name;
'P': pause := not pause;
'O': omit_vol := not omit_vol;
'Q': quiet := true;
'S': sort_switch := by_size;
'T': tree := not(tree);
'U': sort_switch := none;
'V': change_vol := true;
'W': wide := not(wide);
'X': show_subs := false;
'?': help := true;
'2'..'3': begin
data_file := true;
omit_vol := not omit_vol;
pause := not pause;
if cmd_line[j] = '3' then
begin
hyphen := '';
century := 1900
end
end;
end
else
if cmd_line[j] = '/' then k := j
end
end;
if tree then wide := false;
cmd_line[0] := chr(j);
if k > 0 then delete(cmd_line, k, j - k + 1)
end
end;


procedure set_offsets;
begin
pos_name := 38;
if data_file then
begin
pos_ext := 46;
pos_size := 49;
pos_date := 57;
pos_time := 65
end
else
begin
pos_ext := 47;
pos_size := 51;
pos_date := 61;
pos_time := 71
end
end;


procedure show_help;
begin
clrscr;
writeln;
writeln('TD Ver. 0.12 - John Falconer - 01/23/84');
writeln;
writeln('Usage: td [drive spec][path spec][file spec][/options][>>txtfile]');
writeln;
writeln('A - Add a volume name if none exists');
writeln('B - Batch: return NAM, ERR, SPC, SIZ');
writeln('C - Continue until user quits');
writeln('D, E, N, S - sort by Date, Extension, Name or Size');
writeln('H - Hidden files');
writeln('L - Log to directory with match');
writeln('O - Omit volume name');
writeln('P - Pause at full screen');
writeln('Q - Quiet output');
writeln('T - Tree display');
writeln('U - Unsorted');
writeln('V - Volume name change');
writeln('W - Wide listing');
writeln('X - eXclude lower nodes');
writeln('2, 3 - dBASE II or III SDF');
writeln('? - help');
writeln;
writeln('N, O and P default ON.');
writeln('Use DOS''s SET command to SET TD=[/defaults]')
end;


procedure directory;
const max_level = 20;
out_len = 78;
type pac64 = packed array[0..63] of char;

direntry = record
reserved: packed array[0..20] of byte;
attrib : byte;
time : integer;
date : integer;
size : packed array[0..3] of byte;
name : packed array[0..12] of char;
end;

s_link = ^s_node;
s_node = record
path : pac64;
level : integer;
node : s12;
l : s_link
end;

var stack : s_link;
level_arry : array[0..max_level] of integer;
entry : direntry absolute DTA;
path,
log_path : pac64;
cur_path_str : s64;
current_node,
fil_str,
start_node,
vol_name : s12;
outline : string[out_len];
found_size,
free_size : real;
column,
current_level,
ds_len,
fp_len,
fs_len,
last_level,
linecount,
num_files,
num_subs,
path_len,
path_start : integer;
drv_num : byte;


procedure show_results;
var com_str: string[14];

procedure comma_str(r: real);
var i: integer;
begin
str(r:11:0,com_str);
i := length(com_str);
while i > 1 do
begin
if (com_str[i - 1] > ' ') and (i mod 3 = 0) then insert(',',com_str,i);
i := i - 1
end
end;


begin
conoutptr := screen_outptr;
if not wide then writeln;
if found_size > 0 then
begin
comma_str(found_size);
write(com_str:13, ' bytes in ',num_files, ' file');
if num_files <> 1 then write('s')
end
else
write('No files');
if fil_str <> '*.*' then write(' matching ',fil_str);
writeln(' starting at ',start_node);
comma_str(free_size);
write((com_str):13, ' bytes free');
if num_subs > 0 then
begin
write(num_subs:30,' subdirector');
if num_subs = 1 then write('y') else write('ies');
writeln(' searched')
end
else
writeln
end;



procedure blank_line(start: integer);
begin
fillchar(outline[start], out_len - start + 1, ' ')
end;


procedure write_outline;
var i: integer;
begin
i := out_len;
while (outline[i] = ' ') and (i > 1) do i := i - 1;
outline[0] := chr(i);
writeln(outline);
linecount := linecount + 1;
if pause and (linecount mod 20 = 0) then
if user_done then
begin
writeln;
show_results;
halt
end
end;


procedure init_dir;
begin
for current_level := 0 to max_level do level_arry[current_level] := 0;
blank_line(1);
column := 0;
current_level := 0;
current_node := 'ROOT';
drv_num := 0;
error_level := 0;
found_size := 0;
linecount := 0;
last_level := 0;
num_files := 0;
num_subs := 0;
stack := nil;
vol_name := ''
end;

{
parse the search path into its drive, path and file specs ... if no
path is specified use the currently logged path
}

procedure set_search;
var path_str : s64 absolute DTA;
drv_str : string[2];
i, j, k : integer;


procedure get_cur_dir;
var i : integer;
begin
clr_regs;
regs.ax := $4700;
regs.dx := drv_num;
regs.ds := seg(cur_path_str);
regs.si := ofs(cur_path_str) + 1;
msdos(regs);
i := 1;
while cur_path_str[i] <> chr(0) do
begin
cur_path_str[i] := upcase(cur_path_str[i]);
i := i + 1
end;
cur_path_str[0] := chr(i - 1);
if i > 1 then cur_path_str := '\' + cur_path_str + '\'
end;

begin { set_search }
path_str := cmd_line;
ds_len := 0;
drv_str := '';
if length(path_str) > 1 then
if path_str[2] = ':' then
begin
drv_str := copy(path_str, 1, 2);
drv_num := ord(drv_str[1]) - ord('A') + 1;
delete(path_str, 1, 2);
ds_len := 2
end;

fil_str := '';
i := length(path_str);
if i > 0 then
begin
j := i;
while (path_str[i] <> '\') and (i > 0) do i := i - 1;
j := j - i;
i := i + 1;
if j > 0 then
begin
fil_str := copy(path_str, i, j);
delete(path_str, i, j);
if (fil_str <> '') then
begin
i := pos('.',fil_str);
if i = 0 then
fil_str := fil_str + '.*'
else
begin
for k := j - i to 2 do fil_str := fil_str + ' ';
if i = 1 then fil_str := '*' + fil_str
end
end
end
end;
if fil_str = '' then fil_str := '*.*';
fs_len := length(fil_str);

get_cur_dir;
if path_str = '' then path_str := cur_path_str;
path_len := length(path_str);
if path_len > 1 then
begin
i := path_len;
repeat i := i - 1 until (path_str[i] = '\') or (i = 1);
current_node := copy(path_str, i + 1, path_len - i - 1)
end;
start_node := current_node;

path_str := drv_str + path_str + fil_str;
fp_len := length(path_str);
fillchar(path, 64, 0);
move(path_str[1], path, fp_len);
path[fp_len] := '$';
log_path := path;
log_path[ds_len + path_len] := chr(0)
end;

{
return a -1 if drive is unavailable
}

function free_space: real;
var a, b, c: real;
begin
clr_regs;
regs.ax := $3600;
regs.dx := drv_num;
msdos(regs);
if regs.ax <> $FFFF then
begin
a := regs.ax;
b := regs.bx;
c := regs.cx;
free_space := a * b * c
end
else
free_space := -1
end;


function read_first(var path: pac64; mode: byte): boolean;
begin
clr_regs;
regs.ax := $4E00;
regs.cx := mode;
regs.ds := seg(path);
regs.dx := ofs(path);
msdos(regs);
read_first := regs.ax and $FF = 0
end;


function read_next: boolean;
begin
clr_regs;
regs.ax := $4F00;
msdos(regs);
read_next := regs.ax and $FF = 0
end;


procedure get_vol_name;

type pac10 = packed array[0..10] of char;
vol_fcb = record
flag : byte;
zeros : packed array[0..4] of char;
attrib : byte;
driveno : byte;
name1 : pac10;
filler : packed array[0..4] of byte;
name2 : pac10;
end;
var vol_entry: vol_fcb absolute DTA;
i : integer;


procedure init_vol_entry;
begin
clr_regs;
fillchar(vol_entry, sizeof(vol_fcb), 0);
fillchar(vol_entry.name1, 11, ' ');
vol_entry.name2 := vol_entry.name1;
move(vol_name[1], vol_entry.name1, length(vol_name));
vol_entry.driveno := drv_num;
vol_entry.flag := $FF;
vol_entry.attrib := vname;
regs.ds := seg(vol_entry);
regs.dx := ofs(vol_entry)
end;


function rd_fst_vol: boolean;
begin
init_vol_entry;
fillchar(vol_entry.name1, 11, '?');
regs.ax := $1100;
msdos(regs);
rd_fst_vol := regs.ax and $FF = 0
end;


function rd_nxt_vol: boolean;
begin
clr_regs;
regs.ax := $1200;
msdos(regs);
rd_nxt_vol := regs.ax and $FF = 0
end;


procedure change_vol_name;
var new_name: s12;
i, vol_len: integer;
begin
clrscr;
gotoxy(1,2);
write('Volume name is [', vol_name:11, ']. Enter a name or to continue: ');
read(new_name);
gotoxy(1,2);
clreol;
writeln;
vol_len := length(new_name);
if vol_len > 0 then
begin
for i := 1 to vol_len do new_name[i] := upcase(new_name[i]);
init_vol_entry;
if vol_name = '' then
begin
move(new_name[1], vol_entry.name1, vol_len);
regs.ax := $1600
end
else
begin
move(new_name[1], vol_entry.name2, vol_len);
regs.ax := $1700
end;
msdos(regs);
if regs.ax and $FF = 0 then vol_name := new_name
end
end;


begin { get_vol_name }
if not tree then conoutptr := screen_outptr;
if rd_fst_vol then
repeat
if vol_entry.attrib = vname then
begin
move(vol_entry.name1, vol_name[1], 11);
vol_name[0] := chr(11)
end
until not rd_nxt_vol;
if not quiet then
if change_vol or (add_vol and (vol_name = '')) then change_vol_name;
i := length(vol_name);
if i > 0 then
begin
while (i > 0) and (vol_name[i] = ' ') do i := i - 1;
vol_name[0] := chr(i);
end;
if not quiet then
begin
writeln;
if i > 0 then
writeln('Volume ',vol_name)
else
writeln('No name for this volume');
writeln
end;
if not tree then conoutptr := std_outptr
end;


{
show one level of a directory
}

procedure show_dir;
type s17 = string[17];

t_link = ^t_node;
t_node = record
key : s17;
data: direntry;
l, r: t_link
end;

var head, tail: t_link;
level_files: integer;


function file_size: real;
begin
file_size := entry.size[0]
+ entry.size[1] * 256.0
+ entry.size[2] * 65536.0
+ entry.size[3] * 16777216.0
end;


procedure place_vol;
var vol_len: integer;
begin
if omit_vol then
path_start := 1
else
begin
vol_len := length(vol_name);
move(vol_name[1], outline[1], vol_len);
path_start := 1 + vol_len
end;
if path[ds_len] <> '\' then
begin
outline[path_start] := '\';
path_start := path_start + 1
end
end;


procedure place_path;
begin
blank_line(path_start);
move(path[ds_len], outline[path_start], path_len)
end;


procedure place_name;
var i,j: integer;
begin
with entry do
begin
i := 0;
while (i < 8) and (not (name[i] in ['.', chr(0)])) do i := i + 1;
move(name, outline[pos_name], i);
if name[i] <> chr(0) then
begin
j := i + 1;
i := 0;
while (i < 3) and (name[j + i] <> chr(0)) do i := i + 1;
move(name[j], outline[pos_ext], i)
end
end
end;


procedure place_size;
var size_str: string[8];
begin
str(file_size:8:0, size_str);
move(size_str[1], outline[pos_size], 8)
end;

{
1 1 1 1 1 1
5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-------------------------------
| year | month | day |

}

procedure place_date;
var i,j: integer;
mo_str, day_str: string[2];
date_str : string[10];
begin
with entry do
begin
str(date shr 9 + century + 80:2 , date_str);
str(date shr 5 and $0F:2 , mo_str);
str(date and $1F:2 , day_str);
if data_file then
date_str := date_str + hyphen + mo_str + hyphen + day_str
else
date_str := mo_str + hyphen + day_str + hyphen + date_str;
j := length(date_str);
for i := 2 to j do
if date_str[i] = ' ' then date_str[i] := '0';
move(date_str[1], outline[pos_date], j)
end
end;

{
1 1 1 1 1 1
5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-------------------------------
| hour | min. | 2 x sec |

}

procedure place_time;
var i: integer;
min_str, sec_str: string[2];
time_str : string[8];
begin
with entry do
begin
str(time shr 11:2 , time_str);
str(time shr 5 and $3F:2, min_str);
str(time shl 1 and $3F:2, sec_str);
time_str := time_str + ':' + min_str + ':' + sec_str;
for i := 2 to 8 do
if time_str[i] = ' ' then time_str[i] := '0';
move(time_str[1], outline[pos_time], 8)
end
end;


procedure show_direntry;
begin
if wide then
begin
if (column = 5) or (column = 0) then
begin
if column = 5 then write_outline;
pos_name := 1;
pos_ext := 10;
column := 1;
blank_line(1);
end
else
begin
pos_name := pos_name + 16;
pos_ext := pos_ext + 16;
column := column + 1
end;
place_name
end
else
begin
blank_line(38);
place_name;
place_size;
place_date;
place_time;
write_outline
end
end;

{
build a binary tree of directory entries while reading them, use
the chosen sort field to determine tree insertion ... not the fastest
method, but simple and well suited to this application
}

procedure tree_insert(x: t_link);
var father : t_link;
work_key: s17;

procedure get_work_key;
var pos_key : integer;
saved_mode: boolean;
begin
if sort_switch = by_ext then
begin
place_name;
pos_key := pos_ext;
move(outline[pos_key], work_key[1], 3);
move(outline[pos_key], work_key[4], 9)
end
else
begin
case sort_switch of
by_name: begin
place_name;
pos_key := pos_name
end;
by_size: begin
place_size;
pos_key := pos_size
end;
by_date: begin
saved_mode := data_file;
data_file := true;
set_offsets;
place_date;
place_time;
data_file := saved_mode;
pos_key := pos_date;
set_offsets
end
end;
move(outline[pos_key], work_key[1], 17)
end;
blank_line(pos_key);
work_key[0] := chr(17)
end;


begin
get_work_key;
repeat
father := x;
if work_key < x^.key then x := x^.l else x := x^.r
until x = tail;
new(x);
x^.key := work_key;
x^.data:= entry;
x^.l := tail;
x^.r := tail;
if work_key < father^.key then father^.l := x else father^.r := x
end;


procedure tree_initialize;
begin
new(tail);
new(head);
head^.key := '';
head^.r := tail
end;


procedure tree_dispose;
begin
dispose(head);
dispose(tail)
end;


procedure tree_print(x: t_link);
begin
if x <> tail then
begin
tree_print(x^.l);
entry := x^.data;
show_direntry;
tree_print(x^.r);
dispose(x)
end
end;


function in_cur_path: boolean;
var i, l: integer;
begin
l := length(cur_path_str);
if (l = 0) and (path_len = 1) then in_cur_path := true
else if path_len = l then
begin
in_cur_path := true;
for i := 1 to l do
if cur_path_str[i] <> path[ds_len + i - 1] then in_cur_path := false
end
else in_cur_path := false
end;


procedure show_tree;
const col_width = 15;
var treestr : string[col_width];
i, j, new_y, new_x : integer;

procedure mark(ch: char);
begin
gotoxy(new_x, new_y);
writeln(ch)
end;

begin
new_x := current_level * col_width + 1;
new_y := wherey - 1;
if current_level > last_level then mark('Â')
else if current_level < last_level then
begin
new_y := wherey - num_subs + level_arry[current_level];
if new_y < 1 then new_y := 1;
i := wherey - new_y;
mark('Ã');
for j := 1 to i - 1 do writeln('³':new_x)
end
else if num_subs > 0 then mark('Ã');
level_arry[current_level] := num_subs;
last_level := current_level;
treestr := 'ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄ';
write(treestr:(current_level + 1) * col_width);
if level_files > 0 then
begin
write('Ä[',level_files:3,']');
textcolor(green);
j := 6
end
else
begin
write('Äo');
j := 2
end;
for i := 3 to j + col_width do write(chr(8));
write(' ',current_node,' ');
if in_cur_path then
begin
textcolor(red);
writeln(chr(17))
end
else
writeln;
textcolor(yellow)
end;


procedure dir_start;
begin
place_vol;
place_path;
if wide and not quiet then
begin
if in_cur_path then write(chr(16));
write_outline
end
end;


procedure dir_end;
begin
if wide and not quiet then
begin
write_outline;
blank_line(1);
write_outline;
column := 0
end
end;


begin { show_dir }
tree_initialize;
level_files := num_files;
place_vol;
place_path;
if read_first(path, search_mode) then
begin
dir_start;
if log_dir then log_path := path;
repeat
num_files := num_files + 1;
if not (tree or quiet) then
if sort_switch = none then show_direntry else tree_insert(head);
found_size := found_size + file_size
until not read_next;
if not (tree or quiet) then
if sort_switch <> none then tree_print(head^.r);
dir_end
end
else
if fil_str = '*.*' then
begin
dir_start;
env_name := '< No Files >';
if wide then column := 1 else column := pos_name;
blank_line(column);
move(env_name[1], outline[column], 12);
if not (wide or tree or quiet) then write_outline else dir_end
end;
level_files := num_files - level_files;
if tree then show_tree;
tree_dispose
end;


procedure show_sub_dirs;
const sub_ext: string[4] = '*.*$';
var sub_path : pac64;


procedure size_path;
var i: integer;
begin
i := 0;
while (path[i] <> '$') and (i < 64) do i := i + 1;
fp_len := i;
path_len := i - ds_len - fs_len
end;


procedure push_sub(push_path: pac64);
var p: s_link;
begin
if stack = nil then
begin
new(stack);
stack^.l := nil
end
else
begin
new(p);
p^.l := stack;
stack:= p
end;
stack^.level := current_level;
stack^.node := current_node;
stack^.path := push_path
end;

{
this selection sort of contiguous entries at one level causes them
to pop off the stack in alphabetical order
}

procedure sort_list(var s: s_link);
var p, q: s_link;
low_node: s12;
begin
if (s^.l <> nil) and (s^.l^.level = s^.level) then
begin
p := s;
q := nil;
low_node := p^.node;
while (p^.l <> nil) and (p^.l^.level = p^.level) do
begin
if p^.l^.node < low_node then
begin
low_node := p^.l^.node;
q := p
end;
p := p^.l
end;
if q <> nil then { first entry wasn't low }
begin
p := q^.l; { point to new head }
q^.l := p^.l; { point around it }
p^.l := s; { point new head next to old head }
s := p { point stack to new head }
end;
sort_list(s^.l) { until we're done }
end
end;


procedure pop_sub(var pop_path: pac64);
var p: s_link;
begin
if stack <> nil then
begin
p := stack;
pop_path := stack^.path;
current_level := stack^.level;
current_node := stack^.node;
stack := stack^.l;
dispose(p)
end
end;


procedure stack_sub_dirs;
var found_some: boolean;

procedure stack_one_sub;
var i, j, ent_len : integer;
begin
found_some := true;
ent_len := 0;
while (not (entry.name[ent_len] in [' ',chr(0)])) and (ent_len < 12) do
ent_len := ent_len + 1;
move(entry.name[0], current_node[1], ent_len);
current_node[0] := chr(ent_len);
i := fp_len - fs_len;
j := i + ent_len;
sub_path := path;
move(sub_path[i], sub_path[j + 1], fs_len + 1);
move(entry.name, sub_path[i], ent_len);
sub_path[j] := '\';
push_sub(sub_path)
end;

begin { stack_sub_dirs };
found_some := false;
fillchar(sub_path, 64, 0);
move(path, sub_path, fp_len - fs_len);
move(sub_ext[1], sub_path[fp_len - fs_len], 4);
current_level := current_level + 1;
if read_first(sub_path, subdir) then
repeat
if (entry.attrib = subdir) and (entry.name[0] <> '.') then stack_one_sub
until not read_next;
if found_some and (sort_switch <> none) then sort_list(stack)
end;


begin { show_sub_dirs }
stack_sub_dirs;
if stack <> nil then
begin
num_subs := num_subs + 1;
pop_sub(path);
size_path;
show_dir;
show_sub_dirs
end
end;


procedure change_dir;
var i: integer;
begin
i := 63;
while (i >= 0) and (log_path[i] <> '\') do i := i - 1;
case i of
-1: begin
if log_path[1] = ':' then i := 3 else i := 1;
log_path[i - 1] := '\'
end;
0: i := 1;
2: if log_path[1] = ':' then i := 3
end;
log_path[i] := chr(0);
clr_regs;
regs.ax := $3B00;
regs.ds := seg(log_path);
regs.dx := ofs(log_path);
msdos(regs);
if regs.ax and $FF = 0 then
if not quiet then
begin
write('Now logged to ':23);
for i := 0 to i - 1 do write(log_path[i])
end
else
else
error_level := error_level + 2
end;


procedure update_environment;
var dummy: boolean;
begin
env_name := 'NAM';
if vol_name = '' then
env_value := 'NONE'
else
env_value := vol_name;
dummy := use_env(true, env_name, env_value);
env_name := 'ERR';
str(error_level, env_value);
dummy := use_env(true, env_name, env_value);
env_name := 'SIZ';
str(found_size:9:0, env_value);
dummy := use_env(true, env_name, env_value);
env_name := 'SPC';
str(free_size:9:0, env_value);
dummy := use_env(true, env_name, env_value)
end;


begin { directory }
init_dir;
set_search;
free_size := free_space;
if free_size = -1 then error_level := 4
else
begin
get_vol_name;
show_dir;
if show_subs then show_sub_dirs;
if not quiet then show_results;
if num_files = 0 then error_level := 1;
if log_dir then change_dir;
if batch then update_environment
end
end;


begin { main program }
init_main;
check_environment;
set_switches;
set_offsets;
if help then show_help
else
repeat
directory;
if not done then
begin
writeln(chr(7));
done := user_done
end
until done
end.

  3 Responses to “Category : File Managers
Archive   : TD.ZIP
Filename : TD.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/