Delphi Programming Unleashed/Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso/units/alldirs.pas

Pascal/Delphi Source File | 1995-03-21 | 6.9 KB | 325 lines

unit AllDirs;
{ Define Debug }

{ ALLDIRS.PAS copyright (c) 1995 by Charles Calvert }

interface

uses
  Classes,
  Controls,
  StrBox,
  SysUtils;

type
  TStack = class;
  TShortStack = class;

  TStackAry = array[1..1000] of PString;
  TStacksAry = array[1..1000] of TShortStack;

  TStack = class(TObject)
    First,
    Last: Word;
    constructor Create;
    procedure InitCount;
    function IsEmpty: Boolean;
    function Count: Integer;
  end;

  TBigStack = class(TStack)
    Stacks: TStacksAry;
    destructor Destroy; virtual;
    procedure Push(P: TShortStack);
    function Pop: TShortStack;
    function PopValue(var Num: Integer): String;
  end;

  TShortStack = class(TStack)
    StackAry: TStackAry;
    destructor Destroy; virtual;
    procedure Push(S: String);
    function Pop: String;
    function GetMoreDirs(Start: String): Integer;
    procedure Show;
  end;

  TFoundFileEvent = procedure(FileName: string; SR: SysUtils.TSearchRec) of Object;
  TFoundDirEvent = procedure(DirName: string) of Object;

  TRunDirs = class(TComponent)
  private
    FOnFoundFile: TFoundFileEvent;
    FOnProcessDir: TFoundDirEvent;
    FFileMask: Str12;
    FCurDir: DirStr;
    FBigStack: TBigStack;
    FShortStack: TShortStack;
  protected
    procedure PushStack;
    procedure ProcessName(FName: String; SR: TSearchRec); virtual;
    procedure ProcessDir(Start: String); virtual;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; virtual;
    function Run(Start: PathStr; StartingDirectory: String): String;
  published
    property OnFoundFile: TFoundFileEvent
      read FOnFoundFile write FOnFoundFile;
    property OnProcessDir: TFoundDirEvent
      read FOnProcessDir write FOnProcessDir;
    property CurDir: DirStr read FCurDir;
  end;

implementation
{$IfDef Debug}
var
  F: Text;
{$EndIf Debug}

constructor TStack.Create;
begin
  inherited Create;
  InitCount;
end;

procedure TStack.InitCount;
begin
  First := 1;
  Last := 0;
end;

function TStack.IsEmpty: Boolean;
var
  OutCome: Boolean;
begin
  OutCome := First > Last;
  IsEmpty := OutCome
end;

function TStack.Count: Integer;
begin
  Count := Last - First;
end;

{==================================================}

destructor TBigStack.Destroy;
var
  i: Integer;
begin
  for i := First to Last do
    Stacks[i].Destroy;
  inherited Destroy;
end;

procedure TBigStack.Push(P: TShortStack);
begin
  Inc(Last);
  Stacks[Last] := P;
end;

function TBigStack.Pop: TShortStack;
begin
end;

function TBigStack.PopValue(var Num: Integer): String;
begin
  Num := 0;
  if IsEmpty then begin
    PopValue := '-1';
    Num := -1;
    Exit;
  end;
  while Stacks[Last].IsEmpty do begin
    Inc(Num);
    Stacks[Last].Destroy;
    Dec(Last);
    if IsEmpty then begin
      PopValue := '-1';
      Num := -1;
      Exit;
    end;
  end;
  if Last = 0 then begin
    PopValue := '-1';
    Exit;
  end;
  PopValue := Stacks[Last].Pop;
end;

{==================================================}

destructor TShortStack.Destroy;
var
  i: Integer;
begin
  if not IsEmpty then
    for i := First to Last  do
      DisposeStr(StackAry[i]);
  inherited Destroy;
end;

procedure TShortStack.Show;
var
  i: Integer;
begin
  for i := First to Last do begin
    {$IfDef Debug}
    WriteLn(F, StackAry[i]^);
    {$EndIf}
    WriteLn(StackAry[i]^);
  end;
  {$IfDef Debug}
  WriteLn(F, '===============');
  {$EndIf}
end;

