usaveparsed.pas

DelphiDoc is a program for automatic generation of documentation on a Delphi-Project. At the momen

{  JADD - Just Another DelphiDoc: Documentation from Delphi Source Code

Copyright (C) 2003-2008   Gerold Veith

This file is part of JADD - Just Another DelphiDoc.

DelphiDoc is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License version 3 as
published by the Free Software Foundation.

DelphiDoc is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
}


unit USaveParsed;

{Contains the functions to write parsed data to a file and to load it again.
 This is done by a special stream implementing ~[linkclass TIdentStream]. }

interface

uses Windows,
     UBaseIdents;



      //"magic" bytes identifying the file as data of parsed pascal code
const FileMagic: packed array[0..7] of Char = ('J', 'A', 'D', 'D',
                                               '&', '%', '$', '#');

      //the version of the file
      FileVersion = DWORD($00000003);

      //the version of the file as binary data
      FileVersionSave: packed array[0..3] of Byte =
                       (FileVersion shr 24,
                        FileVersion shr 16 and $FF,
                        FileVersion shr 8 and $FF,
                        FileVersion and $FF);



type
  //the possible errors encountered while reading old data
  TParsedDataReadError = (
                          //the array indices could not be read (parsed), so
                          //all arrays are treated as dynamic arrays
                          pdreArrayIndicesLost);

  //the possible errors encountered while reading old data
  TParsedDataReadErrors = set of TParsedDataReadError;


      //the messages describing errors/warnings occuring while loading a file
      //of saved parsed data 
const ParsedDataReadErrorMessages: array[TParsedDataReadError] of String =
      ('The indices of arrays could not be converted from the old format into the current format. All indices are lost, all arrays will be treated as dynamic arrays (or open array parameters)!'
      );



//Writes the parsed data to the file.
procedure WriteDataToFile(const FileName: String; List: TFileList);

//Reads parsed data from the file
function ReadDataFromFile(const FileName: String;
                          var Errors: TParsedDataReadErrors): TFileList;


implementation

uses Classes, SysUtils,
     ZLib,    //if you don't have this file installed, search on your Delphi CD
     UPascalConsts,
     UExtIdents;



     //pointer on a version/an array of versions
type PIdentClassVersion = ^TIdentClassVersion;


     //a (sorted) binary tree mapping objects to integer indices;
     //used to have a faster access on the indices of identifier and files
     PClassIndexBinTree = ^TClassIndexBinTree;


     //an entry in a binary tree mapping objects to integer indices
     TClassIndexBinTree = record
                            AnObject: Pointer;     //the object that is mapped
                            Index: Integer;        //index of the object
                            Left, Right: PClassIndexBinTree; //sub entries
                          end;


//Adds objects sorted to the tree to create it.
function AddObject(Tree: PClassIndexBinTree; AnObject: Pointer;
                   Index: Integer): PClassIndexBinTree; forward;
//Balances the tree.
function BalanceTree(Tree: PClassIndexBinTree): PClassIndexBinTree; forward;
//Finds an object in the tree and returns its index.
function FindObject(Tree: PClassIndexBinTree;
                    AnObject: Pointer): Integer; forward;
//Frees the tree.
procedure FreeTree(Tree: PClassIndexBinTree); forward;

{$IFOPT C+}
//Gets the minimal and maximal levels of the leaves.
procedure GetMinMax(Tree: PClassIndexBinTree; Level: Integer;
                    var Min, Max: Integer); forward;
{$ENDIF}









   { * * *  ***  * * *  ***   TIdentStream   ***  * * *  ***  * * *  }

