unit uDAXMLUtils;

{----------------------------------------------------------------------------}
{ Data Abstract Library - Core Library                                       }
{                                                                            }
{ compiler: Delphi 6 and up, Kylix 3 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the Data Abstract              }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I DataAbstract.inc}

interface

uses Classes, TypInfo, uROXMLIntf, uDAInterfaces;

const
  // Misc
  ValueNIL = 'NIL';

  // Attribute names
  attr_Type = 'Type';
  attr_IsObject = 'IsObject';
  attr_ByRef = 'ByRef';
  attr_RefName = 'RefName';
  attr_Owner = 'Owner';
  attr_IsCollection = 'IsCollection';
  attr_IsArray = 'IsArray';
  attr_Count = 'Count';
  attr_ItemClass = 'ItemClass';
  attr_Item = 'Item';
  attr_ClassName = 'ClassName';
  attr_IsNull = 'IsNull';

type
  { Misc }
  TROXMLStreamerOption = (soIncludeType);
  TROXMLStreamerOptions = set of TROXMLStreamerOption;

  { TROXMLStreamer }
  TROXMLStreamer = class(TComponent)
  private
    fXMLStreamerOptions: TROXMLStreamerOptions;
    fPropertiesToIgnore: TStringList;

    procedure SetPropertiesToIgnore(const Value: TStrings);
    function GetPropertiesToIgnore: TStrings;

  protected
    procedure SerializeSimpleType(const aTargetNode: IXMLNode; anObject: TObject; aPropertyInfo: PPropInfo);
    procedure SerializeObject(const anObjectNode: IXMLNode; anObject: TObject; IsRoot: boolean = FALSE);

    procedure DeserializeObject(const anObjectNode: IXMLNode; anObject: TObject; IsRoot: boolean = FALSE);

  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure Serialize(const aSource: TObject; const anObjectNode: IXMLNode; IsRoot: boolean = True); overload;
    procedure Serialize(const aSource: TObject; aStream: TStream); overload;
    procedure Deserialize(aStream: TStream; aDestination: TObject);

  published
    property StreamerOptions: TROXMLStreamerOptions read fXMLStreamerOptions write fXMLStreamerOptions;
    property PropertiesToIgnore: TStrings read GetPropertiesToIgnore write SetPropertiesToIgnore;
  end;

// Quick access functions
procedure SaveObjectToXMLNode(aSource: TObject; anObjectNode: IXMLNode; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []; IsRoot: boolean = True);
procedure SaveObjectToStream(aSource: TObject; aStream: TStream; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []);
procedure LoadObjectFromStream(aStream: TStream; aDestination: TObject; somePropertiesToIgnore: array of string);

procedure SaveObjectToFile(aSource: TObject; const aFileName: string; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []);
procedure LoadObjectFromFile(const aFileName: string; aDestination: TObject; somePropertiesToIgnore: array of string);

// Dataset oriented functions
function DatasetToXML(
  const aDataset : IDADataset;
  const RootNodeName : string = '';
  const RecordNodeName : string = 'Record';
  IncludeSchema : boolean = TRUE) : IXMLDocument;

procedure XMLToCommandParams(const aCommand : IDASQLCommand; const XML : string);
function XMLToUpdateCommand(const aConnection : IDAConnection;
                            const aReferencedDataset : TDADataset;
                            const aTargetTableName : string;
                            const aXML : string) : IDASQLCommand;


implementation

uses SysUtils, uROTypes, Variants;

procedure SaveObjectToXMLNode(aSource: TObject; anObjectNode: IXMLNode; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []; IsRoot: boolean = True);
var
  i: integer;
begin
  with TROXMLStreamer.Create(nil) do try
    for i := 0 to High(somePropertiesToIgnore) do
      PropertiesToIgnore.Add(somePropertiesToIgnore[i]);

    StreamerOptions := someStreamerOptions;
    Serialize(aSource, anObjectNode,IsRoot);
  finally
    Free;
  end;
end;

procedure SaveObjectToStream(aSource: TObject; aStream: TStream; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []);
var
  i: integer;
begin
  with TROXMLStreamer.Create(nil) do try
    for i := 0 to High(somePropertiesToIgnore) do
      PropertiesToIgnore.Add(somePropertiesToIgnore[i]);

    StreamerOptions := someStreamerOptions;
    Serialize(aSource, aStream);
  finally
    Free;
  end;
