ctdpak.pas

Citadel v.1.6 Full Sources

unit ctdPak;

interface

{$INCLUDE ctdDefs.inc}

uses Windows, Classes, Consts, SysUtils, Controls, Dialogs;

type
  TFieldsList = class(TStringList)
  public
    OwnCount: Integer; // Fields count without including parents' fields
  end;

  procedure GetClassFields(AClass: TClass; Fields: TStringList);
  procedure CtdObjectBinaryToPacked(RootClass: TComponentClass;
    Input, Output: TStream; RunTimeLog: Boolean);

var
  Palette: TStringList;

implementation

uses
  {$ifdef D6UP}
  RTLConsts,
  {$endif D6UP}
  Forms, TypInfo, ToolsAPI, ctdWork, ctdUnpak, ctdAux;

type
  TCtdReader = class(TReader);
  TCtdWriter = class(TWriter);

var
  AllowedClasses,
  DisallowedClasses: TStringList;

procedure GetClassFields(AClass: TClass; Fields: TStringList);

  type
    PFieldClassTable = ^TFieldClassTable;
    TFieldClassTable = packed record
    Count: Smallint;
      Classes: array[0..8191] of ^TPersistentClass;
    end;

  function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
  asm
          MOV     EAX,[EAX].vmtFieldTable
          OR      EAX,EAX
          JE      @@1
          MOV     EAX,[EAX+2].Integer
    @@1:
  end;

  procedure GetFieldListFromTable(Table: PFieldClassTable; List: TStringList);
  var
    i: Integer;
  begin
    for i := 0 to Table^.Count - 1 do
      List.AddObject(Table^.Classes[i]^.ClassName, TObject(Table^.Classes[i]^));
  end;

  procedure GetFieldsFromText(Fields: TStringList; const AClass: TClass;
    const Text: PChar; const Size: Integer);

    function LocateClassDeclaration(const ClassName, ClasssParent: String;
      Lines: TStringList; var FirstLine: Integer): Boolean;
    var
      Line,
      ClassDeclarationText: String;
    begin
      Result := False;
      ClassDeclarationText := ClassName + '=class(';
      while(not Result) and (FirstLine < Lines.Count) do
      begin
        if Pos(ClassName, Lines[FirstLine]) = 0
        then Inc(FirstLine)
        else
        begin
          Line := TrimSpaces(Lines[FirstLine], Length(ClassDeclarationText));
          if CompareText(ClassDeclarationText, Line) <> 0
          then Inc(FirstLine)
          else Result := True;
        end;
      end;
    end;

    function CleanLine(const Str: String): String;
    var
      P: Integer;
    begin
      Result := Str;
      P := Pos('//', Str);
      if P <> 0 then
        Result := Copy(Result, 0, P-1);
      Result := TrimSpaces(Result, Length(Result));
    end;

    function GetIdentifier(const Text: String; var Index: Integer): String;
    var
      i: Integer;
    begin
      SetLength(Result, Length(Text) - Index + 1);
      i := 1;
      while Index <= Length(Text) do
      begin
        if{$ifdef D12UP}CharInSet(Text[Index],{$else}(Text[Index] in{$endif D12UP}['a'..'z', 'A'..'Z', '0'..'9', '_'])
        then
        begin
          Result[i] := Text[Index];
          Inc(i);
          Inc(Index);
        end
        else break;
      end;
      SetLength(Result, i-1);
    end;

    function GetFieldFromLine(const Text: String; var FieldClass: String): Boolean;
    var
      Index: Integer;
    begin
      Result := False;
      Index  := 1;
      if GetIdentifier(Text, Index) = '' then
        exit;
      if Text[Index] <> ':' then
        exit;
      Inc(Index);
      FieldClass := GetIdentifier(Text, Index);
      if FieldClass = '' then
        exit;
      if Text[Index] <> ';' then
        exit;
      if Length(Text) = Index then
        Result := True;
    end;

  var
    Lines: TStringList;
    i: Integer;
    S,
    ClassName,
    FieldClass,
    Line: String;
    FirstLine: Integer;
    auxPos,
    StartPos,
    EndPos: PChar;
    Found: Boolean;
    {$ifdef D6UP}
    OldGroup: TPersistentClass;
    {$endif D6UP}
  begin
    {$ifdef D6UP}
    OldGroup := ActivateClassGroup(TControl);
    try
    {$endif D6UP}
      ClassName := AClass.ClassName;
      Lines := TStringList.Create;
      try
        Found := True;
        auxPos := Text;
        repeat
          StartPos := StrPos(auxPos, 'interface');
          auxPos := StartPos + 1;
          if StartPos = nil
          then
          begin
            StartPos := Text;
            Found    := False;
          end
          else
          begin
            if not({$ifdef D12UP}CharInSet(StartPos[-1],{$else}(StartPos[-1] in{$endif D12UP}[#10, #13])) or
               not({$ifdef D12UP}CharInSet(StartPos[ 9],{$else}(StartPos[ 9] in{$endif D12UP}[#9, #10, #13, ' ']))
            then StartPos := nil
            else StartPos := StartPos + 10;
          end;
        until StartPos <> nil;

        auxPos := StartPos;
        repeat
          EndPos := StrPos(auxPos, 'implementation');
          auxPos := EndPos + 1;
          if EndPos = nil
          then
          begin
            EndPos := @Text[Length(Text)-1];
            Found  := False;
          end
          else
          begin
            if not({$ifdef D12UP}CharInSet(EndPos[-1],{$else}(EndPos[-1] in{$endif D12UP}[#10, #13])) or
               not({$ifdef D12UP}CharInSet(EndPos[14],{$else}(EndPos[14] in{$endif D12UP}[#9, #10, #13, ' '])) then
              EndPos := nil;
          end;
        until EndPos <> nil;

        if Found
        then
        begin
          SetString(S, StartPos, EndPos - StartPos);
          Lines.SetText(PChar(S));
        end
        else Lines.SetText(Text);

        FirstLine := 0;
        if LocateClassDeclaration(ClassName, AClass.ClassParent.ClassName, Lines,
             FirstLine)
        then
        begin
          Inc(FirstLine);
          for i := FirstLine to Lines.Count-1 do
          begin
            Line := CleanLine(Lines[i]);
            if Line <> '' then
            begin
              if GetFieldFromLine(Line, FieldClass)
              then
              begin
                if Fields.IndexOf(FieldClass) = -1 then
                  Fields.AddObject(FieldClass, TObject(GetClass(FieldClass)));
              end
              else break;
            end;
          end;
        end
        else raise Exception.Create('Citadel error: declaration of class ' +
                                      ClassName + ' not found');
      finally
        Lines.Free;
      end;
    {$ifdef D6UP}
    finally
      ActivateClassGroup(OldGroup);
    end;
    {$endif D6UP}
  end;

  procedure GetFieldListFromModule(const ClassName: String; Fields: TStringList);
  var
    Project: IOTAProject40;
    Module: IOTAModule;
    FormName: String;
    Editor: IOTASourceEditor;
    Reader: IOTAEditReader;
    i,
    j,
    CurPos,
    Size: Integer;
    Buffer: array [0..8191] of AnsiChar;
    Text: PChar;
  begin
    Project := GetActiveProject;
    FormName := Copy(ClassName, 2, Length(ClassName)-1);
    for i := 0 to Project.GetModuleCount-1 do
    begin
      if(CompareText(Project.GetModule(i).FormName, FormName) = 0) and
        (Project.GetModule(i).FileName <> '')                      then
      begin
        Module := (BorlandIDEServices as IOTAModuleServices).FindModule(
          Project.GetModule(i).FileName);
        Assert(Module <> nil);
        for j := 0 to Module.GetModuleFileCount-1 do
        begin
          if Module.GetModuleFileEditor(j).
               QueryInterface(IOTASourceEditor, Editor) = S_OK then
          begin
            Assert(Editor <> nil);
            GetMem(Text, MaxPasSize); 
            try
              Reader := Editor.CreateReader;
              try
                CurPos := 0;
                repeat
                  Size := Reader.GetText(CurPos, Buffer, SizeOf(Buffer));
                  if CurPos + Size > MaxPasSize then
                    raise Exception.Create('Unit ''' + Project.GetModule(i).FileName + ''' too big');
                  MoveMemory(@Text[CurPos], @Buffer, Size);
                  Inc(CurPos, Size);
                until Size < SizeOf(Buffer);
              finally
                Reader := nil;
              end;
              GetFieldsFromText(Fields, AClass, Text, CurPos);
            finally
              FreeMem(Text);
            end;
          end;
        end;
        break;
      end;
    end;
  end;

  procedure GetFields(AClass: TClass; Fields: TStringList);
  var
    ClassTable: PFieldClassTable;
  begin
    ClassTable := GetFieldClassTable(AClass);
    if ClassTable <> nil
    then GetFieldListFromTable(ClassTable, Fields)
    else GetFieldListFromModule(AClass.ClassName, Fields);
  end;

var
  SubFields: TStringList;
  First: Boolean;
begin
  if AClass = nil
    then exit;

  First := True;
  SubFields := TStringList.Create;
  try
    while AClass <> TPersistent do
    begin
      GetFields(AClass, SubFields);
      if First and (Fields is TFieldsList) then
        TFieldsList(Fields).OwnCount := SubFields.Count;
      Fields.AddStrings(SubFields);
      SubFields.Clear;
      AClass := AClass.ClassParent;
      First  := False;
    end;
  finally
    SubFields.Free;
  end;
end;

procedure CtdObjectBinaryToPacked(RootClass: TComponentClass;
  Input, Output: TStream; RunTimeLog: Boolean);
var
  SaveSeparator: Char;
  Reader: TReader;
  Writer: TWriter;
  IsRootProperty: Boolean;
  RootName: String;
  RootFields: TFieldsList;

  procedure ConvertValue(ObjectName, OwnerName: String;
    PropTypeInfo: PTypeInfo; PropInfo: PPropInfo); forward;

  function ConvertHeader(var OwnerClass: TComponentClass;
    var OwnerName, ObjectName: String; OwnerFields: TFieldsList;
    var Fields: TFieldsList; var IsInline: Boolean; IsRoot: Boolean): PTypeInfo;
  var
    Flags: TFilerFlags;
    Position: Integer;
    ClassName,
    aux: string;
    ClassIndex: Smallint;
    Size: Shortint;
    ComponentClass: TComponentClass;