unit uROMSXMLImpl;

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


{$I RemObjects.inc}

interface

uses Classes, ActiveX, uROMSXML2_TLB, uROXMLIntf;

type TMSXMLVersion = (msxml26, msxml30, msxml40);
     TMSXMLVersions = set of TMSXMLVersion;

const MSXMLFileNames : array[TMSXMLVersion] of string = ('msxml2.dll', 'msxml3.dll', 'msxml4.dll');

type { TROMSXMLNode }
     TROMSXMLNode = class(TInterfacedObject, IXMLNode)
     private
       fNode : IXMLDOMNode;
       fDoc : IXMLDocument;

     protected
       function GetName : widestring;
       function GetLocalName : widestring;
       function GetRef : pointer;

       function GetParent : IXMLNode;

       function GetValue : Variant;
       procedure SetValue(const Value : Variant);

       function GetXML : widestring;

       function GetAttributes(Index : integer) : IXMLNode;
       function GetAttributeCount : integer;

       function GetChildren(Index : integer) : IXMLNode;
       function GetChildrenCount : integer;

       function Add(const aNodeName : widestring; aNameSpaceURI: widestring = '') : IXMLNode;
       function AddAttribute(const anAttributeName : widestring; const anAttributeValue : Variant) : IXMLNode;
       function AddXml(const Xml: widestring): IXMLNode;

       procedure Delete(Index : integer);
       procedure Remove(const aNode : IXMLNode);

       function GetNodeByName(const aNodeName : widestring) : IXMLNode; // Returns NIL if none is found or exception. Up to you.
       function GetNodeValue(const aNodeName : widestring; const Default : Variant) : Variant;

       function GetAttributeByName(const anAttributeName : widestring) : IXMLNode;
       function GetAttributeValue(const anAttributeName : widestring; DefaultValue : Variant) : Variant;

       function GetNodesByName(const aNodeName : widestring) : IXMLNodeList; // Returns NIL if none are found or exception. Up to you.

       function GetNodeByAttribute(const anAttributeName, anAttributeValue : widestring) : IXMLNode;

       function GetFirstChild: IXMLNode;
       function GetNextSibling: IXMLNode;
       function GetNamespaceURI: WideString;
       function GetDocument: IXMLDocument;


     public
       constructor Create(const aNode : IXMLDOMNode; aDoc: IXMLDocument);
       destructor Destroy; override;
     end;

     { TROMSXMLNodeList }
     TROMSXMLNodeList = class(TInterfacedObject, IXMLNodeLIst)
     private
       fNodeList : IXMLDOMNodeList;
       fDoc: IXMLDocument;
     protected
       function GetNodes(Index : integer) : IXMLNode;
       function GetCount : integer;

     public
       constructor Create(const aNodeList : IXMLDOMNodeList; aDoc: IXMLDocument);
       destructor Destroy; override;
     end;

     { TROMSXMLDocument }
     TROMSXMLDocument = class(TInterfacedObject, IXMLDocument)
     private
       fDocument : IXMLDOMDocument2;

     protected
       function GetDocumentNode : IXMLNode;

       function GetEncoding : TXMLEncoding;

       procedure New(aDocumentName : widestring = ''; anEncoding : TXMLEncoding = xeUTF8);

       procedure SaveToStream(aStream : TStream);
       procedure SaveToFile(const aFileName : string);
       procedure LoadFromStream(aStream : TStream);
       procedure LoadFromFile(const aFileName : string);

       function GetXML:widestring;
       procedure SetXML(const Value : widestring);

       function Transform(const aXSL: string): string;

     public
       constructor Create;
       destructor Destroy; override;

     end;

var InstalledMSXMLVersions : TMSXMLVersions;

implementation

uses uRORes, uROClasses, SysUtils, ComObj, TYpInfo, Windows;

{ TROMSXMLNode }

constructor TROMSXMLNode.Create(const aNode : IXMLDOMNode; aDoc: IXMLDocument);
begin
  if not Assigned(aNode)
    then RaiseError(err_DOMElementIsNIL, []);

  inherited Create;

  fNode := aNode;
  fDoc := aDoc;
end;

destructor TROMSXMLNode.Destroy;
begin
  //fNode := NIL;
  inherited;
end;

