{
    $Id: writer.inc,v 1.1.2.1 2000/12/10 14:32:08 michael Exp $
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}


{****************************************************************************}
{*                         TBinaryObjectWriter                              *}
{****************************************************************************}

constructor TBinaryObjectWriter.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create;
  FStream := Stream;
  FBufSize := BufSize;
  GetMem(FBuffer, BufSize);
end;

destructor TBinaryObjectWriter.Destroy;
begin
  // Flush all data which hasn't been written yet
  FlushBuffer;

  if Assigned(FBuffer) then
    FreeMem(FBuffer, FBufSize);

  inherited Destroy;
end;

procedure TBinaryObjectWriter.BeginCollection;
begin
  WriteValue(vaCollection);
end;

procedure TBinaryObjectWriter.BeginComponent(Component: TComponent;
  Flags: TFilerFlags; ChildPos: Integer);
var
  Prefix: Byte;
begin
  if not FSignatureWritten then
  begin
    Write(FilerSignature, SizeOf(FilerSignature));
    FSignatureWritten := True;
  end;

  { Only write the flags if they are needed! }
  if Flags <> [] then
  begin
    Prefix := Integer(Flags) or $f0;
    Write(Prefix, 1);
    if ffChildPos in Flags then
      WriteInteger(ChildPos);
  end;

  WriteStr(Component.ClassName);
  WriteStr(Component.Name);
end;

procedure TBinaryObjectWriter.BeginList;
begin
  WriteValue(vaList);
end;

procedure TBinaryObjectWriter.EndList;
begin
  WriteValue(vaNull);
end;

procedure TBinaryObjectWriter.BeginProperty(const PropName: String);
begin
  WriteStr(PropName);
end;

procedure TBinaryObjectWriter.EndProperty;
begin
end;

procedure TBinaryObjectWriter.WriteBinary(const Buffer; Count: LongInt);
begin
  WriteValue(vaBinary);
  Write(Count, 4);
  Write(Buffer, Count);
end;

procedure TBinaryObjectWriter.WriteBoolean(Value: Boolean);
begin
  if Value then
    WriteValue(vaTrue)
  else
    WriteValue(vaFalse);
end;

procedure TBinaryObjectWriter.WriteFloat(const Value: Extended);
begin
  WriteValue(vaExtended);
  Write(Value, SizeOf(Value));
end;

procedure TBinaryObjectWriter.WriteSingle(const Value: Single);
begin
  WriteValue(vaSingle);
  Write(Value, SizeOf(Value));
end;

{!!!: procedure TBinaryObjectWriter.WriteCurrency(const Value: Currency);
begin
  WriteValue(vaCurrency);
  Write(Value, SizeOf(Value));
end;}

procedure TBinaryObjectWriter.WriteDate(const Value: TDateTime);
begin
  WriteValue(vaDate);
  Write(Value, SizeOf(Value));
end;

procedure TBinaryObjectWriter.WriteIdent(const Ident: string);
begin
  { Check if Ident is a special identifier before trying to just write
    Ident directly }
  if UpperCase(Ident) = 'NIL' then
    WriteValue(vaNil)
  else if UpperCase(Ident) = 'FALSE' then
    WriteValue(vaFalse)
  else if UpperCase(Ident) = 'TRUE' then
    WriteValue(vaTrue)
  else if UpperCase(Ident) = 'NULL' then
    WriteValue(vaNull) else
  begin
    WriteValue(vaIdent);
    WriteStr(Ident);
  end;
end;

procedure TBinaryObjectWriter.WriteInteger(Value: Int64);
begin
  { Use the smallest possible integer type for the given value: }
  if (Value >= -128) and (Value <= 127) then
  begin
    WriteValue(vaInt8);
    Write(Value, 1);
  end else if (Value >= -32768) and (Value <= 32767) then
  begin
    WriteValue(vaInt16);
    Write(Value, 2);
  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
  begin
    WriteValue(vaInt32);
    Write(Value, 4);
  end else
  begin
    WriteValue(vaInt64);
    Write(Value, 8);
  end;