type
  //dynamic array of boolean values
  PBoolean = ^Boolean;

  //dynamic array of identifier classes
  PIdentifierClass = ^TIdentifierClass;




  {A class for saving or loading the parsed data (with all identifiers and
   files) into/from a stream. }
  TParsedDataStream = class(TIdentStream)
  private
    FStream: TFileStream;         //the stream to save the data into the file

    FNormalFileCount: Integer;    //number of parsed files
    //number of all parsed files, including included files
    FFileCount: Integer;
    FFileList: TFileList;         //the list of files

    FIdentifierCount: Integer;    //number of identifiers
    FIdents: TIdentifierList;     //the list of identifiers
    FFree: PBoolean;              //what identifiers should be freed

    FClassCount: Integer;         //number of different classes
    FClasses: PIdentifierClass;   //the different classes
    FClassDataVersion: PIdentClassVersion; //the versions of the classes

    //the tree of the files for faster access to their indices
    FFileTree: PClassIndexBinTree;
    //the tree of the identifiers for faster access to their indices
    FIdentifierTree: PClassIndexBinTree;



    //marker to check for errors when reading the indices of arrays
    FCheckArrayIndices: Boolean;

    //encountered errors while reading old data
    FParsedDataReadErrors: TParsedDataReadErrors;




    //Returns the index of the class in FClasses.
    function FindClassIndex(TheClass: TIdentifierClass): Integer;

    //Returns the class of identifiers by its name.
    function FindClassByName(const Name: String): TIdentifierClass;
    //Returns the class of identifiers by the index.
    function FindClassByIndex(Index: Integer): TIdentifierClass;
    //Returns the version of the data of the class.
    function FindClassVersion(TheClass: TIdentifierClass): TIdentClassVersion;
{
    //Searches the version of the data of the class.
    function SearchClassVersion(TheClass: TIdentifierClass;
                                var Version: TIdentClassVersion): Boolean;
}
  protected
    //Marks the identifier not to be freed anymore.
    procedure OwnIdent(Ident: TIdentifier); override;
  public
    //Creates the object and opens the file.
    constructor Create(const FileName: String; Write: Boolean);
    //Frees the object and closes the file.
    destructor Destroy; override;


    //Reads some bytes from the stream.
    function Read(var Buffer; Count: Longint): Longint; override;
    //Writes some bytes to the stream.
    function Write(const Buffer; Count: Longint): Longint; override;
    //Does not seek, but raises an exception.
    function Seek(Offset: Longint; Origin: Word): Longint; override;


    //Gets the version of data of identifiers of that class.
    function GetClassDataVersion(IdentClass: TIdentifierClass;
                                 var Version: TIdentClassVersion): Boolean;
                                                                      override;


    //Writes an integer value into the stream, it should be compressed.
    procedure WriteComprInt(Value: Integer); override;
    //Writes a string value into the stream.
    procedure WriteString(const Value: String); override;
    //Writes a string value into the stream, it should be compressed.
    procedure WriteComprString(const Value: String); override;
    //Writes a reference on an identifier into the stream.
    procedure WriteIdent(Ident: TIdentifier); override;
    //Writes a reference on a file into the stream.
    procedure WriteFile(TheFile: TPascalFile); override;


    //Reads an integer value from the stream, it should be compressed.
    function ReadComprInt: Integer; override;
    //Reads a string value from the stream.
    function ReadString: String; override;
    //Reads a string value from the stream, it should have been compressed.
    function ReadComprString: String; override;
    //Reads a reference on an identifier from the stream.
    function ReadIdent(Owned: Boolean = False): TIdentifier; override;
    //Reads a reference on a file from the stream.
    function ReadFile: TPascalFile; override;



    //Writes the parsed data to the file.
    procedure WriteData;

    //Reads parsed data from the file.
    procedure ReadData;



    property FileList: TFileList read FFileList write FFileList;
    property ParsedDataReadErrors: TParsedDataReadErrors
                                                    read FParsedDataReadErrors;
  end;















{Adds objects sorted to the tree to create it.
~param Tree     the tree to add the mapping to
~param AnObject the object to be mapped
~param Index    the index of the object
~result the new tree }
function AddObject(Tree: PClassIndexBinTree; AnObject: Pointer;
                   Index: Integer): PClassIndexBinTree;
begin
 if assigned(Tree) then          //place to insert not found, yet
  begin
   Result := Tree;                 //insert on the correct side
   if Cardinal(AnObject) < Cardinal(Tree.AnObject) then
    Result.Left := AddObject(Result.Left, AnObject, Index)
   else
    Result.Right := AddObject(Result.Right, AnObject, Index);
  end
 else
  begin
   New(Result);                    //create a new entry
   Result.AnObject := AnObject;    //and assign the data
   Result.Index := Index;
   Result.Left := nil;
   Result.Right := nil;
  end;