function TROMSXMLNode.Add(const aNodeName: widestring; aNameSpaceURI: widestring = ''): IXMLNode;
var node : IXMLDOMNode;
begin
  if (aNameSpaceURI = '') and (GetNamespaceURI <> '') then aNameSpaceURI := GetNamespaceURI;
  if aNameSpaceURI = '' then
  begin
    node := fNode.attributes.getNamedItem('xmlns');
    if node <> nil then
      node := fNode.ownerDocument.createNode(NODE_ELEMENT, aNodeName, node.text)
    else
      node := fNode.ownerDocument.createElement(aNodeName);
  end
  else
    node := fNode.ownerDocument.createNode(NODE_ELEMENT, aNodeName, aNameSpaceURI);
  fNode.appendChild(node);

  result := TROMSXMLNode.Create(node, fDoc);
end;

procedure TROMSXMLNode.Delete(Index: integer);
begin
  fNode.removeChild(fNode.childNodes.item[Index])
end;

function TROMSXMLNode.GetAttributes(Index : integer): IXMLNode;
begin
  result := TROMSXMLNode.Create(fNode.attributes.item[Index], fDoc);
end;

function TROMSXMLNode.GetChildren(Index : integer): IXMLNode;
begin
  result := TROMSXMLNode.Create(fNode.childNodes.item[Index], fDoc)
end;

function TROMSXMLNode.GetName: widestring;
begin
  result := fNode.nodeName
end;

function TROMSXMLNode.GetXML: widestring;
begin
  result := fNode.XML;
end;

procedure TROMSXMLNode.Remove(const aNode: IXMLNode);
begin
  fNode.removeChild(IXMLDOMNode(aNode.Ref))
end;

function TROMSXMLNode.GetValue: Variant;
begin
  result := fNode.text
end;

procedure TROMSXMLNode.SetValue(const Value: Variant);
begin
  fNode.text := Value
end;

function TROMSXMLNode.GetNodeByName(const aNodeName: widestring): IXMLNode;
var //list : IXMLDOMNodeList;
    node : IXMLDOMNode;
begin
  result := NIL;

  node := fNode.selectSingleNode(aNodeName);

  if (node<>NIL)
    then result := TROMSXMLNode.Create(node, fDoc);
end;

function TROMSXMLNode.GetNodeByAttribute(const anAttributeName,
  anAttributeValue: widestring): IXMLNode;
var i : integer;
begin
  result := NIL;
  if fNode.attributes = nil then exit;
  for i := 0 to (fNode.attributes.length-1) do
    with fNode.attributes.item[i] do
      if (nodeName=anAttributeName) and (nodeValue=anAttributeValue) then begin
        result := TROMSXMLNode.Create(fNode.attributes.item[i], fDoc);
        Exit;
      end;
end;

function TROMSXMLNode.GetNodesByName(const aNodeName: widestring): IXMLNodeList;
var list : IXMLDOMNodeList;
begin
  result := NIL;

  list := fNode.selectNodes(aNodeName);

  if (list<>NIL) or (list.length>0)
    then result := TROMSXMLNodeList.Create(list, fDoc);
end;

function TROMSXMLNode.GetAttributeByName(
  const anAttributeName: widestring): IXMLNode;
var node : IXMLDOMNode;
begin
  result := NIL;
  if fNode.attributes = nil then exit;
  node := fNode.attributes.getNamedItem(anAttributeName);

  if (node<>NIL)
    then result := TROMSXMLNode.Create(node, fDoc);
end;

function TROMSXMLNode.GetRef: pointer;
begin
  result := pointer(fNode);
end;

function TROMSXMLNode.GetLocalName: widestring;
begin
  result := fNode.baseName
end;

function TROMSXMLNode.AddAttribute(const anAttributeName : widestring;
  const anAttributeValue : Variant) : IXMLNode;
var attr : IXMLDOMAttribute;
begin
  attr := fNode.ownerDocument.createAttribute(anAttributeName);
  attr.value := anAttributeValue;
  fNode.attributes.setNamedItem(attr);

  result := TROMSXMLNode.Create(attr, fDoc);
end;

function TROMSXMLNode.GetParent: IXMLNode;
begin
  result := NIL;
  if (fNode.parentNode<>NIL)
    then result := TROMSXMLNode.Create(fNode.parentNode, fDoc);
