ctdpak.pas

Citadel v.1.6 Full Sources

  begin
    case Reader.NextValue of
      vaList:
        begin
          WriteToLog('Packing list');
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
          while not Reader.EndOfList do
            ConvertValue('', '', nil, nil);
          Reader.ReadListEnd;
          Writer.WriteListEnd;
        end;
      vaInt8:
      begin
        WriteToLog('Packing Shortint');
        TCtdWriter(Writer).WriteValue(vaInt8);
        IntValue := Reader.ReadInteger;
        Writer.Write(IntValue, SizeOf(Shortint));
      end;
      vaInt16:
      begin
        WriteToLog('Packing Smallint');
        TCtdWriter(Writer).WriteValue(vaInt16);
        IntValue := Reader.ReadInteger;
        Writer.Write(IntValue, SizeOf(Smallint));
      end;
      vaInt32:
      begin
        WriteToLog('Packing Integer');
        TCtdWriter(Writer).WriteValue(vaInt32);
        IntValue := Reader.ReadInteger;
        Writer.Write(IntValue, SizeOf(Integer));
      end;
      vaExtended:
      begin
        WriteToLog('Packing extended');
        Writer.WriteFloat(Reader.ReadFloat);
      end;
      vaSingle:
      begin
        WriteToLog('Packing Single');
        Writer.WriteSingle(Reader.ReadSingle);
      end;
      vaCurrency:
      begin
        WriteToLog('Packing currency');
        Writer.WriteCurrency(Reader.ReadCurrency);
      end;
      vaDate:
      begin
        WriteToLog('Packing date');
        Writer.WriteDate(Reader.ReadDate);
      end;
      vaWString:
      begin
        WriteToLog('Packing wide string');
        TCtdWriter(Writer).WriteValue(Reader.ReadValue);
        Reader.Read (IntValue, SizeOf(Integer));
        Writer.Write(IntValue, SizeOf(Integer));
        GetMem(Buffer, IntValue * 2);
        Reader.Read (Buffer^, IntValue * 2);
        Writer.Write(Buffer^, IntValue * 2);
        FreeMem(Buffer, IntValue * 2);
      end;
      vaString:
      begin
        WriteToLog('Packing string');
        TCtdWriter(Writer).WriteValue(Reader.ReadValue);
        Reader.Read (ByteValue, SizeOf(Byte));
        Writer.Write(ByteValue, SizeOf(Byte));
        GetMem(Buffer, ByteValue);
        Reader.Read (Buffer^, ByteValue);
        Writer.Write(Buffer^, ByteValue);
        FreeMem(Buffer, ByteValue);
      end;
      vaLString:
      begin
        WriteToLog('Packing long string');
        TCtdWriter(Writer).WriteValue(Reader.ReadValue);
        Reader.Read (IntValue, SizeOf(Integer));
        Writer.Write(IntValue, SizeOf(Integer));
        GetMem(Buffer, IntValue);
        Reader.Read (Buffer^, IntValue);
        Writer.Write(Buffer^, IntValue);
        FreeMem(Buffer, IntValue);
      end;
      vaIdent:
        PackIdent(Reader.ReadIdent, ObjectName, OwnerName, PropTypeInfo,
          PropInfo);
      vaFalse, vaTrue, vaNil, vaNull:
      begin
        WriteToLog('Packing constant');
        if(PropTypeInfo        = nil     ) or
          (PropTypeInfo^.Kind <> tkMethod) or
          (Reader.NextValue   <> vaNil   )
        then TCtdWriter(Writer).WriteValue(Reader.ReadValue)
        else
        begin // nil event
          aux := 0;
          TCtdWriter(Writer).Write(aux, 1);
          Reader.ReadValue;
        end;
      end;
      vaBinary:
        ConvertBinary;
      vaSet:
        begin
          WriteToLog('Packing set');
          if PropTypeInfo <> nil
          then
          begin
            Reader.ReadValue;
            IntValue := 0;
            BaseType := GetTypeData(PropTypeInfo)^.CompType^;
            while True do
            begin
              S := Reader.ReadStr;
              if S = '' then
                Break;
              WriteToLog('Enum: ' + S);
              Include(TIntegerSet(IntValue), GetEnumValue(BaseType, S));
            end;
            WriteIdentInteger(IntValue);
          end
          else
          begin
            TCtdWriter(Writer).WriteValue(Reader.ReadValue);
            repeat
              s := Reader.ReadStr;
              Writer.WriteStr(s);
            until s = '';
          end;
        end;
      vaCollection: 
        begin
          WriteToLog('Packing collection');
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
          while not Reader.EndOfList do
          begin
            if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
              Writer.WriteInteger(Reader.ReadInteger);
            Reader.CheckValue(vaList);
            TCtdWriter(Writer).WriteValue(vaList);
            while not Reader.EndOfList do
              ConvertProperty(nil, '', '');
            Reader.ReadListEnd;
            Writer.WriteListEnd;
          end;
          Reader.ReadListEnd;
          Writer.WriteListEnd;
        end;
      vaInt64:
      begin
        WriteToLog('Packing int64');
        TCtdWriter(Writer).WriteValue(vaInt64);
        Int64Value := Reader.ReadInt64;
        Writer.Write(Int64Value, SizeOf(Int64));
      end;
      {$ifdef D6UP}
      vaUTF8String:
      begin
        WriteToLog('Packing UTF8 string');
        TCtdWriter(Writer).WriteValue(Reader.ReadValue);
        Reader.Read (IntValue, SizeOf(Integer));
        Writer.Write(IntValue, SizeOf(Integer));
        GetMem(Buffer, IntValue);
        Reader.Read (Buffer^, IntValue);
        Writer.Write(Buffer^, IntValue);
        FreeMem(Buffer, IntValue);
      end;
      {$endif D6UP}
      {$ifdef D9UP}
      vaDouble:
      begin
        WriteToLog('Packing double');
        TCtdWriter(Writer).WriteValue(vaDouble);
        DoubleValue := Reader.ReadDouble;
        Writer.Write(DoubleValue, SizeOf(Double));
      end;
      {$endif D9UP}
    end;
  end;

  procedure ConvertProperty(ParentTypeInfo: PTypeInfo;
    OwnerName, ObjectName: String);
  var
    aux,
    PropCount,
    PropIndex: Smallint;
    PropPath,
    PropName: string;
    I, J, L: Integer;
    PropTypeInfo: PTypeInfo;
    PropInfo: PPropInfo;
    PropPacked,
    Skip: Boolean;
  begin
    Skip         := False;
    PropTypeInfo := ParentTypeInfo;
    PropInfo     := nil;
    PropPath     := Reader.ReadStr;
    WriteToLog('Property path: ' + PropPath + ' (' +
      IntToStr(Reader.Position - Length(PropPath) - 1) + ')');
    if ParentTypeInfo = nil
    then
    begin
      WriteToLog('Property parent type unknown');
      Writer.WriteStr(PropPath);
      PropTypeInfo := nil;
    end
    else
    begin
      PropPacked := False;
      PropCount  := 1;
      for i := 1 to Length(PropPath) do
        if PropPath[i] = '.' then
          Inc(PropCount);
      WriteToLog('Property path count: ' + IntToStr(PropCount));
      I := 1;
      L := Length(PropPath);
      while True do
      begin
        J := I;
        while (I <= L) and (PropPath[I] <> '.') do Inc(I);
        PropName := Copy(PropPath, J, I - J);
        if I > (L + 1) then
          Break;
        WriteToLog('PropName: ' + PropName);
        PropInfo := GetPropInfo(PropTypeInfo, PropName);
        if PropInfo = nil
        then
        begin
          WriteToLog('Property type unknown');
          Writer.WriteStr(Copy(PropPath, J, Length(PropPath) - J + 1));
          PropTypeInfo := nil;
          Break;
        end
        else WriteToLog('Property type: ' + PropInfo.PropType^.Name);

        if(PropCount > 1) and (not PropPacked) then
        begin
          // We make it negative to differentiate
          aux := Swap(PropPathCountValue - PropCount - 1);
          Writer.Write(aux, Sizeof(aux));
          PropPacked := True;
        end;
        WriteToLog('Property index: ' + IntToStr(PropInfo.NameIndex));
        Assert(PropInfo.NameIndex < GetTypeData(PropTypeInfo)^.PropCount);
        // We make it negative to differentiate
        PropIndex := Swap(-(PropInfo.NameIndex + 1));
        Writer.Write(PropIndex, Sizeof(PropIndex));
        PropTypeInfo := PropInfo.PropType^;
        Inc(I);
      end;
    end;
    if not Skip
    then ConvertValue(ObjectName, OwnerName, PropTypeInfo, PropInfo)
    else TCtdReader(Reader).SkipValue;
  end;

  procedure ConvertObject(IsRoot: Boolean; OwnerClass: TComponentClass;
    OwnerName: String; OwnerFields: TFieldsList);
  var
    TypeInfo: PTypeInfo;
    aux,
    ObjectName: String;
    IsInline: Boolean;
    Fields: TFieldsList;
  begin
    aux := ' (' + IntToStr(Reader.Position) + ')';
    if OwnerClass <> nil
    then WriteToLog('OwnerClass: ' + OwnerClass.ClassName + aux)
    else WriteToLog('OwnerClass is unknown' + aux);
    TypeInfo :=
      ConvertHeader(OwnerClass, OwnerName, ObjectName, OwnerFields, Fields,
        IsInline, IsRoot);
    try
      if IsRoot then
      begin
        RootName  := ObjectName;
        OwnerName := ObjectName;
      end;
      while not Reader.EndOfList do
        ConvertProperty(TypeInfo, OwnerName, ObjectName);
      Reader.ReadListEnd;
      Writer.WriteListEnd;
      IsRootProperty := False;

      while not Reader.EndOfList do
        ConvertObject(False, OwnerClass, OwnerName, Fields);
    finally
      if IsInline then
        Fields.Free;
    end;

    Reader.ReadListEnd;
    Writer.WriteListEnd;
  end;