end;

procedure TBinaryObjectWriter.WriteMethodName(const Name: String);
begin
  if Length(Name) > 0 then
  begin
    WriteValue(vaIdent);
    WriteStr(Name);
  end else
    WriteValue(vaNil);
end;

procedure TBinaryObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
var
  i: Integer;
  Mask: LongInt;
begin
  WriteValue(vaSet);
  Mask := 1;
  for i := 0 to 31 do
  begin
    if (Value and Mask) <> 0 then
      WriteStr(GetEnumName(PTypeInfo(SetType), i));
    Mask := Mask shl 1;
  end;
  WriteStr('');
end;

procedure TBinaryObjectWriter.WriteString(const Value: String);
var
  i: Integer;
begin
  i := Length(Value);
  if i <= 255 then
  begin
    WriteValue(vaString);
    Write(i, 1);
  end else
  begin
    WriteValue(vaLString);
    Write(i, 4);
  end;
  if i > 0 then
    Write(Value[1], i);
end;

{!!!: procedure TBinaryObjectWriter.WriteWideString(const Value: WideString);
var
  i: Integer;
begin
  WriteValue(vaWString);
  i := Length(Value);
  Write(i, 4);
  Write(Value[1], i * 2);
end;}

procedure TBinaryObjectWriter.FlushBuffer;
begin
  FStream.WriteBuffer(FBuffer^, FBufPos);
  FBufPos := 0;
end;

procedure TBinaryObjectWriter.Write(const Buffer; Count: LongInt);
var
  CopyNow: LongInt;
begin
  while Count > 0 do
  begin
    CopyNow := Count;
    if CopyNow > FBufSize - FBufPos then
      CopyNow := FBufSize - FBufPos;
    Move(Buffer, PChar(FBuffer)[FBufPos], CopyNow);
    Dec(Count, CopyNow);
    Inc(FBufPos, CopyNow);
    if FBufPos = FBufSize then
      FlushBuffer;
  end;
end;

procedure TBinaryObjectWriter.WriteValue(Value: TValueType);
begin
  Write(Value, 1);
end;

procedure TBinaryObjectWriter.WriteStr(const Value: String);
var
  i: Integer;
begin
  i := Length(Value);
  if i > 255 then
    i := 255;
  Write(i, 1);
  if i > 0 then
    Write(Value[1], i);
end;



{****************************************************************************}
{*                             TWriter                                      *}
{****************************************************************************}


constructor TWriter.Create(ADriver: TAbstractObjectWriter);
begin
  inherited Create;
  FDriver := ADriver;
end;

constructor TWriter.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create;
  FDriver := TBinaryObjectWriter.Create(Stream, BufSize);
  FDestroyDriver := True;
end;

destructor TWriter.Destroy;
begin
  if FDestroyDriver then
    FDriver.Free;
  inherited Destroy;
end;

// Used as argument for calls to TComponent.GetChildren:
procedure TWriter.AddToAncestorList(Component: TComponent);
begin
  FAncestorList.Add(Component);
end;

procedure TWriter.DefineProperty(const Name: String;
  ReadData: TReaderProc; AWriteData: TWriterProc; HasData: Boolean);
begin
  if HasData and Assigned(AWriteData) then
  begin
    // Write the property name and then the data itself
    Driver.BeginProperty(FPropPath + Name);
    AWriteData(Self);
    Driver.EndProperty;
  end;
end;

procedure TWriter.DefineBinaryProperty(const Name: String;
  ReadData, AWriteData: TStreamProc; HasData: Boolean);
begin
  if HasData and Assigned(AWriteData) then
  begin
    // Write the property name and then the data itself
    Driver.BeginProperty(FPropPath + Name);
    WriteBinary(AWriteData);
    Driver.EndProperty;
  end;