end;

function TROMSXMLNode.GetAttributeCount: integer;
begin
  result := fNode.attributes.length
end;

function TROMSXMLNode.GetChildrenCount: integer;
begin
  result := fNode.childNodes.length
end;

function TROMSXMLNode.GetAttributeValue(const anAttributeName: widestring;
  DefaultValue: Variant): Variant;
var attr : IXMLNode;
begin
  attr := GetAttributeByName(anAttributeName);
  if (attr<>NIL) then result := attr.Value
                else result := DefaultValue;
end;

function TROMSXMLNode.GetNodeValue(const aNodeName: widestring;
  const Default: Variant): Variant;
var node : IXMLNode;
begin
  node := GetNodeByName(aNodeName);
  if (node=NIL) then result := Default
                else result := node.Value;
end;

function TROMSXMLNode.GetFirstChild: IXMLNode;
var
  aNode: IXMLDOMNode;
begin
  aNode := fNode.firstChild;
  if aNode <> nil then
    Result := TROMSXMLNode.Create(aNode, fDoc)
  else
    Result := nil;
end;

function TROMSXMLNode.GetNextSibling: IXMLNode;
var
  aNode: IXMLDOMNode;
begin
  aNode := fNode.nextSibling;
  if aNode <> nil then
    Result := TROMSXMLNode.Create(aNode, fDoc)
  else
    Result := nil;
end;

function TROMSXMLNode.GetNamespaceURI: WideString;
begin
  result := fNode.namespaceURI;
end;

function TROMSXMLNode.AddXml(const Xml: widestring): IXMLNode;
var
  doc: TROMSXMLDocument;
begin
  doc := TROMSXMLDocument.Create;
  try
    doc.New();
    doc.SetXML(Xml);
    if doc.fDocument.documentElement <> nil then begin
      result := TROMSXMLNode.Create(fNode.appendChild(doc.fDocument.documentElement), fDoc);
    end else result := nil;
  finally
    doc.Free;
  end;
end;

function TROMSXMLNode.GetDocument: IXMLDocument;
begin
  Result := fDoc;
end;

{ TROMSXMLNodeList }

constructor TROMSXMLNodeList.Create(const aNodeList: IXMLDOMNodeList; aDoc: IXMLDocument);
begin
  if not Assigned(aNodeList)
    then RaiseError(err_DOMElementIsNIL, []);

  inherited Create;

  fNodeList := aNodeList;
  fDoc := aDoc;
end;

destructor TROMSXMLNodeList.Destroy;
begin
//  fNodeList := NIL;
  inherited;
end;

function TROMSXMLNodeList.GetCount: integer;
begin
  result := fNodeList.length
end;

function TROMSXMLNodeList.GetNodes(Index: integer): IXMLNode;
begin
  result := TROMSXMLNode.Create(fNodeList.item[Index], fDoc)
end;

{ TROMSXMLDocument }

constructor TROMSXMLDocument.Create;
begin
  inherited Create;
  fDocument := NIL;
end;

destructor TROMSXMLDocument.Destroy;
begin
  fDocument := NIL;
  inherited;
end;

function TROMSXMLDocument.GetDocumentNode: IXMLNode;
begin
  result := TROMSXMLNode.Create(fDocument.documentElement, self)
end;

function TROMSXMLDocument.GetEncoding: TXMLEncoding;
begin
  result := xeUTF8; // TODO: Complete the UTF8/16 differentiation.
end;

function TROMSXMLDocument.GetXml: widestring;
begin
  result := fDocument.xml;
end;

procedure TROMSXMLDocument.LoadFromFile(const aFileName: string);
begin
  if not fDocument.load(aFileName)
    then with fDocument.parseError do
      RaiseError(err_CannotLoadXMLDocument, [Reason, Line, linePos]);
end;

procedure TROMSXMLDocument.LoadFromStream(aStream: TStream);
var adapter : IStream;
begin
  aStream.Position := 0;
  adapter := TStreamAdapter.Create(aStream, soReference);
  fDocument.async := FALSE;
  if not fDocument.load(adapter) then
    with fDocument.parseError do
      RaiseError(err_CannotLoadXMLDocument, [Reason, Line, linePos]);
end;