end;

{Balances the three so the leaves are on the same level (+/- 1).
~param Tree the tree to balance
~result the balanced tree }
function BalanceTree(Tree: PClassIndexBinTree): PClassIndexBinTree;

 {Makes the tree flat, to a linear list.
 ~param Tree  the tree to be flattened
 ~param Right something to append to the right end
 ~result the flattened tree }
 function Flat(Tree, Right: PClassIndexBinTree): PClassIndexBinTree;
 begin
  if not assigned(Tree) then             //end of the tree reached?
   Result := Right                         //just return the "right end"
  else
   begin
    Tree.Right := Flat(Tree.Right, Right); //flatten the right part
    Result := Flat(Tree.Left, Tree);       //flatten the left part
   end;
 end;

 {Returns the number of entries in the "flat tree" (linear list).
 ~param Tree the linear list to count the entries of
 ~result the number of entries in the flat tree }
 function FlatCount(Tree: PClassIndexBinTree): Cardinal;
 begin
  Result := 0;                           //no entries counted so far
  while assigned(Tree) do                //for every entry
   begin
    inc(Result);                           //count it
    Tree := Tree.Right;
   end;
 end;

 {Balances the flat tree to a real balanced tree.
 ~param Tree   the flat tree (linear list) to balance as a tree
 ~param Length the number of entries in hte linear list to balance to a tree
 ~result the balanced tree }
 function Balance(Tree: PClassIndexBinTree;
                  Length: Cardinal): PClassIndexBinTree;
 var      Half   :Cardinal;              //the position of the new root
 begin
  if Length = 0 then                     //no entries to balance?
   Result := nil                           //return the empty tree
  else
   begin

    Result := Tree;                        //get the new root of the tree
    for Half := 1 to Length div 2 do
     Result := Result.Right;

    Half := Length div 2;
    Result.Left := Balance(Tree, Half);    //balance both sides
    Result.Right := Balance(Result.Right, Length - Half - 1);
   end;
 end;

begin
 Tree := Flat(Tree, nil);                  //flatten the tree
 Result := Balance(Tree, FlatCount(Tree)); //and rebuild it balanced
end;

{Finds an object in the tree and returns its index.
~param Tree     the tree to search for the object
~param AnObject the object to search
~result the index of the object }
function FindObject(Tree: PClassIndexBinTree;
                    AnObject: Pointer): Integer;
begin
 assert(assigned(Tree));

 while Tree.AnObject <> AnObject do       //while not found
  begin                                     //branch to the correct side
   if Cardinal(Pointer(AnObject)) < Cardinal(Tree.AnObject) then
    Tree := Tree.Left
   else
    Tree := Tree.Right;
   assert(assigned(Tree));
  end;

 assert(assigned(Tree));
 Result := Tree.Index;                    //return the index
end;


{Frees the tree.
~param Tree the tree to free }
procedure FreeTree(Tree: PClassIndexBinTree);
begin
 if assigned(Tree) then                   //not the empty tree?
  begin
   FreeTree(Tree.Left);                     //free both sides
   FreeTree(Tree.Right);
   Dispose(Tree);                           //free this node
  end;
end;


{$IFOPT C+}

{Gets the minimal and maximal levels of the leaves.
~param Tree  the tree to get the extrem levels of
~param Level the current level, has to be 1 when called initially
~param Min   the minimum depth of a leaf, has to be initialized with High(Min)
~param Max   the maxmimum depth of a leaf, has to be initialized with -1 or 0 }
procedure GetMinMax(Tree: PClassIndexBinTree; Level: Integer;
                    var Min, Max: Integer);
begin
 if assigned(Tree.Left) or assigned(Tree.Right) then //not a leaf node?
  begin
   if assigned(Tree.Left) then                         //recurse in sub nodes
    GetMinMax(Tree.Left, Level + 1, Min, Max);
   if assigned(Tree.Right) then
    GetMinMax(Tree.Right, Level + 1, Min, Max);
  end
 else
  begin
   if Level > Max then                                 //adjust min and max
    Max := Level;
   if Level < Min then
    Min := Level;
  end;
end;

{$ENDIF}