frxxmlserializer.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{             XML serializer               }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxXMLSerializer;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  TypInfo, frxXML, frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type

{ TfrxXMLSerializer is the XML analogue of the Delphi component streaming -
  TReader and TWriter }

  TfrxXMLSerializer = class(TObject)
  private
    FErrors: TStringList;
    FFixups: TList;
    FOwner: TfrxComponent;
    FReader: TReader;
    FReaderStream: TMemoryStream;
    FSerializeDefaultValues: Boolean;
    FStream: TStream;
    procedure AddFixup(Obj: TPersistent; p: PPropInfo; Value: String);
    procedure ClearFixups;
    procedure FixupReferences;
    procedure OneProp(Name, Value: String; Obj: TPersistent);
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    function ObjToXML(Obj: TPersistent; const Add: String = ''): String;
    function ReadComponent(Root: TfrxComponent): TfrxComponent;
    function ReadComponentStr(Root: TfrxComponent; s: String): TfrxComponent;
    function WriteComponentStr(c: TfrxComponent): String;
    procedure ReadRootComponent(Root: TfrxComponent; XMLItem: TfrxXMLItem = nil;
      DontCreateComponents: Boolean = False);
    procedure ReadPersistentStr(Root: TComponent; Obj: TPersistent; const s: String);
    procedure WriteComponent(c: TfrxComponent);
    procedure WriteRootComponent(Root: TfrxComponent; SaveChildren: Boolean = True;
      XMLItem: TfrxXMLItem = nil);
    procedure XMLToObj(s: String; Obj: TPersistent);
    property Errors: TStringList read FErrors;
    property Owner: TfrxComponent read FOwner write FOwner;
    property Stream: TStream read FStream;
    property SerializeDefaultValues: Boolean read FSerializeDefaultValues
      write FSerializeDefaultValues;
  end;


implementation

uses frxUtils, frxFormUtils, frxRes, frxUnicodeUtils;


type
  TfrxFixupItem = class(TObject)
  public
    Obj: TPersistent;
    PropInfo: PPropInfo;
    Value: String;
  end;

  THackComponent = class(TComponent);
  THackPersistent = class(TPersistent);
  THackReader = class(TReader);


{ TfrxXMLSerializer }

constructor TfrxXMLSerializer.Create(Stream: TStream);
begin
  FErrors := TStringList.Create;
  FErrors.Sorted := True;
  FErrors.Duplicates := dupIgnore;
  FFixups := TList.Create;
  FStream := Stream;
  FReaderStream := TMemoryStream.Create;
  FReader := TReader.Create(FReaderStream, 4096);
end;

destructor TfrxXMLSerializer.Destroy;
begin
  FErrors.Free;
  FReader.Free;
  FReaderStream.Free;
  ClearFixups;
  FFixups.Free;
  inherited;
end;

procedure TfrxXMLSerializer.ClearFixups;
begin
  while FFixups.Count > 0 do
  begin
    TfrxFixupItem(FFixups[0]).Free;
    FFixups.Delete(0);
  end;
end;

procedure TfrxXMLSerializer.AddFixup(Obj: TPersistent; p: PPropInfo;
  Value: String);
var
  Item: TfrxFixupItem;
begin
  Item := TfrxFixupItem.Create;
  Item.Obj := Obj;
  Item.PropInfo := p;
  Item.Value := Value;
  FFixups.Add(Item);
end;

procedure TfrxXMLSerializer.FixupReferences;
var
  i: Integer;
  Item: TfrxFixupItem;
  Ref: TObject;
begin
  for i := 0 to FFixups.Count - 1 do
  begin
    Item := FFixups[i];
    Ref := nil;
    if FOwner <> nil then
      Ref := FOwner.FindObject(Item.Value);
    if Ref = nil then
      Ref := frxFindComponent(FOwner, Item.Value);
    if Ref <> nil then
      SetOrdProp(Item.Obj, Item.PropInfo, Integer(Ref));
  end;

  FReader.FixupReferences;
  FReader.EndReferences;
  ClearFixups;
end;

procedure TfrxXMLSerializer.OneProp(Name, Value: String; Obj: TPersistent);
var
  i, code: Integer;
  p: PPropInfo;

  procedure DoNonPublishedProps;
  begin
    FReaderStream.Clear;
    frxStringToStream(Value, FReaderStream);
    FReaderStream.Position := 0;
    FReader.Position := 0;

    try
      while FReader.Position < FReaderStream.Size do
        THackReader(FReader).ReadProperty(Obj);
    except
    end;
  end;

