abcompnd.inc

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

begin
  inherited Create;
  FKey := Key;
  FChildren := TStringList.Create;
  FChildren.Sorted := True;
  FChildren.Duplicates := dupError;
end;
{-----------------------------------------------------------------------------}
destructor TMultiNode.Destroy;
  {- Destroys the node and all of the children}
var
  i : integer;
begin
  {free children}
  for i := FChildren.Count - 1 downto 0 do
    FChildren.Objects[i].Free;
  FChildren.Free;
  if Assigned(FData) then
    TAbDirectoryEntry(FData).Free;
  inherited Destroy;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.AddChild(const Key : string) : TMultiNode;
  {- Creates and adds a new node - returns the newly added node}
begin
  if Contains(Key) then
    Result := nil
  else begin
    Result := TMultiNode.Create(Key);
    Result.Parent := self;
    FChildren.AddObject(Key, Result);
  end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.Contains(const Key : string) : Boolean;
  {- Returns true if the node contains a child of the name specified by 'Key'}
begin
  Result := (FChildren.IndexOf(Key) >= 0);
end;
{-----------------------------------------------------------------------------}
procedure TMultiNode.DeleteChild(Index : Integer);
  {- Deletes the child node specified by 'Index'}
begin
  if ((Index < 0) or (Index > FChildren.Count - 1)) then
    raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds);
  FChildren.Objects[Index].Free;
  FChildren.Delete(Index);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.DeleteChildByName(const ChildKey : string) : Boolean;
  {- If node found, node is deleted and true is returned, else returns false}
begin
  Result := Contains(ChildKey);
  if Result then begin
    FChildren.Objects[FChildren.IndexOf(ChildKey)].Free;
    FChildren.Delete(FChildren.IndexOf(ChildKey));
  end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.DeleteChildren : Boolean;
  {- Deletes all child nodes}
var
  i : Integer;
begin
  Result := FChildren.Count > 0;
  for i := FChildren.Count - 1 downto 0 do begin
    FChildren.Objects[i].Free;
    FChildren.Delete(i);
  end;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChild(Index : integer) : TMultiNode;
  {- Returns the node specified by Index}
begin
  if ((Index < 0) or (Index > FChildren.Count - 1)) then
    raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds);
  Result := (FChildren.Objects[Index] as TMultiNode);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChildByName(const Key : string) : TMultiNode;
  {- Returns the child node specified by 'Key'.  If not found, result = nil}
begin
  Result := nil;
  if Contains(Key) then
    Result := (FChildren.Objects[FChildren.IndexOf(Key)] as TMultiNode);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChildCount : Integer;
  {- Returns the node's children count}
begin
  Result := FChildren.Count;
end;
{-----------------------------------------------------------------------------}
function TMultiNode.GetChildren(Index : Integer) : TMultiNode;
  {- Returns the node at 'Index'}
begin
  if ((Index < 0) or (Index > FChildren.Count - 1)) then
    raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds);
  Result := (FChildren.Objects[Index] as TMultiNode);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.HasParent : Boolean;
  {- Returns true if parent is assigned, else returns false}
begin
  Result := (FParent <> nil);
end;
{-----------------------------------------------------------------------------}
function TMultiNode.HasChildren : Boolean;
  {- Returns true if the node contains 1 or more child nodes.}
begin
  Result := (FChildren.Count > 0);
end;
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
          {TMultiTree}
{-----------------------------------------------------------------------------}
{-----------------------------------------------------------------------------}
constructor TMultiTree.Create;
  {- creates an empty tree}
begin
  inherited Create;
  FSepChar := '\';
end;
{-----------------------------------------------------------------------------}
destructor TMultiTree.Destroy;
  {- destroys all nodes (post-order)}
var
  Curr : TMultiNode;
begin
  Curr := Root;
  while Curr <> nil do begin
    if Curr.HasChildren then
      Curr := Curr.GetChildren(0)
    else
      begin
        if Curr = Root then begin
          Curr.Free;
          exit;
        end else begin
          Curr := Curr.Parent;
          Curr.DeleteChild(0);
        end;
      end;
  end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.ChangeDir(const Key : string);
  {- Sets current directory of tree if path('Key') is valid}
var
  Node     : TMultiNode;
  Lst      : TStringList;
  i, Ndx   : integer;
  NotFound : Boolean;
begin
  if Root = nil then exit;
  NotFound := False;
  Lst := TStringList.Create;
  try
    ParseDirStr(Key, Lst);
    Node := CurrentNode;
    for i := 0 to Lst.Count - 1 do begin

      if Lst.Strings[i] = '\' then begin                               {!!.01}
        Node := Root;                                                  {!!.01}
        Continue;                                                      {!!.01}
      end                                                              {!!.01}

      else if Lst.Strings[i] = '.' then                                {!!.01}
        Continue                                                       {!!.01}

      else if Lst.Strings[i] = '..' then begin                         {!!.01}
        if Node <> Root then                                           {!!.01}
          Node := TMultiNode(Node.Parent);                             {!!.01}
      end else begin                                                   {!!.01}
        Ndx := Node.FChildren.IndexOf(Lst.Strings[i]);
        if Ndx >= 0 then
          Node := Node.GetChild(Ndx)
        else begin
          NotFound := True;
          Break;
        end;
      end;
    end;
  finally
    Lst.Free;
  end;
  if NotFound = false then
    FCurrentNode := Node;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.DeleteNode(const Key : string) : Boolean;
  {- If node found, deletes the node & returns true, else returns false}
