ctdunpak.pas

Citadel v.1.6 Full Sources

unit ctdUnpak;

interface

{$INCLUDE ctdDefs.inc}

uses Windows, Classes, Consts, Controls, ctdAux;

const
  MaxPropPathCount   = 100;
  PropPathCountValue = (Low(Smallint) + 1) + MaxPropPathCount;

  vaIdentInt8  = 255;
  vaIdentInt16 = 254;
  vaIdentInt32 = 253;
  vaIdentInt64 = 252;

  procedure CtdObjectPackedToBinary(RootClass: TComponentClass;
    Input, Output: TStream);
  {$ifndef CtdNoRTLog}
  procedure CtdDummyWriteToLog(const Text: String;
    LogMode: TCtdLogModes = [lmLogOnly, lmSecondary]);
  {$endif CtdNoRTLog}

var
  DsgnGetFieldClassByIndexRoutine: function(AClass: TClass; var Index: Smallint): TPersistentClass = nil;
  {$ifndef CtdNoRTLog}
  WriteToLog: procedure(const Text: String;
    LogMode: TCtdLogModes = [lmLogOnly, lmSecondary]);
  {$endif CtdNoRTLog}
  RuntimeLog: Boolean = False;

implementation

uses
  {$ifdef D6UP}
  RTLConsts,
  {$endif D6UP}
  SysUtils,
  TypInfo;

type
  TCtdWriter = class(TWriter);

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

{$ifndef CtdNoRTLog}
procedure CtdDummyWriteToLog(const Text: String;
  LogMode: TCtdLogModes = [lmLogOnly, lmSecondary]);
begin
end;
{$endif CtdNoRTLog}

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

function GetFieldClassByIndex(AClass: TClass; var Index: Smallint): TPersistentClass;
var
  Found,
  GetCount: Boolean;
  Count: SmallInt;
  ClassTable: PFieldClassTable;
  aux: TClass;
begin
  Result   := nil;
  GetCount := Index = High(Smallint);
  Count    := 0;
  if Assigned(DsgnGetFieldClassByIndexRoutine)
  then Result := DsgnGetFieldClassByIndexRoutine(AClass, Index)
  else
  begin
    aux        := AClass;
    ClassTable := nil;
    Found      := False;
    while(not Found) and (aux <> TPersistent) do
    begin
      ClassTable := GetFieldClassTable(aux);
      if ClassTable <> nil then
      begin
        Inc(Count, ClassTable.Count);
        if Index >= ClassTable.Count
        then Dec(Index, ClassTable.Count)
        else Found := True;
      end;
      if not Found then
        aux := aux.ClassParent;
    end;
    if Found
    then Result := ClassTable^.Classes[Index]^
    else
    begin
      if GetCount
      then Index := Count
      else raise Exception.Create(
                   'Citadel error: class index ' + IntToStr(Index) +
                   ' not found in class ' + AClass.ClassName);
    end;
  end;
end;

function GetFieldClassByName(AClass: TClass; Name: String): TComponentClass;
var
  Found: Boolean;
  ClassTable: PFieldClassTable;
  aux: TClass;
  i: Integer;
begin
  aux        := AClass;
  Result     := nil;
  Found      := False;
  while(not Found) and (aux <> TPersistent) do
  begin
    ClassTable := GetFieldClassTable(aux);
    if ClassTable <> nil then
    begin
      for i := 0 to ClassTable^.Count - 1 do
      begin
        Found := CompareText(ClassTable^.Classes[i]^.ClassName, Name) = 0;
        if Found then
        begin
          Result := TComponentClass(ClassTable^.Classes[i]^);
          break;
        end;
      end;
    end;
    if not Found then
      aux := aux.ClassParent;
  end;
end;

procedure CtdObjectPackedToBinary(RootClass: TComponentClass;
  Input, Output: TStream);