end;

procedure LoadObjectFromStream(aStream: TStream; aDestination: TObject; somePropertiesToIgnore: array of string);
var
  i: integer;
begin
  with TROXMLStreamer.Create(nil) do try
    for i := 0 to High(somePropertiesToIgnore) do
      PropertiesToIgnore.Add(somePropertiesToIgnore[i]);

    Deserialize(aStream, aDestination);
  finally
    Free;
  end;
end;

procedure SaveObjectToFile(aSource: TObject; const aFileName: string; somePropertiesToIgnore: array of string; someStreamerOptions: TROXMLStreamerOptions = []);
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(aFileName, fmCreate);
  try
    SaveObjectToStream(aSource, fs, somePropertiesToIgnore, someStreamerOptions);
  finally
    fs.Free;
  end;
end;

procedure LoadObjectFromFile(const aFileName: string; aDestination: TObject; somePropertiesToIgnore: array of string);
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(aFileName, fmOpenRead + fmShareDenyWrite);
  try
    LoadObjectFromStream(fs, aDestination, somePropertiesToIgnore);
  finally
    fs.Free;
  end;
end;

{ TROXMLStreamer }

constructor TROXMLStreamer.Create(aOwner: TComponent);
begin
  inherited;

  fPropertiesToIgnore := TStringList.Create;
  fPropertiesToIgnore.Sorted := TRUE;
  fPropertiesToIgnore.Duplicates := dupError;

  fXMLStreamerOptions := [soIncludeType];
end;

destructor TROXMLStreamer.Destroy;
begin
  fPropertiesToIgnore.Free;

  inherited;
end;

procedure TROXMLStreamer.Deserialize(aStream: TStream; aDestination: TObject);
var
  xml: IXMLDocument;
begin
  if (aStream = nil) then raise Exception.Create('Invalid stream');

  xml := NewROXmlDocument;
  xml.New('');
  xml.LoadFromStream(aStream);

  if (xml.DocumentNode.Value = ValueNIL) then
    FreeAndNIL(aDestination)
  else
    DeserializeObject(xml.DocumentNode, aDestination, TRUE);
end;

procedure TROXMLStreamer.Serialize(const aSource: TObject; aStream: TStream);
var
  xml: IXMLDocument;
begin
  if (aStream = nil) then raise Exception.Create('Invalid stream');

  xml := NewROXmlDocument;
  try
    if (aSource = nil) then begin
      xml.New(ValueNIL);
      Exit;
    end
    else
      xml.New(aSource.ClassName);

    // Serializes the object
    SerializeObject(xml.DocumentNode, aSource, TRUE);
  finally
    xml.SaveToStream(aStream);
  end;
end;

procedure TROXMLStreamer.SerializeSimpleType(const aTargetNode: IXMLNode; anObject: TObject; aPropertyInfo: PPropInfo);
var
  int64val: int64;
  intval: integer;
  dblval: double;
  strval: string;
  {$IFNDEF DELPHI5}wstrval: widestring;
  {$ENDIF}
  lName: string;
begin
  lName := {$IFDEF UNICODE}UTF8ToString{$ENDIF}(aPropertyInfo^.Name);
  case aPropertyInfo^.PropType^.Kind of
    {$IFDEF FPC}tkBool,{$ENDIF}
    tkEnumeration: begin
      //enuval := GetOrdProp(anObject, lName);
        aTargetNode.Value := GetPropValue(anObject, lName, TRUE);
      end;

    tkInteger: begin
        intval := GetOrdProp(anObject, lName);
        aTargetNode.Value := intval;
      end;

    tkFloat: begin
        dblval := GetFloatProp(anObject, lName);
        aTargetNode.Value := dblval;
      end;

    tkLString,
     {$IFDEF FPC}tkAString,{$ENDIF}
    tkString: begin
        strval := GetStrProp(anObject, lName);
        aTargetNode.Value := strval;
      end;

    tkInt64: begin
        int64val := GetInt64Prop(anObject, lName);
        aTargetNode.Value := int64val;
      end;
    {$IFDEF UNICODE}tkUString,{$ENDIF}
    tkWString: begin
        {$IFDEF DELPHI5}
        strval := GetStrProp(anObject, lName);
        aTargetNode.Value := strval;
        {$ELSE}
        wstrval := GetWideStrProp(anObject, lName);
        aTargetNode.Value := wstrval;
        {$ENDIF}
      end;

    tkVariant, tkSet: begin
        aTargetNode.Value := GetVariantProp(anObject, lName);
      end;

  else
    raise Exception.Create(Format('Type not supported %s', [GetEnumName(TypeInfo(TTypeKind), Ord(aPropertyInfo^.PropType^.Kind))]))
  end;