procedure TShortStack.Push(S: String);
begin
  if (S <> '.') and (S <> '..') then begin
    Inc(Last);
    StackAry[Last] := NewStr(S);
  end;
end;

function TShortStack.Pop: String;
var
  S: PString;
  Temp: String;
begin
  S := StackAry[First];
  if S <> nil then begin
    Move(S^, Temp, Length(S^) + 1);
    DisposeStr(StackAry[First]);
    Inc(First);
    Pop := Temp;
  end
  else begin
    WriteLn('Error TShortStack.Pop');
    Halt;
  end;
end;

function TShortStack.GetMoreDirs(Start: String): Integer;
var
  SR: SysUtils.TSearchRec;
  Total: Integer;
begin
  Total := 0;
  if FindFirst(Start, faDirectory + faReadOnly, SR) = 0 then
    repeat
      if (SR.Attr = faDirectory) or (SR.Attr = faDirectory + faReadOnly) then begin
        Push(SR.Name);
        Inc(Total);
      end;
    until FindNext(SR) <> 0;
  GetMoreDirs := Total;
end;

{=======================================}

constructor TRunDirs.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  {$IfDef Debug}
  Assign(F, 'DirLists.dat');
  ReWrite(F);
  {$EndIf}
  FShortStack := TShortStack.Create;
  FBigStack := TBigStack.Create;
end;

destructor TRunDirs.Destroy;
begin
  FShortStack.Free;
  FBigStack.Free;
  {$IfDef Debug}
  Close(F);
  {$EndIf}
  inherited Destroy;
end;

procedure TRunDirs.PushStack;
begin
  FBigStack.Push(FShortStack);
  FShortStack := TShortStack.Create;
end;

function RemoveDir(Start: String; NumDirs: Integer): String;
var
  i, j: Integer;
  CurDir: DirStr;
  FileMask: Str12;
begin
  SplitDirName(Start, CurDir, FileMask);
  i := Length(CurDir);
  for j := 1 to NumDirs + 1 do begin
    if CurDir[i] = '\' then  begin
      Dec(CurDir[0]);
      Dec(i);
    end;
    while CurDir[i] <> '\' do begin
      Dec(CurDir[0]);
      Dec(i);
    end;
{    Dec(CurDir[0]);
    Dec(i); }
  end;
  RemoveDir := CurDir;
end;

procedure TRunDirs.ProcessName(FName: String; SR: SysUtils.TSearchRec);
begin
  if Assigned(FOnFoundFile) then FOnFoundFile(FName, SR);
end;

procedure TRunDirs.ProcessDir(Start: String);
var
  SR: SysUtils.TSearchRec;
begin
  if Assigned(FOnProcessDir) then FOnProcessDir(FCurDir);
  if FindFirst(Start, faArchive, SR) = 0 then
    repeat
      ProcessName(UpperCase(FCurDir) + SR.Name, SR);
    until FindNext(SR) <> 0;
end;

function TRunDirs.Run(Start: PathStr; StartingDirectory: string): string;
var
  SR: TSearchRec;
  Finished: Boolean;
  NewDir, StartedAt: string;
  DirMask: string;
  NumDirs: Integer;
  OutCome: Integer;
  SaveDir: string;
begin
  GetDir(0, SaveDir);
  ChDir(StartingDirectory);
  Start := ExpandFileName(Start);
  FCurDir := ''; FFileMask := '';
  DirMask := '*.*';
  OutCome := 3;
  Finished := False;
  StartedAt := Start;
  SplitDirName(Start, FCurDir, FFileMask);
  Start := FCurDir + DirMask;
  while not Finished do begin
    FCurDir := ExtractFilePath(Start);
    ProcessDir(FCurDir + FFileMask);
    OutCome := FShortStack.GetMoreDirs(Start);
    if OutCome > 2 then begin
      {ShortStack^.Show;}
      PushStack;
      Start := FCurDir + FBigStack.PopValue(NumDirs) + '\' + DirMask
    end else begin
      NewDir := FBigStack.  PopValue(NumDirs);
      FCurDir := RemoveDir(Start, NumDirs);
      Start := FCurDir + NewDir + '\' + DirMask;
      if (Start = StartedAt) or (NewDir = '-1') then Finished := True;
    end;
  end;
  ChDir(SaveDir);
end;
end.