procedure TROMSXMLDocument.New(aDocumentName : widestring = ''; anEncoding : TXMLEncoding = xeUTF8);
var
  lPi: IXMLDOMProcessingInstruction;
begin
{   !!! IMPORTANT !!!

    If you get an exception saying "CoInitialize has not been called" make sure the unit
    uROCOMInit.pas is included in *and* is the FIRST UNIT of your DPR file.

    For example:

       program NewProject;

       uses
         uROCOMInit, <--- HERE!!!
         Forms,
         [..]
}

  try
    if msxml40 in InstalledMSXMLVersions
      then fDocument := CoDOMDocument40.Create // See note above in case of an exception here

    else if msxml30 in InstalledMSXMLVersions
      then fDocument := CoDOMDocument30.Create // See note above in case of an exception here

    else if msxml26 in InstalledMSXMLVersions
      then fDocument := CoDOMDocument26.Create // See note above in case of an exception here

    else RaiseError(err_NoXMLParsersAvailable, []);

    fDocument.async := false;

  except
    on E:Exception do RaiseError(err_ErrorCreatingMsXmlDoc,[E.ClassName, E.Message]);
    else raise;
  end;

  if (aDocumentName<>'')
    then fDocument.documentElement := fDocument.createElement(aDocumentName);
  if anEncoding = xeUTF8 then
    lpi := fDocument.createProcessingInstruction('xml', 'version="1.0" encoding="utf-8"')
  else
    lpi := fDocument.createProcessingInstruction('xml', 'version="1.0" encoding="utf-16"');
  fDocument.insertBefore(lpi, fDocument.childNodes[0]);
  fDocument.preserveWhiteSpace := true;
  fDocument.resolveExternals := false;
  fDocument.validateOnParse := false;
end;

procedure TROMSXMLDocument.SaveToFile(const aFileName: string);
begin
  fDocument.save(aFileName);
end;

procedure TROMSXMLDocument.SaveToStream(aStream: TStream);
var adapter : IStream;
begin
  adapter := TStreamAdapter.Create(aStream, soReference);
  fDocument.save(adapter);
end;

function DetectMSXMLVersions : TMSXMLVersions;
var sysdir : array[0..199] of char;
    ver : TMSXMLVersion;
begin
  result := [];

  GetSystemDirectory(sysdir, SizeOf(sysdir));
  
  for ver := Low(TMSXMLVersion) to High(TMSXMLVersion) do
    if FileExists(sysdir+'\'+MSXMLFileNames[ver])
      then result := result+[ver];
end;

procedure TROMSXMLDocument.SetXML(const Value: widestring);
begin
  if not fDocument.loadXML(Value) then
    raise Exception.Create('Invalid input');
end;

const MSXMLDOM_Name = 'Msxml2.DOMDocument.3.0';

function TROMSXMLDocument.Transform(const aXSL: string): string;
var
  XSLStylesheet: IXMLDOMDocument2;
  XSLTemplate: IXSLTemplate;
  XSLProcessor: IXSLProcessor;
  adapter : IStream;
  aStream: TStringStream;
begin
  result := '';

  XSLStylesheet := CoFreeThreadedDomDocument.Create;
  XSLStylesheet.Async := FALSE;
  if not XSLStylesheet.loadXML(aXSL)
    then raise exception.create('Couldn''t load XSL stylesheet');

  XSLTemplate := CoXSLTemplate.Create;
  XSLTemplate._Set_stylesheet(XSLStylesheet);

  XSLProcessor := XSLTemplate.createprocessor;
  XSLProcessor.input := fDocument;

  aStream := TStringStream.Create('');
  try
    adapter := TStreamAdapter.Create(aStream, soReference);
    XSLProcessor.output := adapter; 
    if XSLProcessor.Transform
      then result := aStream.DataString;
    finally
      adapter:=nil;
      aStream.Free;
    end;
end;

initialization
// Removed in favour of the unit uROCOMInit.pas which has to be added as first unit to the project's DPR
// See http://www.devexpress.com/products/vcl/ewf/faq.asp#A8 for more info

//  CoInitializeEx(nil, COINIT_MULTITHREADED or COINIT_SPEED_OVER_MEMORY);

  InstalledMSXMLVersions := DetectMSXMLVersions;

finalization
//  CoUninitialize;

end.