begin
  if Length(Name) = 1 then
  begin
// special properties
    case Name[1] of
      'x':
        begin
          TfrxCustomMemoView(Obj).Text := frxXMLToStr(Value);
          Exit;
        end;
      'u':
        begin
          TfrxCustomMemoView(Obj).Text := Utf8Decode(frxXMLToStr(Value));
          Exit;
        end;
      'l': Name := 'Left';
      't': Name := 'Top';
      'w': Name := 'Width';
      'h': Name := 'Height';
    end;
  end
  else
  begin
// multiple properties
    i := Pos('.', Name);
    while i <> 0 do
    begin
      p := GetPropInfo(Obj.ClassInfo, Copy(Name, 1, i - 1));
      if p = nil then
        Exit;
      Obj := TPersistent(GetOrdProp(Obj, p));
      Delete(Name, 1, i);
      i := Pos('.', Name);
    end;

    if (Obj is TStrings) and (Name = 'text') then
    begin
      TStrings(Obj).Text := frxXMLToStr(Value);
      Exit;
    end
    else if (Obj is TWideStrings) and (Name = 'text') then
    begin
      TWideStrings(Obj).Text := frxXMLToStr(Value);
      Exit;
    end
    else if Name = 'propdata' then
    begin
      DoNonPublishedProps;
      Exit;
    end
    else if (Obj is TfrxCustomMemoView) and (Name = 'text') then
    begin
      TfrxCustomMemoView(Obj).Text := Utf8Decode(frxXMLToStr(Value));
      Exit;
    end
  end;

  p := GetPropInfo(Obj.ClassInfo, Name);
  if p <> nil then
    case p.PropType^.Kind of
      tkInteger, tkSet, tkChar, tkWChar:
        SetOrdProp(Obj, p, StrToInt(Value));

      tkEnumeration:
        begin
          Val(Value, i, code);
          if code = 0 then
            SetOrdProp(Obj, p, i) else
            SetOrdProp(Obj, p, GetEnumValue(p.PropType^, Value));
        end;

      tkFloat:
        SetFloatProp(Obj, p, frxStrToFloat(Value));

      tkString, tkLString, tkWString:
        SetStrProp(Obj, p, frxXMLToStr(Value));

      tkClass:
        AddFixup(Obj, p, Value);

      tkVariant:
        SetVariantProp(Obj, p, frxXMLToStr(Value));
    end;
end;

procedure TfrxXMLSerializer.XMLToObj(s: String; Obj: TPersistent);
var
  i, j: Integer;
  Name, Value: String;
begin
  while s <> '' do
  begin
    i := Pos('"', s);
    Name := Trim(LowerCase(Copy(s, 1, i - 2)));
    if Name = '' then break;
    s[i] := ' ';
    j := Pos('"', s);
    Value := Copy(s, i + 1, j - i - 1);

    try
      OneProp(Name, Value, Obj);
    except
      on E: Exception do
        FErrors.Add(E.Message);
    end;

    Delete(s, 1, j + 1);
  end;
end;

function TfrxXMLSerializer.ObjToXML(Obj: TPersistent; const Add: String = ''): String;
var
  TypeInfo: PTypeInfo;
  PropCount: Integer;
  PropList: PPropList;
  i: Integer;
  s: String;
  ws: WideString;
  Flag: Boolean;

  procedure DoOrdProp;
  var
    Value: Integer;
  begin
    Value := GetOrdProp(Obj, PropList[i]);
    if (Value <> PropList[i].Default) or FSerializeDefaultValues then
      if PropList[i].PropType^.Kind = tkEnumeration then
        s := GetEnumName(PropList[i].PropType^, Value) else
        s := IntToStr(Value);
  end;

  procedure DoFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Obj, PropList[i]);
// commented out due to bug with tfrxmemoview.linespacing=0
//    if (Value <> 0) or FSerializeDefaultValues then
      s := FloatToStr(Value);
  end;

  procedure DoStrProp;
  var
    Value: String;
  begin
    Value := GetStrProp(Obj, PropList[i]);
    if (Value <> '') or FSerializeDefaultValues then
      s := frxStrToXML(Value);
  end;

  procedure DoVariantProp;
  var