end;

procedure TROXMLStreamer.SerializeObject(const anObjectNode: IXMLNode; anObject: TObject; IsRoot: boolean = FALSE);
var
  props: PPropList;
  x, cnt, i: integer;
  subnode, node: IXMLNode;
  coll: TCollection;
    // Temporary variables
  objval: TObject;
  pdata: PTypeData;
  lname: string;
begin
  if (anObject <> nil) and (anObject.ClassInfo <> nil) then begin
    pdata := GetTypeData(anObject.ClassInfo);

    if (pdata <> nil) then begin

      cnt := pdata.PropCount;

      if (cnt > 0) then begin
        GetMem(props, cnt * SizeOf(PPropInfo));

        try
          cnt := GetPropList(PTypeInfo(anObject.ClassInfo), tkProperties, props);

          for i := 0 to (cnt - 1) do begin
            lName := {$IFDEF UNICODE}UTF8ToString{$ENDIF}(props^[i]^.Name);
            if IsRoot and (fPropertiesToIgnore.IndexOf(lName) >= 0)
              or not IsStoredProp(anObject, props^[i]) then Continue;

            node := anObjectNode.Add(lName);

            with props^[i]^ do
              // Class types
              if (PropType^.Kind = tkClass) then begin
                node.AddAttribute(attr_Type, props^[i]^.PropType^.Name); // Always set fo object types
                objval := GetObjectProp(anObject, lName);
                node.AddAttribute(attr_IsObject, XMLBooleans[TRUE]);

                if Assigned(objval) then begin
                  // TComponent

                  if (objval is TStrings) then begin
                    node.Value := TStrings(objval).Text;
                  end else
                  if (objval is TComponent) then begin
                    if (TComponent(objval).Owner = anObject) then
                      SerializeObject(node, objval) // Owned sub-component
                    else begin
                      // Reference to another component
                      node.AddAttribute(attr_ByRef, XMLBooleans[TRUE]);
                      node.AddAttribute(attr_RefName, TComponent(objval).Name);
                      if (TComponent(objval).Owner <> nil) then node.AddAttribute(attr_Owner, TComponent(objval).Owner.Name);
                    end;
                  end

                  // TCollection
                  else if (objval is TCollection) then begin
                    coll := TCollection(objval);
                    node.AddAttribute(attr_IsCollection, XMLBooleans[TRUE]);
                    node.AddAttribute(attr_Count, coll.Count);
                    node.AddAttribute(attr_ItemClass, coll.ItemClass.ClassName);

                    for x := 0 to (coll.Count - 1) do begin
                      subnode := node.Add(attr_Item + IntToStr(x));
                      SerializeObject(subnode, coll.Items[x]);
                    end;
                  end

                  // Standard persistent class
                  else
                    SerializeObject(node, objval);
                end

                // NIL object
                else
                  node.AddAttribute(attr_IsNull, XMLBooleans[TRUE]);
              end

            // Simple types
              else begin
                if (soIncludeType in fXMLStreamerOptions) then node.AddAttribute(attr_Type, props^[i]^.PropType^.Name);
                SerializeSimpleType(node, anObject, props^[i]);
              end;
          end;
        finally
          FreeMem(props, cnt * SizeOf(PPropInfo));
        end;
      end

(*      // TROArray (they don't have properties so they will not fall in the previous block)
      else if (anObject is TROArray) then begin
        arr := TROArray(anObject);
        anObjectNode.AddAttribute(attr_IsArray, XMLBooleans[TRUE]);
        anObjectNode.AddAttribute(attr_Count, arr.Count);

        if (arr.GetItemType<>NIL) then begin
          anObjectNode.AddAttribute(attr_ItemClass, arr.GetItemType^.Name);
          for x := 0 to (arr.Count-1) do begin
            subnode := anObjectNode.Add(attr_Item+IntToStr(x));
            SerializeObject(subnode, TObject(arr.GetItemRef(x)));
          end;
        end;
      end*)
    end;
  end

  else
    anObjectNode.AddAttribute(attr_IsNull, XMLBooleans[TRUE]);
