[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]
{
Next in this continuing series of code: the actual directry
object.
}
Unit Dirs;
{
A directory management object from a concept originally by Allan
Holub, as discussed in Byte Dec/93 (Vol 18, No 13, page 213)
Turbo Pascal code by Larry Hadley, tested using BP7.
}
INTERFACE
Uses Sort, DOS;
TYPE
pSortSR = ^oSortSR;
oSortSR = OBJECT(oSortTree)
procedure DeleteNode(var Node); virtual;
end;
callbackproc = procedure(name :string; lev :integer);
prec = ^searchrec;
pentry = ^entry;
entry = record
fil :prec;
next, last :pentry;
end;
pdir = ^dir;
dir = record
flist :pentry;
count :word;
path :string[80];
end;
pDirectry = ^Directry;
Directry = OBJECT
dirroot :pdir;
constructor Init(path, filespec :string; attribute :byte);
destructor Done;
procedure Load(path, filespec :string; attribute :byte);
procedure Sort;
procedure Print;
END;
CONST
NotDir = ReadOnly+Hidden+SysFile+VolumeID+Archive;
dosattr : array[0..8] of char = '.rhsvdaxx';
procedure TraverseTree(root :string; pcallproc :pointer; do_depth :boolean);
IMPLEMENTATION
var
treeroot :pSortSR; { sorting tree object }
procedure disposelist(ls :pentry);
var
lso :pentry;
begin
while ls<>NIL do
begin
dispose(ls^.fil);
lso := ls;
ls := ls^.next;
dispose(lso);
end;
end;
{ Define oSortSR.DeleteNode method so object knows how to dispose of
individual data pointers in the event that "Done" is called before
tree is empty. }
procedure oSortSR.DeleteNode(var Node);
var
pNode :pRec ABSOLUTE Node;
begin
dispose(pNode);
end;
constructor Directry.Init(path, filespec :string; attribute :byte);
var
pathspec :string;
node :pentry;
i :word;
BEGIN
FillChar(Self, SizeOf(Self), #0);
Load(path, filespec, attribute); { scan specified directory }
if dirroot^.count=0 then { if no files were found, abort }
begin
if dirroot<>NIL then
begin
disposelist(dirroot^.flist);
dispose(dirroot);
end;
FAIL;
end;
{ the following code expands the pathspec to a full qualified path }
pathspec := dirroot^.path+'\';
node := dirroot^.flist;
while ((node^.fil^.name='.') or (node^.fil^.name='..')) and
(node^.next<>NIL) do
node := node^.next;
if node^.fil^.name='..' then
pathspec := pathspec+'.'
else
pathspec := pathspec+node^.fil^.name;
pathspec := FExpand(pathspec);
i := Length(pathspec);
repeat
Dec(i);
until (i=0) or (pathspec[i]='\');
if i>0 then
begin
Delete(pathspec, i, Length(pathspec));
dirroot^.path := pathspec;
end;
END;
destructor Directry.Done;
begin
if dirroot<>NIL then
begin
disposelist(dirroot^.flist);
dispose(dirroot);
end;
end;
procedure Directry.Load(path, filespec :string; attribute :byte);
{ scan a specified directory with a specified wildcard and attribute
byte }
var
count : word;
pstr : pathstr;
dstr : dirstr;
srec : SearchRec;
dirx : pdir;
firstfl, thisfl, lastfl : pentry;
begin
count := 0;
New(firstfl);
with firstfl^ do
begin
next := NIL; last := NIL; New(fil);
end;
thisfl := firstfl; lastfl := firstfl;
dstr := path;
if path = '' then dstr := '.';
if dstr[Length(dstr)]<>'\' then dstr := dstr+'\';
if filespec = '' then filespec := '*.*';
pstr := dstr+filespec;
FindFirst(pstr, attribute, srec);
while DosError=0 do { while new files are found... }
begin
if srec.attr = (srec.attr and attribute) then
{ make sure the attribute byte matches our required atttribute mask }
begin
if count>0 then
{ if this is NOT first file found, link in new node }
begin
New(thisfl);
lastfl^.next := thisfl;
thisfl^.last := lastfl;
thisfl^.next := NIL;
New(thisfl^.fil);
lastfl := thisfl;
end;
thisfl^.fil^ := srec;
Inc(count);
end;
FindNext(srec);
end;
{ construct root node }
New(dirx);
with dirx^ do
flist := firstfl;
dirx^.path := path; { path specifier for directory list }
dirx^.count := count; { number of files in the list }
if dirroot=NIL then
dirroot := dirx
else
begin
disposelist(dirroot^.flist);
dispose(dirroot);
dirroot := dirx;
end;
end;
{ The following function is the far-local function needed for the
SORT method (which uses the sort unit posted earlier)
Note that this is hard-coded to sort by filename, then extension.
I plan to rewrite this later to allow user-selectable sort
parameters and ordering. }
function Comp(d1, d2 :pointer):integer; far;
var
data1 :pRec ABSOLUTE d1;
data2 :pRec ABSOLUTE d2;
name1, name2, ext1, ext2 :string;
begin
{ This assures that the '.' and '..' dirs will always be the first
listed. }
if (data1^.name='.') or (data1^.name='..') then
begin
Comp := -1;
EXIT;
end;
if (data2^.name='.') or (data2^.name='..') then
begin
Comp := 1;
EXIT;
end;
with data1^ do
begin
name1 := Copy(name, 1, Pos('.', name)-1);
ext1 := Copy(name, Pos('.', name)+1, 3);
end;
with data2^ do
begin
name2 := Copy(name, 1, Pos('.', name)-1);
ext2 := Copy(name, Pos('.', name)+1, 3);
end;
if name1=name2 then
{ If filename portion is equal, use extension to resolve tie }
begin
if ext1=ext2 then
{ There should be NO equal filenames, but handle anyways for
completeness... }
Comp := 0
else
if ext1>ext2 then
Comp := 1
else
Comp := -1;
end
else
if name1>name2 then
Comp := 1
else
Comp := -1;
end;
{ Sort method uses the sort unit to sort the collected directory
entries. }
procedure Directry.Sort;
var
s1, s2 :string;
p1 :pentry;
{ This local procedure keeps code more readable }
procedure UpdatePtr(var prev :pentry; NewEntry :pointer);
begin
if NewEntry<>NIL then { check to see if tree is empty }
begin
New(prev^.next);
prev^.next^.fil := NewEntry;
prev^.next^.last := prev;
prev := prev^.next;
prev^.next := NIL;
end
else
prev := prev^.next;
{ tree is empty, flag "done" with NIL pointer }
end;
begin
p1 := dirroot^.flist;
New(treeroot, Init(Comp));
{ Create a sort tree, point to our COMP function }
while p1<>NIL do
{ Go through our linked list and insert the items into the sorting
tree, dispose of original nodes as we go. }
begin
if p1^.last<>NIL then
dispose(p1^.last);
treeroot^.InsertNode(p1^.fil);
if p1^.next=NIL then
begin
dispose(p1);
p1 := NIL;
end
else
p1 := p1^.next;
end;
{ Reconstruct directory list from sorted tree }
New(dirroot^.flist);
with dirroot^ do
begin
flist^.next := NIL;
flist^.last := NIL;
flist^.fil := treeroot^.ReadLeftNode;
end;
if dirroot^.flist^.fil<>NIL then
begin
p1 := dirroot^.flist;
while p1<>NIL do
UpdatePtr(p1, treeroot^.ReadLeftNode);
end;
{ We're done with sorting tree... }
dispose(treeroot, Done);
end;
procedure Directry.Print;
{ currently prints the entire list, may modify this later to allow
selective printing }
var
s, s1 :string;
e :pentry;
dt :DateTime;
dbg :byte;
procedure DoDateEle(var sb :string; de :word);
begin
Str(de, sb);
if Length(sb)=1 then { Add leading 0's}
sb := '0'+sb;
end;
begin
if dirroot=NIL then EXIT; { make sure empty dirs aren't attempted }
e := dirroot^.flist;
while e<>NIL do
begin
s := '';
with e^.fil^ do
begin
dbg := 1;
repeat
case dbg of { parse attribute bits }
1: s := s+dosattr[(attr and $01)];
2: s := s+dosattr[(attr and $02)];
3: if (attr and $04) = $04 then
s := s+dosattr[3]
else
s := s+dosattr[0];
4: if (attr and $08) = $08 then
s := s+dosattr[4]
else
s := s+dosattr[0];
5: if (attr and $10) = $10 then
s := s+dosattr[5]
else
s := s+dosattr[0];
6: if (attr and $20) = $20 then
s := s+dosattr[6]
else
s := s+dosattr[0];
else
s := s+dosattr[0];
end;
Inc(dbg);
until dbg>8;
s := s+' ';
{ Kludge to make sure that extremely large files (>=100MB) don't
overflow size field... }
if size<100000000 then
Str(size:8, s1)
else
begin
Str((size div 1000):7, s1); { decimal kilobytes }
s1 := s1+'k';
end;
s := s+s1+' ';
{ Format date/time fields }
UnpackTime(Time, dt);
{month}
DoDateEle(s1, dt.month); s := s+s1+'/';
{day}
DoDateEle(s1, dt.day); s := s+s1+'/';
{year}
DoDateEle(s1, dt.year); s := s+s1+' ';
{hour}
DoDateEle(s1, dt.hour); s := s+s1+':';
{minutes}
DoDateEle(s1, dt.min); s := s+s1+':';
{seconds}
DoDateEle(s1, dt.sec); s := s+s1+' - ';
s := s+dirroot^.path+'\'+name;
end;
Writeln(s); s := '';
e := e^.next;
end;
Writeln; Writeln(' ', dirroot^.count, ' files found.'); Writeln;
end;
{ If TraverseTree is not given a callback procedure, this one is
used. }
procedure DefaultCallback(name :string; lev :integer); far;
var
s :string;
const
spaces = ' ';
begin
s := Copy(spaces, 1, lev*4); s := s+name;
Writeln(s);
end;
{ TraverseTree is untested as yet, rest of code (above) works fine.
Note that TraverseTree is NOT a member method of DIRECTRY. Read
the BYTE Dec/93 article for a clarification of why it is good
that it not be a member.}
procedure TraverseTree(root :string; pcallproc :pointer; do_depth :boolean);
var
level :integer;
fullpath :string;
rootdir :pdir;
const
callproc : callbackproc = DefaultCallBack;
{ Actual recursive procedure to scan down directory structure
using the DIRECTRY object. }
procedure Tree(newroot :string; callee :callbackproc; do_last :boolean);
var
subdirs :pdirectry;
direntry :pentry;
Procedure DoDir;
begin
New(subdirs, Init(newroot, '*.*', NotDir));
if subdirs<>NIL then
begin
subdirs^.sort;
direntry := subdirs^.dirroot^.flist;
while direntry<>NIL do
begin
fullpath := newroot+'\'+direntry^.fil^.name;
callee(newroot, level);
direntry := direntry^.next;
end;
dispose(subdirs, done);
end;
end;
begin
if not(do_last) then
DoDir;
New(subdirs, Init(newroot, '*.*', directory));
if subdirs<>NIL then
begin
subdirs^.sort;
direntry := subdirs^.dirroot^.flist;
while direntry<>NIL do
begin
Inc(level);
fullpath := newroot+'\'+direntry^.fil^.name;
Tree(fullpath, callee, do_last);
dec(level);
direntry := direntry^.next;
end;
dispose(subdirs, done);
end;
if do_last then
DoDir;
end;
begin
level := 0;
if pcallproc<>NIL then
callproc := callbackproc(pcallproc^);
root := fexpand(root);
if root[Length(root)]='\' then
Delete(root, Length(root), 1);
if not(do_depth) then
callproc(root, level);
Tree(root, callproc, do_depth);
if do_depth then
callproc(root, level);
end;
END.
[Back to DIRS SWAG index] [Back to Main SWAG index] [Original]