var
  SaveSeparator: Char;
  Reader: TReader;
  Writer: TWriter;
  RootName: String;

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

  function ReadStringIndex(var Index: Smallint; var Str: String): Boolean;
  var
    auxW: Smallint;
    auxC: Char;
    Length: Integer;
  begin
    Reader.Read(auxW, 2);
    auxC := Char(Lo(auxW));
    if auxC > 'z'
    then // It's an index
    begin
      auxW   := Swap(auxW);
      Index  := -auxW - 1;
      Result := True;
    end
    else // It's a string
    begin
      Length := Lo(auxW);
      SetString(Str, PChar(nil), Length);
      Str[1] := Char(Hi(auxW));
      Reader.Read(Str[2], Length - 1);
      Index := -1;
      Result := False;
    end;
  end;
                                                   
  function ConvertHeader(var OwnerClass: TComponentClass;
    var OwnerName, ObjectName, ClassName: String; IsRoot: Boolean): PTypeInfo;
  var
    Flags: TFilerFlags;
    Position: Integer;
    aux: string;
    Index,
    FieldIndex: Smallint;
    Size: Shortint;
    ComponentClass: TComponentClass;
    IsInline,
    IsInherited: Boolean;
    {$ifdef D6UP}
    OldGroup: TPersistentClass;
    {$endif D6UP}
    {$ifndef CtdNoRTLog}
    auxClass: TClass;
    DsgPropCount,
    PropCount: Word;
    FieldsCount,
    DsgFieldsCount: Smallint;
    {$endif CtdNoRTLog}
  begin
    Result         := nil;
    ComponentClass := nil;
    Reader.ReadPrefix(Flags, Position);
    IsInline    := ffInline    in Flags;
    IsInherited := ffInherited in Flags;
    if IsInline and IsInherited then
      Exclude(Flags, ffInline);
    TCtdWriter(Writer).WritePrefix(Flags, Position);

    {$ifndef CtdNoRTLog}
    if IsInline then
      WriteToLog('Inline');
    if ffChildPos in Flags then
      WriteToLog('ChildPos');
    if IsInherited then
      WriteToLog('Inherited');
    {$endif CtdNoRTLog}

    if ReadStringIndex(Index, ClassName)
    then
    begin
      {$ifndef CtdNoRTLog}
      WriteToLog('Class is packed');
      {$endif CtdNoRTLog}
      if Index = -(Low(Smallint) + 1)
      then
      begin
        Assert(RootClass <> nil);
        ComponentClass := RootClass;
      end
      else
      begin
        if OwnerClass <> nil then
        begin
          FieldIndex := -(Low(Smallint) + Index + 2);
          Assert(OwnerClass <> nil);
          ComponentClass :=
            TComponentClass(GetFieldClassByIndex(OwnerClass, FieldIndex));
        end;
      end;
      Assert(ComponentClass <> nil);
      ClassName := ComponentClass.ClassName;
    end
    else
    begin
      if ComponentClass = nil then
      begin
        {$ifdef D6UP}
        OldGroup := ActivateClassGroup(TControl);
        try
        {$endif D6UP}
          ComponentClass := TComponentClass(GetClass(ClassName));
        {$ifdef D6UP}
        finally
          ActivateClassGroup(OldGroup);
        end;
        {$endif D6UP}

        if(ComponentClass = nil) and
          (not Assigned(DsgnGetFieldClassByIndexRoutine)) then
          ComponentClass := GetFieldClassByName(OwnerClass, ClassName);
      end;
    end;

    {$ifndef CtdNoRTLog}
    WriteToLog('ClassName: ' + ClassName);
    {$endif CtdNoRTLog}

    if ComponentClass <> nil
    then
    begin
      {$ifndef CtdNoRTLog}
      WriteToLog('ComponentClass: ' + ComponentClass.ClassName);
      {$endif CtdNoRTLog}

      Result := PTypeInfo(ComponentClass.ClassInfo);
      {$ifndef CtdNoRTLog}
      if(Index <> -1) and RunTimeLog then
      begin
        Reader.Read(DsgPropCount, SizeOf(Word));
        PropCount := GetTypeData(Result)^.PropCount;
        WriteToLog('PropCount: ' + IntToStr(PropCount));
        auxClass  := ComponentClass;
        while PropCount > DsgPropCount do
        begin
          auxClass := auxClass.ClassParent;
          PropCount := GetTypeData(PTypeInfo(auxClass.ClassInfo))^.PropCount;
        end;
        if PropCount <> DsgPropCount then
          raise Exception.Create('Citadel error: properties count for ' +
            ClassName + ' differs at design (' + IntToStr(DsgPropCount) +
            ') and runtime (' + IntToStr(PropCount) + ')');

        if IsRoot or IsInline  then
        begin
          Reader.Read(DsgFieldsCount, SizeOf(Word));
          FieldsCount := High(Smallint);
          GetFieldClassByIndex(ComponentClass, FieldsCount);
          WriteToLog('FieldsCount: ' + IntToStr(FieldsCount));
          if FieldsCount <> DsgFieldsCount then
            raise Exception.Create('Citadel error: fields count for ' +
              ClassName + ' differs at design (' + IntToStr(DsgFieldsCount) +
              ') and runtime (' + IntToStr(FieldsCount) + ')');
        end;
      end
      else
      begin
        WriteToLog('PropCount: ' + IntToStr(GetTypeData(Result)^.PropCount));
        if IsRoot or IsInline  then
        begin
          FieldsCount := High(Smallint);
          GetFieldClassByIndex(ComponentClass, FieldsCount);
          WriteToLog('FieldsCount: ' + IntToStr(FieldsCount));
        end;
      end;
      {$endif CtdNoRTLog}
    end
    {$ifndef CtdNoRTLog}
    else WriteToLog('ComponentClass unknown');
    {$else};
    {$endif CtdNoRTLog}

    Writer.WriteStr(ClassName);

    if Shortint(Reader.NextValue) < 0
    then
    begin
      ObjectName := Copy(ClassName, 2, Length(ClassName) - 1);
      Reader.Read(Size, SizeOf(Byte));
      Size := (-Size) - Length(ObjectName);
      if Size > 0 then
      begin
        SetString(aux, PChar(nil), Size);
        Reader.Read(aux[1], Size);
        ObjectName := ObjectName + aux;
      end;
    end
    else ObjectName := Reader.ReadStr;
    Writer.WriteStr(ObjectName);

    {$ifndef CtdNoRTLog}
    WriteToLog('ObjectName: ' + ObjectName);
    {$endif CtdNoRTLog}

    if IsInline then
    begin
      OwnerClass := ComponentClass;
      OwnerName  := ObjectName;

      {$ifndef CtdNoRTLog}
      WriteToLog('New Owner: ' + ObjectName);
      {$endif CtdNoRTLog}
    end;
  end;

  procedure ConvertBinary;
  const
    BufSize = 4096;
  var
    Buffer: PChar;
    N,
    Count: Integer;
  begin
    {$ifndef CtdNoRTLog}
    WriteToLog('Unpacking binary');
    {$endif CtdNoRTLog}
    TCtdWriter(Writer).WriteValue(Reader.ReadValue);
    Reader.Read(Count, SizeOf(Count));
    Writer.Write(Count, SizeOf(Count));
    GetMem(Buffer, BufSize);
    try
      while Count > 0 do
      begin
        if Count > BufSize
        then N := BufSize
        else N := Count;
        Reader.Read(Buffer^, N);
        Writer.Write(Buffer^, N);
        Dec(Count, N);
      end;
    finally
      FreeMem(Buffer);
    end;
  end;

  procedure ConvertProperty(TypeInfo: PTypeInfo;
    ObjectName, OwnerName, ClassName: String); forward;

  procedure UnpackInt(ValueType: TValueType; Value: Integer);
  begin
    case ValueType of
      vaInt8:
      begin
        {$ifndef CtdNoRTLog}
        WriteToLog('Unpacking Shortint');
        {$endif CtdNoRTLog}
        TCtdWriter(Writer).WriteValue(vaInt8);
        Writer.Write(Value, SizeOf(Shortint));
      end;
      vaInt16:
      begin
        {$ifndef CtdNoRTLog}
        WriteToLog('Unpacking Smallint');
        {$endif CtdNoRTLog}
        TCtdWriter(Writer).WriteValue(vaInt16);
        Writer.Write(Value, SizeOf(Smallint));
      end;
      vaInt32:
      begin
        {$ifndef CtdNoRTLog}
        WriteToLog('Unpacking Integer');
        {$endif CtdNoRTLog}
        TCtdWriter(Writer).WriteValue(vaInt32);
        Writer.Write(Value, SizeOf(Integer));
      end;
    end;
  end;

  procedure SetIdentInt(ValueType: TValueType; PropTypeInfo: PTypeInfo;
    const Value: Integer);
  var
    IntToIdent: TIntToIdent;
    Ident: string;
  begin
    IntToIdent := FindIntToIdent(PropTypeInfo);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident)
    then
    begin
      {$ifndef CtdNoRTLog}
      WriteToLog('Ident: ' + Ident);
      {$endif CtdNoRTLog}
      Writer.WriteIdent(Ident);
    end
    else
    begin
      {$ifndef CtdNoRTLog}
      WriteToLog('Warning: can''t read identifier. Using integer value (' + IntToStr(Value) + ').');
      {$endif CtdNoRTLog}
      Writer.WriteInteger(Value);
    end;
  end;

  procedure SetSetInt(PropTypeInfo: PTypeInfo; const Value: Integer);
  var
    i: Integer;
    BaseType: PTypeInfo;