end;

procedure TWriter.SetRoot(ARoot: TComponent);
begin
  inherited SetRoot(ARoot);
  // Use the new root as lookup root too
  FLookupRoot := ARoot;
end;

procedure TWriter.WriteBinary(AWriteData: TStreamProc);
var
  MemBuffer: TMemoryStream;
  BufferSize: Longint;
begin
  { First write the binary data into a memory stream, then copy this buffered
    stream into the writing destination. This is necessary as we have to know
    the size of the binary data in advance (we're assuming that seeking within
    the writer stream is not possible) }
  MemBuffer := TMemoryStream.Create;
  try
    AWriteData(MemBuffer);
    BufferSize := MemBuffer.Size;
    Driver.WriteBinary(MemBuffer.Memory^, BufferSize);
  finally
    MemBuffer.Free;
  end;
end;

procedure TWriter.WriteBoolean(Value: Boolean);
begin
  Driver.WriteBoolean(Value);
end;

procedure TWriter.WriteChar(Value: Char);
begin
  WriteString(Value);
end;

procedure TWriter.WriteCollection(Value: TCollection);
var
  i: Integer;
begin
  Driver.BeginCollection;
  if Assigned(Value) then
    for i := 0 to Value.Count - 1 do
    begin
      { Each collection item needs its own ListBegin/ListEnd tag, or else the
        reader wouldn't be able to know where an item ends and where the next
	one starts }
      WriteListBegin;
      WriteProperties(Value.Items[i]);
      WriteListEnd;
    end;
  WriteListEnd;
end;

procedure TWriter.WriteComponent(Component: TComponent);
var
  SavedAncestor: TPersistent;
  SavedRootAncestor, AncestorComponent, CurAncestor: TComponent;
  i: Integer;
  s: String;
begin
  SavedAncestor := Ancestor;
  SavedRootAncestor := RootAncestor;

  try
    // The component has to know that it is being written now...
    Include(Component.FComponentState, csWriting);

    // Locate the component in the ancestor list, if necessary
    if Assigned(FAncestorList) then
    begin
      Ancestor := nil;
      s := UpperCase(Component.Name);
      for i := 0 to FAncestorList.Count - 1 do
      begin
        CurAncestor := TComponent(FAncestorList[i]);
        if UpperCase(CurAncestor.Name) = s then
	begin
	  Ancestor := CurAncestor;
	  break;
	end;
      end;
    end;

    // Do we have to call the OnFindAncestor callback?
    if Assigned(FOnFindAncestor) and
      ((not Assigned(Ancestor)) or Ancestor.InheritsFrom(TComponent)) then
    begin
      AncestorComponent := TComponent(Ancestor);
      FOnFindAncestor(Self, Component, Component.Name,
        AncestorComponent, FRootAncestor);
      Ancestor := AncestorComponent;
    end;

    // Finally write the component state
    Component.WriteState(Self);

    // The writing has been finished now...
    Exclude(Component.FComponentState, csWriting);

  finally
    Ancestor := SavedAncestor;
    FRootAncestor := SavedRootAncestor;
  end;
end;

procedure TWriter.WriteComponentData(Instance: TComponent);
var
  SavedAncestorList: TList;
  SavedRoot, SavedRootAncestor: TComponent;
  SavedAncestorPos, SavedChildPos: Integer;
  Flags: TFilerFlags;
