fpc/fcl/xml/xmlstreaming.pp

{
    $Id$
    This file is part of the Free Component Library
    This file:
      Copyright (c) 2000 by Sebastian Guenther, [email protected]

    XML serialisation driver

    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.

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


unit XMLStreaming;

{$MODE objfpc}
{$H+}

interface

uses SysUtils, Classes, DOM;

type

  TXMLObjectWriterStackElType = (elUnknown, elPropertyList, elChildrenList);

  TXMLObjectWriterStackEl = class
  public
    Element, Parent: TDOMElement;
    ElType: TXMLObjectWriterStackElType;
    CurName: String;
  end;

  TXMLObjectWriter = class(TAbstractObjectWriter)
  private
    FDoc: TDOMDocument;
    FRootEl: TDOMElement;
    FStack: TList;
    StackEl: TXMLObjectWriterStackEl;
    procedure StackPush;
    procedure StackPop;
    function GetPropertyElement(const TypeName: String): TDOMElement;
  public
    constructor Create(ADoc: TDOMDocument);
    procedure BeginCollection; override;
    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
      ChildPos: Integer); override;
    procedure BeginList; override;
    procedure EndList; override;
    procedure BeginProperty(const PropName: String); override;
    procedure EndProperty; override;

    procedure WriteBinary(const Buffer; Count: Longint); override;
    procedure WriteBoolean(Value: Boolean); override;
    // procedure WriteChar(Value: Char);
    procedure WriteFloat(const Value: Extended); override;
    procedure WriteSingle(const Value: Single); override;
    {!!!: procedure WriteCurrency(const Value: Currency); override;}
    procedure WriteDate(const Value: TDateTime); override;
    procedure WriteIdent(const Ident: string); override;
    procedure WriteInteger(Value: Int64); override;
    procedure WriteMethodName(const Name: String); override;
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
    procedure WriteString(const Value: String); override;
  end;



implementation


procedure TXMLObjectWriter.StackPush;
var
  Parent: TDOMElement;
begin
  if Assigned(FStack) then
  begin
    Parent := StackEl.Element;
    FStack.Add(StackEl);
    StackEl := TXMLObjectWriterStackEl.Create;
    StackEl.Parent := Parent;
  end else
  begin
    FStack := TList.Create;
    StackEl := TXMLObjectWriterStackEl.Create;
    StackEl.Parent := FRootEl;
  end;
end;

procedure TXMLObjectWriter.StackPop;
begin
  StackEl.Free;
  if FStack.Count > 0 then
  begin
    StackEl := TXMLObjectWriterStackEl(FStack[FStack.Count - 1]);
    FStack.Delete(FStack.Count - 1);
  end else
  begin
    FStack.Free;
    FStack := nil;
    StackEl := nil;
  end;
end;

function TXMLObjectWriter.GetPropertyElement(const TypeName: String): TDOMElement;
begin
  if not Assigned(StackEl.Element) then
  begin
    StackEl.Element := FDoc.CreateElement(TypeName);
    StackEl.Parent.AppendChild(StackEl.Element);
    StackEl.Element['name'] := StackEl.CurName;
    Result := StackEl.Element;
  end else
    Result := nil;
end;

constructor TXMLObjectWriter.Create(ADoc: TDOMDocument);
begin
  inherited Create;
  FDoc := ADoc;
  FRootEl := FDoc.CreateElement('fcl-persistent');
  FDoc.AppendChild(FRootEl);
end;

procedure TXMLObjectWriter.BeginCollection;
begin
  WriteLn('BeginCollection');
end;

procedure TXMLObjectWriter.BeginComponent(Component: TComponent; Flags: TFilerFlags;
  ChildPos: Integer);
begin
  StackPush;
  StackEl.Element := FDoc.CreateElement('component');
  StackEl.Parent.AppendChild(StackEl.Element);

  if Length(Component.Name) > 0 then
    StackEl.Element['name'] := Component.Name;
  StackEl.Element['class'] := Component.ClassName;

  StackPush;
  StackEl.Element := FDoc.CreateElement('properties');
  StackEl.Parent.AppendChild(StackEl.Element);
  StackEl.ElType := elPropertyList;
end;

procedure TXMLObjectWriter.BeginList;
begin
  WriteLn('BeginList');
end;

procedure TXMLObjectWriter.EndList;
begin
  if StackEl.ElType = elPropertyList then
  begin
    if not StackEl.Element.HasChildNodes then
      StackEl.Parent.RemoveChild(StackEl.Element);
    StackPop;

    StackPush;
    StackEl.Element := FDoc.CreateElement('children');
    StackEl.Parent.AppendChild(StackEl.Element);
    StackEl.ElType := elChildrenList;
  end else if StackEl.ElType = elChildrenList then
  begin
    if not StackEl.Element.HasChildNodes then
      StackEl.Parent.RemoveChild(StackEl.Element);
    StackPop;
  end else
    StackPop;
end;

procedure TXMLObjectWriter.BeginProperty(const PropName: String);
begin
  StackPush;
  StackEl.CurName := PropName;
end;

procedure TXMLObjectWriter.EndProperty;
begin
  StackPop;
end;

procedure TXMLObjectWriter.WriteBinary(const Buffer; Count: Longint);
begin
  WriteLn('WriteBinary (', Count, ' Bytes)');
end;

procedure TXMLObjectWriter.WriteBoolean(Value: Boolean);
begin
  WriteLn('WriteBoolean: ', Value);
end;

procedure TXMLObjectWriter.WriteFloat(const Value: Extended);
begin
  WriteLn('WriteFloat: ', Value);
end;

procedure TXMLObjectWriter.WriteSingle(const Value: Single);
begin
  WriteLn('WriteSingle: ', Value);
end;

procedure TXMLObjectWriter.WriteDate(const Value: TDateTime);
begin
  WriteLn('WriteDate: ', Value);
end;

procedure TXMLObjectWriter.WriteIdent(const Ident: string);
begin
  GetPropertyElement('ident')['value'] := Ident;
end;

procedure TXMLObjectWriter.WriteInteger(Value: Int64);
begin
  GetPropertyElement('integer')['value'] := IntToStr(Value);
end;

procedure TXMLObjectWriter.WriteMethodName(const Name: String);
begin
  GetPropertyElement('method-name')['value'] := Name;
end;

procedure TXMLObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
begin
  WriteLn('WriteSet: ', Value);
end;

procedure TXMLObjectWriter.WriteString(const Value: String);
begin
  GetPropertyElement('string')['value'] := Value;
end;


end.


{
  $Log$
  Revision 1.1  2000-07-13 06:33:50  michael
  + Initial import

  Revision 1.1  2000/06/29 16:43:02  sg
  * Added XML object streaming (serialisation) support

}