end;

procedure TROXMLStreamer.DeserializeObject(const anObjectNode: IXMLNode;
  anObject: TObject; IsRoot: boolean = FALSE);
var
  props: PPropList;
  x, cnt, i: integer;
  node: IXMLNode;
  coll: TCollection;

  // Temporary variables
  objval: TObject;
  pdata: PTypeData;
  collitem: TCollectionItem;
  strVal: string;
  lName: string;
begin
  if (anObjectNode.GetAttributeValue(attr_IsNull, XMLBooleans[FALSE]) = XMLBooleans[TRUE]) then begin
    //anObject := NIL;
    Exit;
  end;

  pdata := GetTypeData(anObject.ClassInfo);

  if (pdata <> nil) then begin

    cnt := pdata.PropCount;

    if (cnt > 0) then begin
      GetMem(props, cnt * SizeOf(PPropInfo));

      try
        cnt := GetPropList(PTypeInfo(anObject.ClassInfo), tkProperties, props);

        for i := 0 to (cnt - 1) do begin
          lname:= {$IFDEF UNICODE}UTF8ToString {$ENDIF}(props^[i]^.Name);
          if IsRoot and (fPropertiesToIgnore.IndexOf(lName) >= 0) then Continue;

          node := anObjectNode.GetNodeByName(lName);
          if (node = nil) then Continue; // Property was not streamed

          with props^[i]^ do
            // Class types
            if (PropType^.Kind = tkClass) then begin
              objval := GetObjectProp(anObject, lName);

              if (objval = nil) then
                Continue

              else begin
                // TComponent
                  if (objval is TStrings) then begin
                    TStrings(objval).Text := node.Value;
                  end else
                if (objval is TComponent) then begin
                  if (TComponent(objval).Owner = anObject) then
                    DeserializeObject(node, objval) // Owned sub-component
                  else begin
                    // Reference to another component
                    {node.AddAttribute(attr_ByRef, XMLBooleans[TRUE]);
                    node.AddAttribute(attr_RefName, TComponent(objval).Name);
                    if (TComponent(objval).Owner<>NIL)
                      then node.AddAttribute(attr_Owner, TComponent(objval).Owner.Name);}
                  end;
                end

                // TCollection
                else if (objval is TCollection) then begin
                  coll := TCollection(objval);
                  coll.Clear;

                  for x := 0 to (node.ChildrenCount - 1) do try
                    if SameText(Copy(node.Children[x].Name, 1, 4), attr_Item) then begin
                      collitem := coll.Add;
                      DeserializeObject(node.Children[x], collitem);
                    end;
                  except
                    raise
                  end;
                end

                // Standard persistent class
                else
                  DeserializeObject(node, objval);
              end
            end

          // Simple types
            else begin
              case PropType^.Kind of
                tkEnumeration: begin
                  // If enumerated values are empty, it should just skip and leave the defaults.
                  // Not doing so generates a range check error.
                  strVal := VarToStr(node.Value);
                  if (strVal<>'')
                    then SetPropValue(anObject, lName, GetEnumValue(props^[i]^.PropType{$IFNDEF FPC}^{$ENDIF}, strVal));
                end;
              else
                SetPropValue(anObject, lName, node.Value);
              end;
            end;
        end;
      finally
        FreeMem(props, cnt * SizeOf(PPropInfo));
      end;
    end

    // TROArray (they don't have properties so they will not fall in the previous block)
(*    else if (anObject is TROArray) then begin
      arr := TROArray(anObject);
      arr.Resize(anObjectNode.ChildrenCount-1);

      if (arr.GetItemType<>NIL) then begin
        arr.GetItemClass.Create
        anObjectNode.AddAttribute(attr_ItemClass, arr.GetItemType^.Name);
        for x := 0 to (arr.Count-1) do begin
          subnode := anObjectNode.Add(attr_Item+IntToStr(x));
          SerializeObject(subnode, TObject(arr.GetItemRef(x)));
        end;
      end;
    end*)
  end;
end;

procedure TROXMLStreamer.SetPropertiesToIgnore(const Value: TStrings);
begin
  fPropertiesToIgnore.Assign(Value);
end;