begin
  // Determine the filer flags to store
  if Assigned(Ancestor) and ((not (csInline in Instance.ComponentState)) or
    ((csAncestor in Instance.ComponentState) and Assigned(FAncestorList))) then
    Flags := [ffInherited]
  else if csInline in Instance.ComponentState then
    Flags := [ffInline]
  else
    Flags := [];

  if Assigned(FAncestorList) and (FAncestorPos < FAncestorList.Count) and
    ((not Assigned(Ancestor)) or
    (TPersistent(FAncestorList[FAncestorPos]) <> Ancestor)) then
    Include(Flags, ffChildPos);

  Driver.BeginComponent(Instance, Flags, FChildPos);

  if Assigned(FAncestorList) and (FAncestorPos < FAncestorList.Count) then
  begin
    if Assigned(Ancestor) then
      Inc(FAncestorPos);
    Inc(FChildPos);
  end;

  // Write property list
  WriteProperties(Instance);
  WriteListEnd;

  // Write children list
  SavedAncestorList := FAncestorList;
  SavedAncestorPos := FAncestorPos;
  SavedChildPos := FChildPos;
  SavedRoot := FRoot;
  SavedRootAncestor := FRootAncestor;
  try
    FAncestorList := nil;
    FAncestorPos := 0;
    FChildPos := 0;
    if not IgnoreChildren then
      try
        // Set up the ancestor list if we have an ancestor
        if Assigned(FAncestor) and FAncestor.InheritsFrom(TComponent) then
        begin
          if csInline in TComponent(FAncestor).ComponentState then
            FRootAncestor := TComponent(FAncestor);
          FAncestorList := TList.Create;
          TComponent(FAncestor).GetChildren(@AddToAncestorList, FRootAncestor);
        end;

        if csInline in Instance.ComponentState then
          FRoot := Instance;

        Instance.GetChildren(@WriteComponent, FRoot);

      finally
        FAncestorList.Free;
      end;

  finally
    FAncestorList := SavedAncestorList;
    FAncestorPos := SavedAncestorPos;
    FChildPos := SavedChildPos;
    FRoot := SavedRoot;
    FRootAncestor := SavedRootAncestor;
  end;

  WriteListEnd;
end;

procedure TWriter.WriteDescendent(ARoot: TComponent; AAncestor: TComponent);
begin
  FRoot := ARoot;
  FAncestor := AAncestor;
  FRootAncestor := AAncestor;
  FLookupRoot := ARoot;

  WriteComponent(ARoot);
end;

procedure TWriter.WriteFloat(const Value: Extended);
begin
  Driver.WriteFloat(Value);
end;

procedure TWriter.WriteSingle(const Value: Single);
begin
  Driver.WriteSingle(Value);
end;

{!!!: procedure TWriter.WriteCurrency(const Value: Currency);
begin
  Driver.WriteCurrency(Value);
end;}

procedure TWriter.WriteDate(const Value: TDateTime);
begin
  Driver.WriteDate(Value);
end;

procedure TWriter.WriteIdent(const Ident: string);
begin
  Driver.WriteIdent(Ident);
end;

procedure TWriter.WriteInteger(Value: LongInt);
begin
  Driver.WriteInteger(Value);
end;

procedure TWriter.WriteInteger(Value: Int64);
begin
  Driver.WriteInteger(Value);
end;

procedure TWriter.WriteListBegin;
begin
  Driver.BeginList;
end;

procedure TWriter.WriteListEnd;
begin
  Driver.EndList;
end;

procedure TWriter.WriteProperties(Instance: TPersistent);
var
  i, PropCount: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  { First step: Write the properties given by the RTTI for Instance }
  PropCount := GetTypeData(Instance.ClassInfo)^.PropCount;
  if PropCount > 0 then
  begin
    GetMem(PropList, PropCount * SizeOf(PPropInfo));
    try
      GetPropInfos(Instance.ClassInfo, PropList);
      for i := 0 to PropCount - 1 do
      begin
        PropInfo := PropList^[i];
        if IsStoredProp(Instance, PropInfo) then
          WriteProperty(Instance, PropInfo);
      end;
    finally
      FreeMem(PropList);
    end;
  end;

  { Second step: Give Instance the chance to write its own private data }
  Instance.DefineProperties(Self);
end;

procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
var
  HasAncestor: Boolean;
  PropType: PTypeInfo;
  Value, DefValue: LongInt;
  Ident: String;
  IntToIdentFn: TIntToIdent;
  FloatValue, DefFloatValue: Extended;
  MethodValue: TMethod;
  DefMethodCodeValue: Pointer;
  StrValue, DefStrValue: String;
  AncestorObj: TObject;
  Component: TComponent;
  ObjValue: TObject;
  SavedAncestor: TPersistent;
  SavedPropPath, Name: String;
  Int64Value, DefInt64Value: Int64;
begin

  if (not Assigned(PPropInfo(PropInfo)^.SetProc)) or
    (not Assigned(PPropInfo(PropInfo)^.GetProc)) then
    exit;

  { Check if the ancestor can be used }
  HasAncestor := Assigned(Ancestor) and ((Instance = Root) or
    (Instance.ClassType = Ancestor.ClassType));

  PropType := PPropInfo(PropInfo)^.PropType;
  case PropType^.Kind of
    tkInteger, tkChar, tkEnumeration, tkSet:
      begin
        Value := GetOrdProp(Instance, PropInfo);
        if HasAncestor then
          DefValue := GetOrdProp(Ancestor, PropInfo)
        else
          DefValue := PPropInfo(PropInfo)^.Default;

        if Value <> DefValue then
        begin
	  Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
          case PropType^.Kind of
            tkInteger:
      	      begin
		// Check if this integer has a string identifier
		IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType);
		if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident) then
	          // Integer can be written a human-readable identifier
	          WriteIdent(Ident)
		else
	          // Integer has to be written just as number
	          WriteInteger(Value);
	      end;
    	    tkChar:
              WriteChar(Chr(Value));
    	    tkSet:
	      Driver.WriteSet(Value, GetTypeData(PropType)^.CompType);
    	    tkEnumeration:
              WriteIdent(GetEnumName(PropType, Value));
          end;
	  Driver.EndProperty;
	end;
      end;
    tkFloat:
      begin
        FloatValue := GetFloatProp(Instance, PropInfo);
        if HasAncestor then
          DefFloatValue := GetFloatProp(Ancestor, PropInfo)
        else
          DefFloatValue := 0;
        if FloatValue <> DefFloatValue then
        begin
	  Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
          WriteFloat(FloatValue);
	  Driver.EndProperty;
        end;
      end;
    tkMethod:
      begin
        MethodValue := GetMethodProp(Instance, PropInfo);
        if HasAncestor then
          DefMethodCodeValue := GetMethodProp(Ancestor, PropInfo).Code
        else
          DefMethodCodeValue := nil;

        if (MethodValue.Code <> DefMethodCodeValue) and
          ((not Assigned(MethodValue.Code)) or
          ((Length(FLookupRoot.MethodName(MethodValue.Code)) >= 0))) then
        begin
          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
          if Assigned(MethodValue.Code) then
            Driver.WriteMethodName(FLookupRoot.MethodName(MethodValue.Code))
          else
            Driver.WriteMethodName('');
	  Driver.EndProperty;
        end;
      end;
    tkSString, tkLString, tkAString, tkWString:
      // !!!: Can we really handle WideStrings here?
      begin
        StrValue := GetStrProp(Instance, PropInfo);
        if HasAncestor then
          DefStrValue := GetStrProp(Ancestor, PropInfo)
        else
          SetLength(DefStrValue, 0);

        if StrValue <> DefStrValue then
        begin
          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
          WriteString(StrValue);
	  Driver.EndProperty;
        end;
      end;
  {!!!: tkVariant:}
    tkClass:
      begin
        ObjValue := TObject(GetOrdProp(Instance, PropInfo));
        if HasAncestor then
        begin
          AncestorObj := TObject(GetOrdProp(Ancestor, PropInfo));
          if Assigned(AncestorObj) then
            if Assigned(ObjValue) and
              (TComponent(AncestorObj).Owner = FRootAncestor) and
    	      (TComponent(ObjValue).Owner = Root) and
              (UpperCase(TComponent(AncestorObj).Name) = UpperCase(TComponent(ObjValue).Name)) then
              AncestorObj := ObjValue
	    else
	      AncestorObj := nil;
	end else
          AncestorObj := nil;

	if (not Assigned(ObjValue)) and (ObjValue <> AncestorObj) then
	begin
          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
	  Driver.WriteIdent('NIL');
	  Driver.EndProperty;
	end else If Assigned(ObjValue) then
	if ObjValue.InheritsFrom(TPersistent) then
          if ObjValue.InheritsFrom(TComponent) then
             begin
             Component := TComponent(ObjValue);
             if ObjValue <> AncestorObj then
               begin
               { Determine the correct name of the component this property contains }
               if Component.Owner = LookupRoot then
                 Name := Component.Name
               else if Component = LookupRoot then
                 Name := 'Owner'
               else if Assigned(Component.Owner) and (Length(Component.Owner.Name) > 0)
                and (Length(Component.Name) > 0) then
                 Name := Component.Owner.Name + '.' + Component.Name
               else if Length(Component.Name) > 0 then
                 Name := Component.Name + '.Owner'
               else
                 SetLength(Name, 0);
               if Length(Name) > 0 then
                 begin
                 Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
                 WriteIdent(Name);
                 Driver.EndProperty;
                 end;
                end;
             end else if ObjValue.InheritsFrom(TCollection) then
               begin
               if (not HasAncestor) or (not CollectionsEqual(TCollection(ObjValue),
                 TCollection(GetOrdProp(Ancestor, PropInfo)))) then
                 begin
                 Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
                 SavedPropPath := FPropPath;
                 try
                   SetLength(FPropPath, 0);
                   WriteCollection(TCollection(ObjValue));
                 finally
                   FPropPath := SavedPropPath;
                   Driver.EndProperty;
                 end;
                 end;
             end else
               begin
               SavedAncestor := Ancestor;
               SavedPropPath := FPropPath;
               try
                 FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
                 if HasAncestor then
                   Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
                 WriteProperties(TPersistent(ObjValue));
               finally
                 Ancestor := SavedAncestor;
                 FPropPath := SavedPropPath;
               end;
               end;
      end;
    tkInt64:
      begin
        Int64Value := GetInt64Prop(Instance, PropInfo);
        if HasAncestor then
          DefInt64Value := GetInt64Prop(Ancestor, PropInfo)
        else
          DefInt64Value := 0;

        if Int64Value <> DefInt64Value then
        begin
          Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
          WriteInteger(Int64Value);
	  Driver.EndProperty;
        end;
      end;
  end;
