frxxmlserializer.pas

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

  end;

  procedure DoVariantProp;
  var
    Value: Variant;

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

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

  procedure DoClassProp;
  var
    FClass: TClass;
    FComp, FAncComp: TComponent;
    FObj, FAncObj: TPersistent;
  begin
    FClass := GetTypeData(PropList[i].PropType^).ClassType;
    if FClass.InheritsFrom(TComponent) then
    begin
      FComp := TComponent(GetOrdProp(Obj, PropList[i]));
      if Ancestor <> nil then
        FAncComp := TComponent(GetOrdProp(Ancestor, PropList[i]))
      else
        FAncComp := nil;

      if Ancestor <> nil then
      begin
        if (FComp = nil) and (FAncComp = nil) then Exit;
        if (FComp <> nil) and (FAncComp <> nil) then
          if CompareText(FComp.Name, FAncComp.Name) = 0 then Exit;
        if (FComp = nil) and (FAncComp <> nil) then
        begin
          s := 'nil';
          Exit;
        end;
      end;

      if FComp <> nil then
        s := frxGetFullName(FOwner, FComp);
    end
    else if FClass.InheritsFrom(TPersistent) then
    begin
      FObj := TPersistent(GetOrdProp(Obj, PropList[i]));
      if Ancestor <> nil then
        FAncObj := TPersistent(GetOrdProp(Ancestor, PropList[i]))
      else
        FAncObj := nil;

      if FObj is TStrings then
      begin
        if Ancestor <> nil then
          if TStrings(FObj).Text = TStrings(FAncObj).Text then
            Exit;
{$IFDEF Delphi12}
//        s := UTF8Encode(TStrings(FObj).Text);
        s := TStrings(FObj).Text;
{$ELSE}
        s := TStrings(FObj).Text;
{$ENDIF}
        if (Length(s) >= 2) and
           (s[Length(s) - 1] = #13) and (s[Length(s)] = #10) then
          Delete(s, Length(s) - 1, 2);
        s := ' ' + Add + String(PropList[i].Name) + '.Text="' +
          frxStrToXML(s) + '"';

      end
      else if FObj is {$IFDEF Delphi10}TfrxWideStrings{$ELSE}TWideStrings{$ENDIF} then
      begin
        // skip, handle separately
      end
      else
        s := ObjToXML(FObj, Add + String(PropList[i].Name) + '.', FAncObj);
      Flag := True;
    end;
  end;

  procedure DoNonPublishedProps;
  var
    wr: TWriter;
    ms, AncMs: TMemoryStream;
  begin
    ms := TMemoryStream.Create;
    try
      wr := TWriter.Create(ms, 4096);
      wr.Root := FOwner;

      try
        THackPersistent(Obj).DefineProperties(wr);
      finally
        wr.Free;
      end;

      if ms.Size > 0 then
      begin
        if Ancestor <> nil then
        begin
          AncMs := TMemoryStream.Create;
          try
            wr := TWriter.Create(AncMs, 4096);
            wr.Root := FOwner;

            try
              THackPersistent(Ancestor).DefineProperties(wr);
            finally
              wr.Free;
            end;
            if frxStreamCRC32(ms) = frxStreamCRC32(AncMs) then
              Exit;
          finally
            AncMs.Free;
          end;
        end;

        s := frxStreamToString(ms);
        Result := Result + ' ' + Add + 'PropData="' + s + '"';
      end;
    finally
      ms.Free;
    end;
  end;

begin
  Result := '';
  if Obj = nil then Exit;

  TypeInfo := Obj.ClassInfo;
  PropCount := GetTypeData(TypeInfo).PropCount;
  GetMem(PropList, PropCount * SizeOf(PPropInfo));
  GetPropInfos(TypeInfo, PropList);

  try
    if Obj is TfrxComponent then
    begin
      TfrxComponent(Obj).IsWriting := True;
      if (Ancestor = nil) and Assigned(FOnGetAncestor) then
        FOnGetAncestor(TfrxComponent(Obj).Name, Ancestor);
    end;
    if Ancestor is TfrxComponent then
      TfrxComponent(Ancestor).IsWriting := True;

    for i := 0 to PropCount - 1 do
    begin
      s := '';
      Flag := False;

      if IsStoredProp(Obj, PropList[i]) then
        case PropList[i].PropType^.Kind of
          tkInteger, tkSet, tkChar, tkWChar, tkEnumeration:
            DoOrdProp;

          tkFloat:
            DoFloatProp;

          tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
            DoStrProp;

          tkClass:
            DoClassProp;

          tkVariant:
            DoVariantProp;
        end;

      if s <> '' then
        if Flag then
          Result := Result + s
        else
          Result := Result + ' ' + Add + String(PropList[i].Name) + '="' + s + '"';
    end;

    if Obj is TfrxCustomMemoView then
      if (Ancestor = nil) or
        (TfrxCustomMemoView(Obj).Text <> TfrxCustomMemoView(Ancestor).Text) then
      begin
        ws := TfrxCustomMemoView(Obj).Text;
        if (Length(ws) >= 2) and
          (ws[Length(ws) - 1] = #13) and (ws[Length(ws)] = #10) then
            Delete(ws, Length(ws) - 1, 2);
{$IFDEF Delphi12}
        Result := Result + ' Text="' + frxStrToXML(ws) + '"';
{$ELSE}
        Result := Result + ' Text="' + frxStrToXML(Utf8Encode(ws)) + '"';
{$ENDIF}
      end;

    DoNonPublishedProps;

  finally
    if Obj is TfrxComponent then
      TfrxComponent(Obj).IsWriting := False;
    if Ancestor is TfrxComponent then
      TfrxComponent(Ancestor).IsWriting := False;
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

procedure TfrxXMLSerializer.ReadRootComponent(Root: TfrxComponent;
  XMLItem: TfrxXMLItem = nil);
var
  XMLDoc: TfrxXMLDocument;
  CompList: TList;

  procedure DoRead(Item: TfrxXMLItem; Owner: TfrxComponent);
  var
    i: Integer;
    c: TfrxComponent;
    IsAncestor: Boolean;
  begin
{$IFDEF Delphi12}
//   IsAncestor := AnsiStrIComp(PAnsiChar(Item.Name), PAnsiChar(AnsiString('inherited'))) = 0;
    IsAncestor := CompareText(Item.Name, 'inherited') = 0;
{$ELSE}
    IsAncestor := CompareText(Item.Name, 'inherited') = 0;
{$ENDIF}
    if not IsAncestor then
      try
        FindClass(String(Item.Name));
      except
        FErrors.Add(frxResources.Get('xrCantFindClass') + ' ' + String(Item.Name));
        Exit;
      end;

    if Owner <> nil then
    begin
      c := FOwner.FindComponent(String(Item.Prop['Name'])) as TfrxComponent;
      if not IsAncestor and (c = nil) then
      begin
        c := TfrxComponent(FindClass(String(Item.Name)).NewInstance);
        c.Create(Owner);
      end;
    end
    else
      c := Root;

    if c <> nil then
    begin
      c.IsLoading := True;
      XMLToObj(Item.Text, c);
      CompList.Add(c);

      for i := 0 to Item.Count - 1 do
        DoRead(Item[i], c);
    end;
  end;

  procedure DoLoaded;
  var
    i: Integer;
    c: TfrxComponent;
  begin
    for i := 0 to CompList.Count - 1 do
    begin
      c := CompList[i];
      c.IsLoading := False;
      if not (c is TfrxReport) then
        THackComponent(c).Loaded;
    end;
  end;

begin
  if Owner = nil then
    Owner := Root;
  XMLDoc := nil;
  CompList := TList.Create;

  if XMLItem = nil then
  begin
    XMLDoc := TfrxXMLDocument.Create;
    XMLItem := XMLDoc.Root;
    try
      XMLDoc.LoadFromStream(FStream);
      FOldFormat := XMLDoc.OldVersion;
    except
      XMLDoc.Free;
      CompList.Free;
      raise;
    end;
  end;

  FReader.Root := FOwner;
  FReader.BeginReferences;
  try
    DoRead(XMLItem, nil);
    FixupReferences;
    DoLoaded;
  finally
    if XMLDoc <> nil then
      XMLDoc.Free;
    CompList.Free;
  end;
end;

procedure TfrxXMLSerializer.WriteRootComponent(Root: TfrxComponent;
  SaveChildren: Boolean = True; XMLItem: TfrxXMLItem = nil; Streaming: Boolean = False);
var
  XMLDoc: TfrxXMLDocument;

  procedure DoWrite(Item: TfrxXMLItem; ARoot: TfrxComponent);
  var
    i: Integer;
  begin
    if ARoot.IsAncestor and not Streaming then
      Item.Name := 'inherited'
    else
      Item.Name := ARoot.ClassName;
    if ARoot = Root then
      Item.Text := ObjToXML(ARoot)
    else
      Item.Text := 'Name="' + ARoot.Name + '"' + ObjToXML(ARoot);
    if SaveChildren then
      for i := 0 to ARoot.Objects.Count - 1 do
        DoWrite(Item.Add, ARoot.Objects[i]);
  end;

begin
  if Owner = nil then
    Owner := Root;
  XMLDoc := nil;

  if XMLItem = nil then
  begin
    XMLDoc := TfrxXMLDocument.Create;
    XMLItem := XMLDoc.Root;
    XMLDoc.AutoIndent := True;
  end;

  try
    DoWrite(XMLItem, Root);
    if XMLDoc <> nil then
      XMLDoc.SaveToStream(FStream);
  finally
    if XMLDoc <> nil then
      XMLDoc.Free;
  end;
end;

function TfrxXMLSerializer.ReadComponent(Root: TfrxComponent): TfrxComponent;
var
  rd: TfrxXMLReader;
  RootItem: TfrxXMLItem;
begin
  rd := TfrxXMLReader.Create(FStream);
  RootItem := TfrxXMLItem.Create;

  try
    rd.ReadRootItem(RootItem, False);
    Result := ReadComponentStr(Root, RootItem.Name + ' ' + RootItem.Text);
  finally
    rd.Free;
    RootItem.Free;
  end;
end;

procedure TfrxXMLSerializer.WriteComponent(c: TfrxComponent);
var
  s: AnsiString;
begin
{$IFDEF Delphi12}
  s := '<' + UTF8Encode(WriteComponentStr(c)) + '/>';
{$ELSE}
  s := '<' + WriteComponentStr(c) + '/>';
{$ENDIF}
  FStream.Write(s[1], Length(s));
end;

function TfrxXMLSerializer.ReadComponentStr(Root: TfrxComponent;
  s: String; DontFixup: Boolean = False): TfrxComponent;
var
  n: Integer;
  s1: String;
begin
  Owner := Root;
  if Trim(String(s)) = '' then
    Result := nil
  else
  begin
    n := Pos(' ', s);
    s1 := Copy(s, n + 1, MaxInt);
    Delete(s, n, MaxInt);

    Result := TfrxComponent(FindClass(s).NewInstance);
    Result.Create(Root);

    FReader.Root := Root;
    FReader.BeginReferences;
    try
      Result.IsLoading := True;
      XMLToObj(s1, Result);
    finally
      if DontFixup then
      begin
        FReader.EndReferences;
        ClearFixups;
      end
      else
        FixupReferences;
      Result.IsLoading := False;
      if not (Result is TfrxReport) then
        THackComponent(Result).Loaded;
    end;
  end;
end;

function TfrxXMLSerializer.WriteComponentStr(c: TfrxComponent): String;
begin
  Result := c.ClassName + ObjToXML(c);
end;

procedure TfrxXMLSerializer.ReadPersistentStr(Root: TComponent;
  Obj: TPersistent; const s: String);
begin
  FReader.Root := Root;
  FReader.BeginReferences;
  XMLToObj(s, Obj);
  FixupReferences;
end;

end.



//