begin
  Reader := TReader.Create(Input, 4096);
  SaveSeparator := DecimalSeparator;
  DecimalSeparator := '.';
  try
    Writer := TWriter.Create(Output, 4096);
    try
      IsRootProperty := True;
      RootFields     := nil;
      try
        RootFields := TFieldsList.Create;
        if RootClass <> nil then
          GetClassFields(RootClass, RootFields);
        ConvertObject(True, RootClass, RootName, RootFields);
      finally
        RootFields.Free;
      end;
    finally
      Writer.Free;
    end;
  finally
    DecimalSeparator := SaveSeparator;
    Reader.Free;
  end;
end;

initialization

  AllowedClasses    := TStringList.Create;
  DisallowedClasses := TStringList.Create;
  AllowedClasses   .Sorted := True;
  DisallowedClasses.Sorted := True;

  // ReportBuilder allowed classes
  AllowedClasses   .Add('TppField');
  AllowedClasses   .Add('TppHeaderBand');
  AllowedClasses   .Add('TppTitleBand');
  AllowedClasses   .Add('TppDetailBand');
  AllowedClasses   .Add('TppSummaryBand');
  AllowedClasses   .Add('TppFooterBand');
  AllowedClasses   .Add('TppGroupHeaderBand');
  AllowedClasses   .Add('TppGroupFooterBand');
  AllowedClasses   .Add('TppColumnHeaderBand');
  AllowedClasses   .Add('TppColumnFooterBand');
  AllowedClasses   .Add('TppPageStyle');
  AllowedClasses   .Add('TppGroup');
  AllowedClasses   .Add('TppField');
  AllowedClasses   .Add('TppAutoSearchField');
  AllowedClasses   .Add('TppMasterFieldLink');

finalization

  AllowedClasses   .Free;
  DisallowedClasses.Free;

end.