end;

procedure TWriter.WriteRootComponent(ARoot: TComponent);
begin
  WriteDescendent(ARoot, nil);
end;

procedure TWriter.WriteString(const Value: String);
begin
  Driver.WriteString(Value);
end;

{!!!: procedure TWriter.WriteWideString(const Value: WideString);
begin
  Driver.WriteWideString(Value);
end;}


{
  $Log: writer.inc,v $
  Revision 1.1.2.1  2000/12/10 14:32:08  michael
  + Added check for Object<>nil in streamer

  Revision 1.1  2000/07/13 06:31:32  michael
  + Initial import

  Revision 1.7  2000/06/29 16:29:23  sg
  * Implemented streaming. Note: The writer driver interface is stable, but
    the reader interface is not final yet!

  Revision 1.6  2000/01/07 01:24:33  peter
    * updated copyright to 2000

  Revision 1.5  2000/01/06 01:20:33  peter
    * moved out of packages/ back to topdir

  Revision 1.2  2000/01/04 18:07:16  michael
  + Streaming implemented

  Revision 1.3  1999/09/13 08:35:16  fcl
  * Changed some argument names (Root->ARoot etc.) because the new compiler
    now performs more ambiguity checks  (sg)

  Revision 1.2  1999/04/08 10:18:58  peter
    * makefile updates

}
