frxxmlserializer.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{             XML serializer               }
{                                          }
{         Copyright (c) 1998-2008          }
{         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
  TfrxGetAncestorEvent = procedure(const ComponentName: String;
    var Ancestor: TPersistent) of object;

{ 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;
    FOldFormat: Boolean;
    FOnGetAncestor: TfrxGetAncestorEvent;
    procedure AddFixup(Obj: TPersistent; p: PPropInfo; Value: String);
    procedure ClearFixups;
    procedure FixupReferences;
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    function ObjToXML(Obj: TPersistent; const Add: String = ''; Ancestor: TPersistent = nil): String;
    function ReadComponent(Root: TfrxComponent): TfrxComponent;
    function ReadComponentStr(Root: TfrxComponent; s: String; DontFixup: Boolean = False): TfrxComponent;
    function WriteComponentStr(c: TfrxComponent): String;
    procedure ReadRootComponent(Root: TfrxComponent; XMLItem: TfrxXMLItem = nil);
    procedure ReadPersistentStr(Root: TComponent; Obj: TPersistent; const s: String);
    procedure WriteComponent(c: TfrxComponent);
    procedure WriteRootComponent(Root: TfrxComponent; SaveChildren: Boolean = True;
      XMLItem: TfrxXMLItem = nil; Streaming: Boolean = False);
    procedure XMLToObj(const 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;
    property OnGetAncestor: TfrxGetAncestorEvent read FOnGetAncestor write FOnGetAncestor;
    property OldFormat: Boolean read FOldFormat write FOldFormat;
  end;


implementation

uses frxUtils, 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);
{$IFDEF Delphi12}
  FOldFormat := False;
{$ELSE}
  FOldFormat := True;
{$ENDIF}
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.XMLToObj(const s: String; Obj: TPersistent);
var
  i, j, start, len, code: Integer;
  i1, start1, len1: Integer;
  Name, Value: String;
  Obj1: TPersistent;
  p: PPropInfo;
  ps, ps1: PChar;

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

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

begin
  { speed optimized code. affects the speed of loading prepared page in the preview }
  len := Length(s);
  i := 1;
  ps := PChar(s) - 1;
  while i < len do
  begin
    j := i;
    len1 := len;
    ps1 := ps;
    while (j < len1) and (ps1[j] = ' ') do
      Inc(j);
    start := j;
    while (j < len1) and (ps1[j] <> '=') do
      Inc(j);
    i := j;
    if i < len then
    begin
      j := i - 1;
      while (j > 0) and (ps1[j] = ' ') do
        Dec(j);
      Name := Copy(s, start, j - start + 1);
      if Name = '' then break;
      j := i;
      len1 := len;
      while (j < len1) and (ps1[j] <> '"') do
        Inc(j);
      start := j + 1;
      Inc(j);
      while (j < len1) and (ps1[j] <> '"') do
        Inc(j);
      i := j;
      Value := Copy(s, start, i - start);
      Inc(i);

      Obj1 := Obj;

      { check multiple properties }
      len1 := Length(Name);
      start1 := 1;
      i1 := 1;
      while (i1 < len1) and (Name[i1] <> '.') do
        Inc(i1);
      if i1 < len1 then
      begin
        while i1 < len1 do
        begin
          p := GetPropInfo(Obj1.ClassInfo, Copy(String(Name), start1, i1 - start1));
          if p = nil then
            break;
          Obj1 := TPersistent(GetOrdProp(Obj1, p));
          start1 := i1 + 1;
          Inc(i1);
          while (i1 < len1) and (Name[i1] <> '.') do
            Inc(i1);
        end;
        Name := Copy(Name, start1, MaxInt);
      end;

      try
        if Length(Name) = 1 then
        begin
          { special properties }
          case Name[1] of
            'x':
              begin
                TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value);
                continue;
              end;
            'u':
              begin
{$IFDEF Delphi12}
                if FOldFormat then
                  TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Utf8Decode(AnsiString(Value)))
                else
                  TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value);
{$ELSE}
                TfrxCustomMemoView(Obj1).Text := Utf8Decode(frxXMLToStr(Value));
{$ENDIF}
                continue;
              end;
            'l':
              begin
                TfrxComponent(Obj1).Left := frxStrToFloat(String(Value));
                continue;
              end;
            't':
              begin
                TfrxComponent(Obj1).Top := frxStrToFloat(String(Value));
                continue;
              end;
            'w':
              begin
                TfrxComponent(Obj1).Width := frxStrToFloat(String(Value));
                continue;
              end;
            'h':
              begin
                TfrxComponent(Obj1).Height := frxStrToFloat(String(Value));
                continue;
              end;
          end;
        end
        else
        begin
          if Name = 'Text' then
          begin
            if Obj1 is TStrings then
            begin
              {$IFNDEF Delphi12}
              if not FOldFormat then
                TStrings(Obj1).Text := String(UTF8Decode(frxXMLToStr(Value))) else
              {$ENDIF}
              TStrings(Obj1).Text := frxXMLToStr(Value);
              continue;
            end
            else if Obj1 is {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF} then
            begin
              {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF}(Obj1).Text := frxXMLToStr(Value);
              continue;
            end
            else if Obj1 is TfrxCustomMemoView then
            begin
              {$IFDEF Delphi12}
              if FOldFormat then
                TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Utf8Decode(AnsiString(Value)))
              else TfrxCustomMemoView(Obj1).Text := frxXMLToStr(Value);
              {$ELSE}
              TfrxCustomMemoView(Obj1).Text := Utf8Decode(frxXMLToStr(Value));
              {$ENDIF}
              continue;
            end
          end
          else if Name = 'PropData' then
          begin
            DoNonPublishedProps;
            continue;
          end
          else if (Obj1 is TfrxReport) and (Name = 'Name') then
            continue;
        end;

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

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

            tkFloat:
              SetFloatProp(Obj1, p, frxStrToFloat(String(Value)));

            tkString, tkLString{$IFDEF Delphi12}{$ELSE}, tkWString{$ENDIF}:
{$IFNDEF Delphi12}
              if not FOldFormat then
                SetStrProp(Obj1, p, String(UTF8Decode(frxXMLToStr(Value)))) else
{$ENDIF}
              SetStrProp(Obj1, p, String(frxXMLToStr(Value)));
{$IFDEF Delphi12}
            tkUString, tkWString:
              SetStrProp(Obj1, p, frxXMLToStr(Value));
{$ENDIF}
            tkClass:
              AddFixup(Obj1, p, String(Value));

            tkVariant:
              SetVariantProp(Obj1, p, frxXMLToStr(Value));
          end;
      except
        on E: Exception do
          FErrors.Add(E.Message);
      end;
    end;
  end;
end;

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

  procedure DoOrdProp;
  var
    Value: Integer;

    function IsDefault: Boolean;
    begin
      if Ancestor <> nil then
        Result := Value = GetOrdProp(Ancestor, PropList[i])
      else
        Result := Value = PropList[i].Default;
    end;

  begin
    Value := GetOrdProp(Obj, PropList[i]);
    if not IsDefault 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;

    function IsDefault: Boolean;
    begin
      if Ancestor <> nil then
        Result := Abs(Value - GetFloatProp(Ancestor, PropList[i])) < 1e-6
      else
        Result := False;
    end;

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

  procedure DoStrProp;
  var
    Value: String;

    function IsDefault: Boolean;
    begin
      if Ancestor <> nil then
        Result := Value = GetStrProp(Ancestor, PropList[i])
      else
        Result := Value = '';
    end;

  begin
    Value := GetStrProp(Obj, PropList[i]);
    if not IsDefault or FSerializeDefaultValues then
      s := frxStrToXML(Value);