ctdunpak.pas

Citadel v.1.6 Full Sources

    {$ifndef CtdNoRTLog}
    aux: String;
    {$endif CtdNoRTLog}
  begin
    {$ifndef CtdNoRTLog}
    WriteToLog('Unpacking set');
    {$endif CtdNoRTLog}
    BaseType := GetTypeData(PropTypeInfo)^.CompType^;
    TCtdWriter(Writer).WriteValue(vaSet);
    for i := 0 to SizeOf(TIntegerSet) * 8 - 1 do
      if i in TIntegerSet(Value) then
      begin
        {$ifndef CtdNoRTLog}
        aux := GetEnumName(BaseType, i);
        Writer.WriteStr(aux);
        WriteToLog('Enum: ' + aux);
        {$else}
        Writer.WriteStr(GetEnumName(BaseType, i));
        {$endif CtdNoRTLog}
      end;
    Writer.WriteStr('');
  end;

  procedure UnpackIdent(ValueType: TValueType; Value: Integer;
    PropTypeInfo: PTypeInfo);
  {$ifndef CtdNoRTLog}
  var
    aux: String;
  {$endif CtdNoRTLog}
  begin
    if PropTypeInfo = nil
    then raise Exception.Create('Can''t read identifier: unknown type')
    else
    begin
      case PropTypeInfo.Kind of
        tkEnumeration:
        begin
          {$ifndef CtdNoRTLog}
          aux := GetEnumName(PropTypeInfo, Value);
          Writer.WriteIdent(aux);
          WriteToLog('Enum: ' + aux);
          {$else}
          Writer.WriteIdent(GetEnumName(PropTypeInfo, Value));
          {$endif CtdNoRTLog}
        end;
        tkSet: SetSetInt(PropTypeInfo, Value);
        else SetIdentInt(ValueType, PropTypeInfo, Value);
      end;
    end;
  end;

  procedure UnpakEvent(ObjectName, OwnerName: String; PropInfo: PPropInfo);
  var
    Value: Byte;
    IsIdent: Boolean;
    Name,
    EventPart: String;
  begin
    IsIdent := False;
    Value   := Byte(Reader.NextValue);
    case Value of
        0: TCtdWriter(Writer).WriteValue(vaNil);
      252: Name := 'Frame';
      253: Name := 'DataModule';
      254: Name := 'Form';
      255:
      begin
        if OwnerName = RootName
        then Name := ObjectName
        else Name := OwnerName + ObjectName;
      end;
      else
      begin
        Name    := Reader.ReadStr;
        IsIdent := True;
      end;
    end;

    if not IsIdent then
    begin
      Reader.ReadValue;
      if Value <> 0
      then
      begin
        if(PropInfo.Name[1] = 'O') and (PropInfo.Name[2] = 'n')
        then EventPart := Copy(PropInfo.Name, 3, Length(PropInfo.Name) - 2)
        else EventPart := PropInfo.Name;
        Name := Name + EventPart;
        Writer.WriteIdent(Name);
      end;
    end
    else Writer.WriteIdent(Name);

    {$ifndef CtdNoRTLog}
    WriteToLog('Event: ' + Name);
    {$endif CtdNoRTLog}
  end;

  function ReadIdentInteger: Longint;
  var
    S: Shortint;
    I: Smallint;
  begin
    case Byte(Reader.ReadValue) of
      vaIdentInt8:
        begin
          Reader.Read(S, SizeOf(Shortint));
          Result := S;
        end;
      vaIdentInt16:
        begin
          Reader.Read(I, SizeOf(I));
          Result := I;
        end;
      vaIdentInt32:
        Reader.Read(Result, SizeOf(Result));
    else raise EReadError.CreateRes(@SInvalidPropertyValue);
    end;
  end;

  procedure ConvertValue(ObjectName, OwnerName: String;
    PropTypeInfo: PTypeInfo; PropInfo: PPropInfo);
  var
    S: string;
    NextValue: TValueType;
    IntValue: Integer;
    ByteValue: Byte;
    Buffer: Pointer;
  begin
    if(PropTypeInfo <> nil) and (PropTypeInfo.Kind = tkMethod)
    then UnpakEvent(ObjectName, OwnerName, PropInfo)
    else
    begin
      NextValue := Reader.NextValue;
      case NextValue of
        vaList:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking list');
          {$endif CtdNoRTLog}
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
          while not Reader.EndOfList do
            ConvertValue('', '', nil, nil);
          Reader.ReadListEnd;
          Writer.WriteListEnd;
        end;
        vaInt8, vaInt16, vaInt32:
          UnpackInt(NextValue, Reader.ReadInteger);
        {$WARNINGS OFF}
        TValueType(vaIdentInt8), TValueType(vaIdentInt16), TValueType(vaIdentInt32):
        {$WARNINGS ON}
          UnpackIdent(NextValue, ReadIdentInteger, PropTypeInfo); 
        vaExtended:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking extended');
          {$endif CtdNoRTLog}
          Writer.WriteFloat(Reader.ReadFloat);
        end;
        vaSingle:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking single');
          {$endif CtdNoRTLog}
          Writer.WriteSingle(Reader.ReadSingle);
        end;
        vaCurrency:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking currency');
          {$endif CtdNoRTLog}
          Writer.WriteCurrency(Reader.ReadCurrency);
        end;
        vaDate:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking date');
          {$endif CtdNoRTLog}
          Writer.WriteDate(Reader.ReadDate);
        end;
        vaWString:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking wide string');
          {$endif CtdNoRTLog}
          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
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking string');
          {$endif CtdNoRTLog}
          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
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking long string');
          {$endif CtdNoRTLog}
          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:
          Writer.WriteIdent(Reader.ReadIdent);
        vaFalse, vaTrue, vaNil, vaNull:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking constant');
          {$endif CtdNoRTLog}
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
        end;
        vaBinary:
          ConvertBinary;
        vaSet:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking set');
          {$endif CtdNoRTLog}
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
          while True do
          begin
            S := Reader.ReadStr;
            Writer.WriteStr(S);
            if S = '' then Break;
          end;
        end;
        vaCollection:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking collection');
          {$endif CtdNoRTLog}
          TCtdWriter(Writer).WriteValue(Reader.ReadValue);
          while not Reader.EndOfList do
          begin
            if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
              ConvertValue('', '', nil, nil);
            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
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking int64');
          {$endif CtdNoRTLog}
          Writer.WriteInteger(Reader.ReadInt64);
        end;
        {$ifdef D6UP}
        vaUTF8String:
        begin
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking UTF8 string');
          {$endif CtdNoRTLog}
          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
          {$ifndef CtdNoRTLog}
          WriteToLog('Unpacking double');
          {$endif CtdNoRTLog}
          Writer.WriteDouble(Reader.ReadDouble);
        end;
        {$endif D9UP}
      end;
    end;
  end;

  procedure ConvertProperty(TypeInfo: PTypeInfo;
    ObjectName, OwnerName, ClassName: String);
  var
    PropIndex,
    PropPathCount: Smallint;
    i,
    PropCount: Integer;
    PropList: PPropList;
    PropPath,
    PropName: string;
    PropTypeInfo: PTypeInfo;
    PropInfo: PPropInfo;
    IsIndex: Boolean;
  begin
    {$ifndef CtdNoRTLog}
    WriteToLog('Unpacking property' + PropPath + ' (' + IntToStr(Writer.Position) + ')');
    {$endif CtdNoRTLog}
    PropPathCount := 1;
    PropInfo      := nil;

    IsIndex := ReadStringIndex(PropIndex, PropName);
    if (TypeInfo = nil) and IsIndex then
      raise Exception.Create('Citadel error: class ''' + ClassName + ''' unknown');
    if IsIndex then
    begin
      {$ifndef CtdNoRTLog}
      WriteToLog('Property is packed');
      {$endif CtdNoRTLog}
      if (-PropIndex) < PropPathCountValue then
        PropPathCount := PropPathCountValue + PropIndex;
    end;
    {$ifndef CtdNoRTLog}
    WriteToLog('Property path count: ' + IntToStr(PropPathCount));
    {$endif CtdNoRTLog}

    PropTypeInfo := TypeInfo;
    i := 1;
    while i <= PropPathCount do
    begin
      if PropPathCount > 1 then
        IsIndex := ReadStringIndex(PropIndex, PropName);

      if IsIndex
      then
      begin
        PropCount := GetTypeData(PropTypeInfo)^.PropCount;
        {$ifndef CtdNoRTLog}
        WriteToLog('Property index: ' + IntToStr(PropIndex));
        Assert(PropIndex < PropCount);
        {$endif CtdNoRTLog}
        GetMem(PropList, PropCount * SizeOf(Pointer));
        try
          GetPropInfos(PropTypeInfo, PropList);
          PropInfo := PropList[PropIndex];
          if PropInfo = nil then
            raise Exception.Create(
              'Citadel error: can''t unpack property for class ''' + ClassName + '''');
          PropTypeInfo := PropInfo.PropType^;
          PropPath     := PropPath + PropInfo.Name;
          {$ifndef CtdNoRTLog}
          WriteToLog('Property name: ' + PropInfo.Name);
          WriteToLog('Property type: ' + PropInfo.PropType^.Name);
          {$endif CtdNoRTLog}
        finally
          FreeMem(PropList);
        end;
      end
      else
      begin
        PropPath     := PropPath + PropName;
        PropTypeInfo := nil;
        PropInfo     := nil;
        break;
      end;
      if i < PropPathCount then
        PropPath := PropPath + '.';
      Inc(i);
    end;
    {$ifndef CtdNoRTLog}
    WriteToLog('Property path: ' + PropPath);
    {$endif CtdNoRTLog}
    Writer.WriteStr(PropPath);
    ConvertValue(ObjectName, OwnerName, PropTypeInfo, PropInfo);
    {$ifndef CtdNoRTLog}
    WriteToLog('Property unpacked');
    {$endif CtdNoRTLog}
  end;

  procedure ConvertObject(IsRoot: Boolean; OwnerClass: TComponentClass;
    OwnerName: String);
  var
    TypeInfo: PTypeInfo;
    {$ifndef CtdNoRTLog}
    aux,
    {$endif CtdNoRTLog}
    ObjectName,
    ClassName: String;
  begin
    {$ifndef CtdNoRTLog}
    aux := ' (' + IntToStr(Writer.Position) + ')';
    if OwnerClass <> nil
    then WriteToLog('OwnerClass: ' + OwnerClass.ClassName + aux)
    else WriteToLog('OwnerClass: unknown' + aux);
    {$endif CtdNoRTLog}
    TypeInfo := ConvertHeader(OwnerClass, OwnerName, ObjectName, ClassName,
      IsRoot);
    if IsRoot then
    begin
      RootName  := ObjectName;
      OwnerName := ObjectName;
    end;
    while not Reader.EndOfList do
      ConvertProperty(TypeInfo, ObjectName, OwnerName, ClassName);
    Reader.ReadListEnd;
    Writer.WriteListEnd;
    while not Reader.EndOfList do
      ConvertObject(False, OwnerClass, OwnerName);
    Reader.ReadListEnd;
    Writer.WriteListEnd;
  end;

begin
  Reader := TReader.Create(Input, 4096);
  SaveSeparator := DecimalSeparator;
  DecimalSeparator := '.';
  try
    Writer := TWriter.Create(Output, 4096);
    try
      ConvertObject(True, RootClass, RootName);
    finally
      Writer.Free;
    end;
  finally
    DecimalSeparator := SaveSeparator;
    Reader.Free;
  end;
end;

initialization

  DsgnGetFieldClassByIndexRoutine := nil;
  {$ifndef CtdNoRTLog}
  WriteToLog := CtdDummyWriteToLog;
  {$endif CtdNoRTLog}

end.