ctdpak.pas

Citadel v.1.6 Full Sources

    {$ifdef D6UP}
    OldGroup: TPersistentClass;
    {$endif D6UP}
    Allowed,
    Disallowed: Boolean;
    FieldsCount: Word;
    IsInherited: Boolean;
  begin
    Result         := nil;
    ClassIndex     := -1;
    ComponentClass := nil;
    Reader.ReadPrefix(Flags, Position);
    IsInline    := ffInline    in Flags;
    IsInherited := ffInherited in Flags;

    if IsInline then
      WriteToLog('Inline');
    if ffChildPos in Flags then
      WriteToLog('ChildPos');
    if IsInherited then
    begin
      if IsRoot
      then
      begin
        if OwnerClass <> nil
        then WriteToLog('Inherited from ' + OwnerClass.ClassParent.ClassName)
        else WriteToLog('Inherited from unknown');
      end
      else WriteToLog('Inherited');
    end;

    ClassName := Reader.ReadStr;
    WriteToLog('ClassName: ' + ClassName);

    Allowed := AllowedClasses.IndexOf(ClassName) <> -1;
    if not Allowed
    then
    begin
      Disallowed := DisallowedClasses.IndexOf(ClassName) <> -1;
      if Disallowed then
        WriteToLog('Disallowed class');
    end
    else
    begin
      WriteToLog('Allowed class');
      Disallowed := False;
    end;

    if(not Disallowed) and (OwnerClass <> nil) then
    begin
      if CompareText(ClassName, OwnerClass.ClassName) = 0
      then
      begin
        ComponentClass := OwnerClass;
        ClassIndex     := Swap(Low(Smallint));
      end
      else
      begin
        ClassIndex := OwnerFields.IndexOf(ClassName);
        if(not IsInherited) and (ClassIndex >= OwnerFields.OwnCount) then
          ClassIndex := -1;
        if ClassIndex <> -1
        then ClassIndex := Swap(Low(Smallint) + ClassIndex + 1)
        else
        begin
          if Palette.IndexOf(ClassName) <> -1
          then raise Exception.Create('Class ' + ClassName + ' not found in ' +
                 OwnerClass.ClassName + '''s fields')
          else WriteToLog('Class not found in fields');
        end;
      end;
    end;

    if(not Disallowed) and (ComponentClass = nil) then
    begin
      if Allowed or (ClassIndex <> -1) or (Palette.IndexOf(ClassName) <> -1) then
      begin
        {$ifdef D6UP}
        OldGroup := ActivateClassGroup(TControl);
        try
        {$endif D6UP}
          ComponentClass := TComponentClass(GetClass(ClassName));
        {$ifdef D6UP}
        finally
          ActivateClassGroup(OldGroup);
        end;
        {$endif D6UP}
      end;

      if ComponentClass = nil then
        ComponentClass := GetComponentFromModule(nil, ClassName);
    end;

    Assert(not((ClassIndex <> -1) and (ComponentClass = nil)));

    if(ComponentClass <> nil)               and
       IsInherited                          and
      (ComponentClass.InheritsFrom(TFrame)) then
    begin
      Include(Flags, ffInline);
      IsInline := True;
      WriteToLog('Inline');
    end;

    TCtdWriter(Writer).WritePrefix(Flags, Position);

    if ClassIndex <> -1
    then
    begin
      WriteToLog('Class packed');
      Writer.Write(ClassIndex, SizeOf(ClassIndex));
    end
    else Writer.WriteStr(ClassName);

    if not IsInline
    then Fields := OwnerFields
    else
    begin
      Fields := TFieldsList.Create;
      GetClassFields(ComponentClass, Fields);
    end;
    FieldsCount := Fields.Count;

    if ComponentClass <> nil then
    begin
      Result := ComponentClass.ClassInfo;
      WriteToLog('ComponentClass: ' + ComponentClass.ClassName);
      WriteToLog('PropCount: ' + IntToStr(GetTypeData(Result)^.PropCount));
      if IsRoot or IsInline then
        WriteToLog('FieldsCount: ' + IntToStr(FieldsCount));

      if ClassIndex <> -1 then
      begin
        if RunTimeLog then
        begin
          Writer.Write(GetTypeData(Result)^.PropCount, SizeOf(Word));

          if IsRoot or IsInline then
            Writer.Write(FieldsCount, SizeOf(Word));
        end;
      end;
    end
    else WriteToLog('ComponentClass unknown');

    ObjectName := Reader.ReadStr;
    WriteToLog('ObjectName: ' + ObjectName);
    if Copy(ClassName , 2, Length(ClassName) - 1) =
       Copy(ObjectName, 1, Length(ClassName) - 1)
    then 
    begin
      Size := -Length(ObjectName);
      Writer.Write(Size, SizeOf(Byte));
      if Length(ObjectName) > (Length(ClassName) - 1) then
      begin
        aux := Copy(ObjectName, Length(ClassName),
          Length(ObjectName) - (Length(ClassName) - 1));
        Writer.Write(aux[1], Length(aux));
      end;
    end
    else Writer.WriteStr(ObjectName);

    if IsInline then
    begin
      OwnerClass := ComponentClass;
      OwnerName  := ObjectName;
      WriteToLog('New Owner: ' + ObjectName);
    end;
  end;

  procedure ConvertBinary;
  const
    BufSize = 4096;
  var
    Buffer: PChar;
    N,
    Count: Integer;
  begin
    WriteToLog('Packing binary');
    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, BufSize);
    end;
  end;

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

  procedure WriteIdentInteger(Value: Longint);
  begin
    if (Value >= Low(ShortInt)) and (Value <= High(ShortInt)) then
    begin
      TCtdWriter(Writer).WriteValue(TValueType(vaIdentInt8));
      Writer.Write(Value, SizeOf(Shortint));
    end else
    if (Value >= Low(SmallInt)) and (Value <= High(SmallInt)) then
    begin
      TCtdWriter(Writer).WriteValue(TValueType(vaIdentInt16));
      Writer.Write(Value, SizeOf(Smallint));
    end
    else
    begin
      TCtdWriter(Writer).WriteValue(TValueType(vaIdentInt32));
      Writer.Write(Value, SizeOf(Integer));
    end;
  end;

  procedure SetIntIdent(PropTypeInfo: PTypeInfo; const Ident: string);
  var
    V: Longint;
    IdentToInt: TIdentToInt;
    IntToIdent: TIntToIdent;
    Ident2: String;
  begin
    IdentToInt := FindIdentToInt(PropTypeInfo);
    IntToIdent := FindIntToIdent(PropTypeInfo);
    if Assigned(IdentToInt) and IdentToInt(Ident, V ) and
       Assigned(IntToIdent) and IntToIdent(V, Ident2) and (Ident = Ident2)
    then WriteIdentInteger(V)
    else Writer.WriteIdent(Ident);
  end;

  procedure SetEnumIdent(PropTypeInfo: PTypeInfo; const Ident: string);
  var
    V: Integer;
  begin
    V := GetEnumValue(PropTypeInfo, Ident);
    if V = -1
    then
    begin
      WriteToLog('Error getting enum value');
      Writer.WriteIdent(Ident);
    end
    else
    begin
      if Ident = GetEnumName(PropTypeInfo, V)
      then WriteIdentInteger(V)
      else Writer.WriteIdent(Ident);
    end;
  end;

  procedure PakEvent(Ident, ObjectName, OwnerName: String;
    PropInfo: PPropInfo);
  var
    EventPart,
    EventName: String;
    aux: Byte;
  begin
    if OwnerName <> RootName then
      ObjectName := OwnerName + ObjectName;
    if(PropInfo.Name[1] = 'O') and (PropInfo.Name[2] = 'n')
    then EventPart := Copy(PropInfo.Name, 3, Length(PropInfo.Name) - 2)
    else EventPart := PropInfo.Name;

    aux := 0;
    if Copy(Ident, 1, Length(ObjectName)) = ObjectName
    then
    begin
      EventName := ObjectName + EventPart;
      aux := 255;
    end
    else if IsRootProperty then
    begin
      if Copy(Ident, 1, 4) = 'Form'
      then
      begin
        aux := 254;
        EventName := 'Form' + EventPart;
      end
      else if Copy(Ident, 1, 10) = 'DataModule'
      then
      begin
        aux := 253;
        EventName := 'DataModule' + EventPart;
      end
      else if Copy(Ident, 1, 5) = 'Frame' then
      begin
        aux := 252;
        EventName := 'Frame' + EventPart;
      end;
    end;

    if(aux <> 0) and (EventName = Ident)
    then Writer.Write(aux, 1)
    else Writer.WriteStr(Ident);
  end;

  procedure PackIdent(Ident, ObjectName, OwnerName: String;
    PropTypeInfo: PTypeInfo; PropInfo: PPropInfo);
  begin
    WriteToLog('Packing ident ' + Ident);
    if PropTypeInfo = nil
    then Writer.WriteIdent(Ident)
    else
    begin
      case PropTypeInfo^.Kind of
        tkInteger    :
        begin
          WriteToLog('Identifier is integer');
          SetIntIdent(PropTypeInfo, Ident);
        end;
        tkEnumeration:
        begin
          WriteToLog('Identifier is enum');
          SetEnumIdent(PropTypeInfo, Ident);
        end;
        tkMethod     :
        begin
          WriteToLog('Identifier is event');
          PakEvent(Ident, ObjectName, OwnerName, PropInfo);
        end;
{        tkClass:
          case NextValue of
            vaNil:
              begin
                ReadValue;
                SetOrdProp(Instance, PropInfo, 0)
              end;
            vaCollection:
              begin
                ReadValue;
                ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
              end
          else
            SetObjectIdent(Instance, PropInfo, ReadIdent);
          end;}
        else Writer.WriteIdent(Ident);
      end;
    end;
  end;

  procedure ConvertValue(ObjectName, OwnerName: String; PropTypeInfo: PTypeInfo;
    PropInfo: PPropInfo);
  var
    S: string;
    IntValue: Integer;
    Int64Value: Int64;
    ByteValue: Byte;
    Buffer: Pointer;
    BaseType: PTypeInfo;
    aux: Byte;
    {$ifdef D9UP}
    DoubleValue: Double;
    {$endif D9UP}