function TROXMLStreamer.GetPropertiesToIgnore: TStrings;
begin
  result := fPropertiesToIgnore;
end;

// Dataset oriented functions
function DatasetToXML(
  const aDataset : IDADataset;
  const RootNodeName : string = '';
  const RecordNodeName : string = 'Record';
  IncludeSchema : boolean = TRUE) : IXMLDocument;
var root, node : IXMLNode;
    i : integer;
begin
  result := NewROXmlDocument;

  if (RootNodeName<>'') then result.New(RootNodeName)
  else begin
    if (Trim(aDataset.Name)<>'') then result.New(aDataset.Name)
                                 else result.New('Dataset');
  end;

  if not aDataset.Active then Exit;

  root := result.DocumentNode;

  if IncludeSchema then begin
  end;

  while not aDataset.EOF do try
    node := root.Add(RecordNodeName);
    for i := 0 to aDataset.FieldCount-1 do begin
      node.Add(aDataset.Fields[i].Name).Value := aDataset.Fields[i].AsString;
    end;
  finally
    aDataset.Next;
  end;
end;

procedure XMLToCommandParams(const aCommand : IDASQLCommand; const XML : string);
var xmldoc : IXMLDocument;
    i : integer;
    node : IXMLNode;
    param : TDAParam;
begin
  xmldoc := NewROXmlDocument;
  xmldoc.New('CommandParams');
  xmldoc.XML := XML;

  for i := 0 to (aCommand.Params.Count-1) do
    aCommand.Params[i].Value := Null;

  for i := 0 to (xmldoc.DocumentNode.ChildrenCount-1) do begin
    node := xmldoc.DocumentNode.Children[i];
    param := aCommand.Params.FindParam(node.Name);
    if (param=NIL) then Continue;

    param.Value := node.Value;
  end;
end;

function XMLToUpdateCommand(const aConnection : IDAConnection;
                            const aReferencedDataset : TDADataset;
                            const aTargetTableName : string;
                            const aXML : string) : IDASQLCommand;
const CRLF = #13#10;
var fld : TDAField;
    i : integer;
    xmldoc : IXMLDocument;
    nme, where, sql : string;
begin
  xmldoc := NewROXmlDocument;
  xmldoc.New;
  xmldoc.XML := aXML;

  result := NIL;
  if (xmldoc.DocumentNode.ChildrenCount=0)
    then raise Exception.Create('Invalid XML document. Cannot generate an update statement');

  sql := 'UPDATE '+aTargetTableName+' SET'+CRLF;
  where := '';

  with xmldoc do begin
    for i := 0 to (DocumentNode.ChildrenCount-1) do begin
      nme := DocumentNode.Children[i].Name;
      fld := aReferencedDataset.Fields.FindField(nme);

      if (fld=NIL) then begin
        if (Pos(old_FieldPrefix, UpperCase(nme))=1) then begin
          if (where<>'') then where := where+' AND ';
          nme := Copy(nme, Length(old_FieldPrefix)+1, MaxInt);
          fld := aReferencedDataset.Fields.FindField(nme);
          if (fld=NIL) then Continue;
          if (fld.DataType in [datWideString, datString, datDateTime])
            then where := where+nme+'='+''''+VarToStr(DocumentNode.Children[i].Value)+''''
            else where := where+nme+'='+VarToStr(DocumentNode.Children[i].Value);

        end;
        Continue;
      end
      else begin
        sql := sql+fld.Name+'=';
        if (fld.DataType in [datWideString, datString, datDateTime])
          then sql := sql+''''+VarToStr(DocumentNode.Children[i].Value)+''''
          else sql := sql+VarToStr(DocumentNode.Children[i].Value);
        sql := sql+','+CRLF;
      end;
    end;
  end;
  sql := Copy(sql, 1, Length(sql)-3)+CRLF;

  if (where<>'') then sql := sql+' WHERE '+where;

  result := aConnection.NewCommand(sql, stSQL, 'UPDATE_'+aTargetTableName);
end;

procedure TROXMLStreamer.Serialize(const aSource: TObject; const anObjectNode: IXMLNode; IsRoot: boolean = True);
begin
  if (anObjectNode = nil) then raise Exception.Create('Invalid XMLNode.');
  if (aSource <> nil) then SerializeObject(anObjectNode, aSource, IsRoot);
end;

end.