begin
  Result := False;
  if CurrentNode <> nil then
    if CurrentNode.Contains(Key) then begin
      Result := CurrentNode.DeleteChildByName(Key);
      Dec(FCount);
    end;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.GetNode(const Key : string) : TMultiNode;
  {- Returns the node if found, else returns nil}
begin
  Result := nil;
  if CurrentNode <> nil then
    if CurrentNode.Contains(Key) then
      Result := CurrentNode.GetChildByName(Key);
end;
{-----------------------------------------------------------------------------}
function TMultiTree.Insert(ParentNode : TMultiNode;
                        const Key : string) : TMultiNode;
  {- Adds child node to specified ParentNode}
var
  NewNode : TMultiNode;
begin
  Result := nil;
  if CurrentNode = nil then begin
    {adding root node}
    NewNode := TMultiNode.Create(Key);
    FRoot := NewNode;
    FCurrentNode := NewNode;
    Result := NewNode;
  end else begin
    if not CurrentNode.Contains(Key) then begin
      Result := CurrentNode.AddChild(Key);
      Result.Parent := CurrentNode;
    end;
  end;
  Inc(FCount);
end;
{-----------------------------------------------------------------------------}
{!!.01 - Complete rewrite}
procedure TMultiTree.ParseDirStr(const Key : string; Lst : TStringList);
  {- parses Key into individual dir commands adding each to Lst}
var
  LocKey : string;
  Counter : integer;
begin
  LocKey := Key;
  Lst.Clear;

  {- are we to start from the root folder}
  Counter := 0;
  while LocKey[Counter+1] = '\' do
    inc(Counter);

  if Counter = 1 then
    Lst.Add('\');

  {- begin parsing}
  while Length(LocKey) > 0 do begin
    while LocKey[1] = '\' do
      Delete(LocKey, 1, 1);

    if pos(SepChar,LocKey) > 0 then begin
      Lst.Add(copy(LocKey, 1, Pos(SepChar, LocKey) - 1));
      Delete(LocKey, 1, Pos(SepChar, LocKey));
    end else
      if Length(LocKey) > 0 then begin
        Lst.Add(LocKey);
        LocKey := '';
      end;
  end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.PopulateSubNodes(ParentNode : TMultiNode;
                     TreeView : TTreeView; TreeNode : TTreeNode);
  {- Visits sub-nodes recursively - pre order}
var
  Curr : TMultiNode;
  i    : Integer;
  Node : TTreeNode;
begin
  Node := TreeView.Items.AddChild(TreeNode, ParentNode.Key);
  Curr := ParentNode;
  if Curr <> nil then begin
    if Curr.HasChildren then begin
      for i := 0 to Curr.ChildCount -1 do
        PopulateSubNodes(Curr.Children[i], TreeView, Node);
    end;
  end;
end;
{-----------------------------------------------------------------------------}
function TMultiTree.PopulateTreeView(TreeView : TTreeView) : Integer;
{- Populates a user-supplied TTreeView with multiway tree nodes}
var
  i        : Integer;
  TreeNode : TTreeNode;
begin
  TreeView.Items.Clear;
  if Root <> nil then begin
    TreeNode := TreeView.Items.Add(nil, Root.Key);
    if Root.HasChildren then begin
      for i := 0 to Root.ChildCount - 1 do
        PopulateSubNodes(Root.Children[i], TreeView, TreeNode);
    end;
  end;
  Result := TreeView.Items.Count
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.TraversePost(ID : Integer);
  {- Traverses tree post-order - CurrentNode after traversal will be the node
     whose EntryID = ID}
var
  i : Integer;
begin
  if Root <> nil then begin
    if Root.HasChildren then begin
      for i := 0 to Root.ChildCount - 1 do
        VisitSubNodesPost(Root.Children[i], ID);
    end;
    if (TAbDirectoryEntry(Root.FData).FEntryID = ID) then
      FCurrentNode := Root;
  end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.TraversePre(Strm : TStream);
  {- Traverses tree pre-order}
var
  i : Integer;
begin
  if Root <> nil then begin
    FIDCount := 1;
    TAbDirectoryEntry(Root.Data).FEntryID := FIDCount;

    VisitNode(Root, Strm);
    if Root.HasChildren then begin
      for i := 0 to Root.ChildCount - 1 do
        VisitSubNodesPre(Root.Children[i], Strm);
    end;
  end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitNode(Node : TMultiNode; Strm : TStream);
  {- Called recursively from VisitSubNodesPre. Assigns unique entry ID's for
     each directory entry to maintain hierarchy}
begin
  if Node.Parent = nil then
    TAbDirectoryEntry(Node.Data).ParentFolder := -1
  else
    TAbDirectoryEntry(Node.Data).ParentFolder :=
      TAbDirectoryEntry(TMultiNode(Node.Parent).Data).FEntryID;

  TAbDirectoryEntry(Node.Data).WriteToStream(TMemoryStream(Strm));
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitSubNodesPost(Node : TMultiNode; ID : Integer);
  {- Visits sub-nodes recursively - post order}
var
  Curr : TMultiNode;
  i    : Integer;
begin
  Curr := Node;
  if Curr <> nil then begin
    if Curr.HasChildren then begin
      for i := 0 to Curr.ChildCount -1 do
        VisitSubNodesPost(Curr.Children[i], ID);
    end;
    if (TAbDirectoryEntry(Curr.FData).FEntryID = ID) then
      FCurrentNode := Curr;
  end;
end;
{-----------------------------------------------------------------------------}
procedure TMultiTree.VisitSubNodesPre(Node : TMultiNode; Strm : TStream);
  {- Visits sub-nodes recursively - pre order}
var
  Curr : TMultiNode;
  i    : Integer;