Wie füge ich ein namespace-Präfix zu jedem Knoten mit TXMLDocument

Mögliche Lösung für das problem mit mehreren namespace: Einhaken und Klasse Helfer

//
//The original Delphi code is : XMLHookUnit.pas released 2015.09.20
//Last version: 0.1 released 2015.09.20
//The initial developer is Cedomir Plavljanic ([email protected])
//Copyright (C) 2015-2015 Cedomir Plavljanic
//
//This program is free software; you can redistribute it and/or modify
//it under the terms of the GNU General Public License as published by
//the Free Software Foundation; either version 2 of the License, or
//(at your option) any later version
//
//This unit is distributed in the hope that it will be useful,
//but WITHOUT ANY WARRANTY; without even the implied warranty of
//MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//GNU General Public License for more details.
//
//
//This unit hooking 2 methods from XMLDoc.TXMLNode and 1 method from XMLDoc.TXMLNodeList
//Allows use of units created with XML binding wizard with multiple namespace
//
//This is only test
//
//       XML Binding Wizard
//         - change all the names that end with _ (All signature nodes have this problem)
//         - example: TSignatureType_ -> TSignatureType_ds
//
//Usage: add the unit to project
//
//This unit contains variables
//   - ListNameSpace - dictionary for pair prefixes and namespace
//         - in example pair is from XML Schema Definition in UBL 2.1 by Oasis
//           http://docs.oasis-open.org/ubl/os-UBL-2.1/UBL-2.1.html
//         - for own use must changed
//   - DigitalSignatureWithoutPrefix - flag for add or remove digital signature prefix in nodename
//
//
//This unit contains Helper: TXMLNodeListHelper, TXMLNodeHelper
//This unit contains function for hooking TXMLNode and TXMLNodeList
//For hooking in testing using example from Hook Api Library 0.2 [Ring3] By Anskya Email:[email protected]
// - with litle modification in call function VirtualProtect
//     - flNewProtect used as PAGE_READWRITE
//
//version: 0.1
//can be used with all versions of Delphi that have suport generic TDictionary
//for older versions of Delphi have to ask via e-mail or add support for TDictionary
//I also have a version for Delphi 2007 (XML binding wizard is bad, must be used from newer version of Delphi)
//


unit XMLHookUnit;

interface

uses
  System.Generics.Collections;

var
////Dictionary for pair prefixes and namespaces in all *.xsd file (without default namespace)
    ListNameSpace : TDictionary<String, String>;
//Include or Exclude ds: prefix in digital signature node
  DigitalSignatureWithoutPrefix : Boolean = True;

//Hook 1 methods from TXMLNodeList and 2 method from TXMLNode
//TXMLNodeList.GetNode
//TXMLNode.RegisterChildNode
//TXMLNode.InternalAddChildNode
//for hooking in testing using example from Hook Api Library 0.2 [Ring3] By Anskya Email:[email protected]
//with litle modification in call function VirtualProtect
//flNewProtect is PAGE_READWRITE
procedure HookXMLNodeLibrary;
//UnHook 1 methods from TXMLNodeList and 2 method from TXMLNode
//TXMLNodeList.GetNode
//TXMLNode.RegisterChildNode
//TXMLNode.InternalAddChildNode
//for unhooking in testing using example from Hook Api Library 0.2 [Ring3] By Anskya Email:[email protected]
//with litle modification in call function VirtualProtect
//flNewProtect is PAGE_READWRITE
procedure UnHookXMLNodeLibrary;

implementation

uses
  System.Types, StrUtils, Variants, HookApiLib, xmldom, XMLDoc, XMLIntf;

const
//namespace for digital signature
  NameSpace_DigitalSignature = 'http://www.w3.org/2000/09/xmldsig#';

var
//Flag is True if methods from XMLDoc are hooked
  IsHookXMLNodeLibrary : Boolean = False;

type
//access to proteted part in TXMLNodeList
  TXMLNodeListHelp = class(TXMLNodeList);
//access to proteted part in TXMLNode
  TXMLNodeHelp = class(TXMLNode);

//helper for TXMLNodelist
  TXMLNodeListHelper = class helper for TXMLNodeList
  public
//avoid overload trouble
//getnode call wrong findnode function
    function FindNodeHelp(aField: DOMString):IXMLNode;
//find prefix for node in ListNameSpace
    function FindPrefixHelp(aField:DOMString):String;
  end;

//helper function for TXMLNodelist
  TXMLNodeHelper = class helper for TXMLNode
  public
//extract LocalName, Prefix and Namespace based on NodeName
    procedure ExtractFieldPrefixNameSpace(const aNodeName: DOMString; out aField, aPrefix, aNameSpace: DOMString);
  end;

//prototype for hooking TXMLNodeList.GetNode
  TProtoTypeNodeListGetNode = function( const aSelf:TXMLNodeListHelp;
                                        const IndexOrName: OleVariant): IXMLNode;
//prototype for hooking TXMLNode.RegisterChildNode
  TProtoTypeNodeRegisterChildNode = procedure(const aSelf:TXMLNodeHelp;
                                              const aField: DOMString;
                                              const ChildNodeClass: TXMLNodeClass;
                                              const aNameSpace : DOMString);
//prototype for hooking TXMLNode.InternalAddChild
  TProtoTypeNodeInternalAddChild = function(const aSelf:TXMLNodeHelp;
                                            const NodeClass: TXMLNodeClass;
                                            const NodeName, NamespaceURI: DOMString;
                                            const Index: Integer): IXMLNode;

var
//Save old address for TXMLNodeList.GetNode
  SavePrototypeGetNode : TProtoTypeNodeListGetNode = nil;
//Save old address for TXMLNode.RegisterChildNode
  SaveProtoTypeRegisterChildNode : TProtoTypeNodeRegisterChildNode = nil;
//Save old address for TXMLNode.InternalAddChild
  SaveProtoTypeNodeInternalAddChild : TProtoTypeNodeInternalAddChild = nil;

{ TXMLNodeListHelper }

function TXMLNodeListHelper.FindNodeHelp(aField: DOMString): IXMLNode;

var
  aPrefix: string;

begin
  aPrefix := FindPrefixHelp(aField);
  if aPrefix <> '' then Result := FindNode(aPrefix+':'+aField, '');
  if Result = nil then Result := FindNode(aField, '');
end;

function TXMLNodeListHelper.FindPrefixHelp(aField: DOMString): String;

var
  aNodeClass:TNodeClassArray;
  i: Integer;
  aTest:TPair<String,String>;

begin
  Result := '';
  aNodeClass := TXMLNodeHelp(Self.Owner).ChildNodeClasses;
  aField:=ExtractLocalName(aField);
  for i := 0 to Length(aNodeClass)-1 do
    if aNodeClass[i].NodeName = aField then begin
      for aTest in ListNameSpace do begin
        if aTest.Value = aNodeClass[i].NamespaceURI then begin
          Result := aTest.Key;
          Break;
        end;
      end;
      Break;
    end;
end;

{ TXMLNodeHelper }
procedure TXMLNodeHelper.ExtractFieldPrefixNameSpace(const aNodeName : DOMString; out aField, aPrefix, aNameSpace: DOMString);
var
  i: Integer;
  sHelp:DOMString;
  Test:TPair<String,String>;
  Flag : Boolean;

begin
  sHelp := ExtractLocalName(aNodeName);
  aPrefix := '';
  aNameSpace := '';
  Flag := False;
  for i := 0 to Length(ChildNodeClasses) - 1 do begin
    if ChildNodeClasses[i].NodeName = sHelp then begin
      aNameSpace := ChildNodeClasses[i].NamespaceURI;
      for Test in ListNameSpace do begin
        if Test.Value = aNameSpace then begin
          aPrefix := Test.Key;
          Flag := DigitalSignatureWithoutPrefix and (aNameSpace = NameSpace_DigitalSignature);
          Break;
        end;
      end;
      Break;
    end;
  end;
  if (aPrefix = '') or (Flag) then begin
    aField := ExtractLocalName(aNodeName);
    if aNameSpace = '' then aNameSpace := GetNamespaceURI;
  end else
    aField := aPrefix + ':' + ExtractLocalName(aNodeName);
end;


//help function for find namaspase bassed on classname
//last part after underscore in classname is prefix
function GetNameSpace(const ChildNodeClass: TXMLNodeClass): DOMString;

var
  aList : TStringDynArray;

begin
  Result := ChildNodeClass.ClassName;
  aList:=StrUtils.SplitString(Result,'_');
  if Length(aList)>1 then
    ListNameSpace.TryGetValue(aList[Length(aList)-1],Result)
  else
   Result := '';
end;

//replace for TXMLNodeList.GetNode
function GetNodeHelp( const aSelf:TXMLNodeListHelp;
                      const IndexOrName: OleVariant):IXMLNode;

begin
  if VarIsOrdinal(IndexOrName) then
    Result := SavePrototypeGetNode(aSelf,IndexOrName)
  else begin
    Result := aSelf.FindNodeHelp(DOMString(IndexOrName));
    if Result = nil then
      Result := SavePrototypeGetNode(aSelf,IndexOrName);
  end;
end;

//replace for TXMLNode.RegisterChildNode
procedure RegisterChildNodeHelp(const aSelf:TXMLNodeHelp;
                                const aField: DOMString;
                                const ChildNodeClass: TXMLNodeClass;
                                const aNameSpace : DOMString);

var
  hNameSpace: DOMString;

begin
  if aNameSpace<>'' then
    hNameSpace := aNameSpace
  else begin
    hNameSpace := GetNameSpace(ChildNodeClass);
    if hNameSpace = '' then hNameSpace := aSelf.GetNamespaceURI;
  end;
  SaveProtoTypeRegisterChildNode(aSelf, aField, ChildNodeClass, hNameSpace);
end;

//replace for TXMLNode.InternalAddChild
function InternalAddChildHelp(const aSelf:TXMLNodeHelp;
                              const NodeClass: TXMLNodeClass;
                              const NodeName, NamespaceURI: DOMString;
                              const Index: Integer): IXMLNode;

var
  aField, aPrefix, aNameSpace:DOMString;

begin
  aSelf.ExtractFieldPrefixNameSpace(NodeName, aField, aPrefix, aNameSpace);
  Result := SaveProtoTypeNodeInternalAddChild(aSelf, NodeClass, aField, aNameSpace, Index);
end;


procedure HookXMLNodeLibrary;

begin
  if IsHookXMLNodeLibrary then Exit;

  @SavePrototypeGetNode := HookCode(@TXMLNodeListHelp.GetNode, @GetNodeHelp);
  @SaveProtoTypeRegisterChildNode := HookCode(@TXMLNodeHelp.RegisterChildNode, @RegisterChildNodeHelp);
  @SaveProtoTypeNodeInternalAddChild := HookCode(@TXMLNodeHelp.InternalAddChild, @InternalAddChildHelp);
  IsHookXMLNodeLibrary := True;
end;

procedure UnHookXMLNodeLibrary;

begin
  if not IsHookXMLNodeLibrary then Exit;

  UnHookCode(@SavePrototypeGetNode);
  UnHookCode(@SaveProtoTypeRegisterChildNode);

  UnHookCode(@SaveProtoTypeNodeInternalAddChild);

  SavePrototypeGetNode := nil;
  SaveProtoTypeRegisterChildNode := nil;
  SaveProtoTypeNodeInternalAddChild := nil;

  IsHookXMLNodeLibrary := False;
end;

//Dictionary for prefixes and namespaces
procedure AddNameSpace;

begin
    ListNameSpace.Add('xsd','http://www.w3.org/2001/XMLSchema');
    ListNameSpace.Add('cac','urn:oasis:names:specification:ubl:schema:xsd:CommonAggregateComponents-2');
    ListNameSpace.Add('cbc','urn:oasis:names:specification:ubl:schema:xsd:CommonBasicComponents-2');
    ListNameSpace.Add('ccts','urn:un:unece:uncefact:documentation:2');
    ListNameSpace.Add('ext','urn:oasis:names:specification:ubl:schema:xsd:CommonExtensionComponents-2');
    ListNameSpace.Add('udt','urn:oasis:names:specification:ubl:schema:xsd:UnqualifiedDataTypes-2');
    ListNameSpace.Add('qdt','urn:oasis:names:specification:ubl:schema:xsd:QualifiedDataTypes-2');
    ListNameSpace.Add('ccts-cct','urn:un:unece:uncefact:data:specification:CoreComponentTypeSchemaModule:2');
    ListNameSpace.Add('cct','urn:un:unece:uncefact:data:specification:CoreComponentTypeSchemaModule:2');
    ListNameSpace.Add('sig','urn:oasis:names:specification:ubl:schema:xsd:CommonSignatureComponents-2');
    ListNameSpace.Add('sac','urn:oasis:names:specification:ubl:schema:xsd:SignatureAggregateComponents-2');
    ListNameSpace.Add('ds','http://www.w3.org/2000/09/xmldsig#');
    ListNameSpace.Add('sbc','urn:oasis:names:specification:ubl:schema:xsd:SignatureBasicComponents-2');
  ListNameSpace.Add('xsi','http://www.w3.org/2001/XMLSchema-instance');

end;

initialization
  HookXMLNodeLibrary;
    ListNameSpace := TDictionary<String,String>.Create;
    AddNameSpace;
finalization
  UnHookXMLNodeLibrary;
    ListNameSpace.DisposeOf;
end.

Inspiriert durch die Lösung von Cedomir Plavljanic, ich erstellte Einheit Einhaken delphi-Verfahren und erlaubt die einfache Nutzung Einheiten erstellt, die mit Delphi XML Binding Wizard mit mehreren namespace und die richtigen Präfixe.

XMLDocHelper

unit XMLDocHelper;

(*
  (CreateCollection\(.+?,.+?, ')(.+?)\)
  \1tns:\2\)
  RegisterChildNode('
  RegisterChildNode('tns:
  ChildNodes['
  ChildNodes['tns:
  ItemTag := '
  ItemTag := 'tns:
*)

interface

uses DDetours, System.Variants, System.Generics.Collections, System.SysUtils, Xml.XMLDoc, Xml.XMLIntf, Xml.xmldom;

type
  TXMLNodeHelp = class(TXMLNode);
  TXMLNodeListHelp = class(TXMLNodeList);
  TXMLNodeCollectionHelp = class(TXMLNodeCollection);

type
  TXMLNodeHelper = class helper for TXMLNode
  public
    function _FindNamespaceURI(const TagOrPrefix: DOMString): DOMString;
  end;

var
  TrampolineXMLNode_RegisterChildNode: procedure(const aSelf: TXMLNodeHelp; const TagName: DOMString; ChildNodeClass: TXMLNodeClass; NamespaceURI: DOMString = '') = nil;
  TrampolineXMLNode_CreateCollection: function(const aSelf: TXMLNodeHelp; const CollectionClass: TXMLNodeCollectionClass; const ItemInterface: TGuid; const ItemTag: DOMString; ItemNS: DOMString = ''): TXMLNodeCollection = nil;
  TrampolineXMLNode_InternalAddChild: function(const aSelf: TXMLNodeHelp; NodeClass: TXMLNodeClass; const NodeName, NamespaceURI: DOMString; Index: Integer): IXMLNode;
  TrampolineXMLNodeList_GetNode: function(const aSelf: TXMLNodeListHelp; const aIndexOrName: OleVariant): IXMLNode = nil;
  TrampolineXMLNodeCollection_IsCollectionItem: function(const aSelf: TXMLNodeCollectionHelp; const Node: IXMLNode): Boolean;

implementation

procedure XMLNode_RegisterChildNodeHooked(const aSelf: TXMLNodeHelp; const TagName: DOMString; ChildNodeClass: TXMLNodeClass; NamespaceURI: DOMString = '');
begin
  if IsPrefixed(TagName) and (NamespaceURI = '') then
    TrampolineXMLNode_RegisterChildNode(aSelf, TagName, ChildNodeClass, aSelf._FindNamespaceURI(TagName))
  else
    TrampolineXMLNode_RegisterChildNode(aSelf, TagName, ChildNodeClass, NamespaceURI);
end;

function XMLNode_CreateCollectionHooked(const aSelf: TXMLNodeHelp; const CollectionClass: TXMLNodeCollectionClass; const ItemInterface: TGuid; const ItemTag: DOMString; ItemNS: DOMString = ''): TXMLNodeCollection;
begin
  Result := nil;
  if IsPrefixed(ItemTag) and (ItemNS = '') then
    Result := TrampolineXMLNode_CreateCollection(aSelf, CollectionClass, ItemInterface, ItemTag, aSelf._FindNamespaceURI(ItemTag));
  if Result = nil then
    Result := TrampolineXMLNode_CreateCollection(aSelf, CollectionClass, ItemInterface, ItemTag, ItemNS);
end;

function XMLNode_InternalAddChildHooked(const aSelf: TXMLNodeHelp; NodeClass: TXMLNodeClass; const NodeName, NamespaceURI: DOMString; Index: Integer): IXMLNode;
var
  NS: string;
begin
  NS := aSelf._FindNamespaceURI(NodeName);
  if NS = '' then
    NS := NamespaceURI;
  Result := TrampolineXMLNode_InternalAddChild(aSelf, NodeClass, NodeName, NS, Index)
end;

function XMLNodeList_GetNodeHooked(const aSelf: TXMLNodeListHelp; const aIndexOrName: OleVariant): IXMLNode;
begin
  if VarIsOrdinal(aIndexOrName) then
    Result := TrampolineXMLNodeList_GetNode(aSelf, aIndexOrName)
  else
  begin
    if IsPrefixed(aIndexOrName) then
      Result := aSelf.FindNode(ExtractLocalName(aIndexOrName), aSelf.Owner._FindNamespaceURI(aIndexOrName));
    if Result = nil then
      Result := TrampolineXMLNodeList_GetNode(aSelf, aIndexOrName);
  end;
end;

function XMLNodeCollection_IsCollectionItem(const aSelf: TXMLNodeCollectionHelp; const Node: IXMLNode): Boolean;

const
  AdjustIndex = 1 - Low(string);

type
  TStringSplitOption = (ssNone, ssRemoveEmptyEntries);
  TStringSplitOptions = set of TStringSplitOption;
  TDOMStringDynArray = array of DOMString;

  function SplitString(const S: DOMString; Delimiter: WideChar; const StringSplitOptions: TStringSplitOptions = []): TDOMStringDynArray;
  var
    LInputLength, LResultCapacity, LResultCount, LCurPos, LSplitStartPos: Integer;
  begin
    { Get the current capacity of the result array }
    LResultCapacity := Length(Result);
    { Reset the number of results already set }
    LResultCount := 0;
    { Start at the first character }
    LSplitStartPos := 1;
    { Save the length of the input }
    LInputLength := Length(S);
    { Step through the entire string }
    for LCurPos := 1 to LInputLength do
    begin
      { Find a delimiter }
      if S[LCurPos - AdjustIndex] = Delimiter then
      begin
        { Is the split non-empty, or are empty strings allowed? }
        if (LSplitStartPos < LCurPos) or not(ssRemoveEmptyEntries in StringSplitOptions) then
        begin
          { Split must be added - is there enough capacity in the result array? }
          if LResultCount = LResultCapacity then
          begin
            { Grow the result array - make it slightly more than double the
              current size }
            LResultCapacity := LResultCapacity * 2 + 8;
            SetLength(Result, LResultCapacity);
          end;
          { Set the string }
          SetString(Result[LResultCount], PWideChar(@S[LSplitStartPos - AdjustIndex]), LCurPos - LSplitStartPos);
          { Increment the result count }
          Inc(LResultCount);
        end;
        { Set the next split start position }
        LSplitStartPos := LCurPos + 1;
      end;
    end;
    { Add the final split }
    if (LSplitStartPos <= LInputLength) or not(ssRemoveEmptyEntries in StringSplitOptions) then
    begin
      { Correct the output length }
      if LResultCount + 1 <> LResultCapacity then
        SetLength(Result, LResultCount + 1);
      { Set the string }
      SetString(Result[LResultCount], PWideChar(@S[LSplitStartPos - AdjustIndex]), LInputLength - LSplitStartPos + 1);
    end
    else
    begin
      { No final split - correct the output length }
      if LResultCount <> LResultCapacity then
        SetLength(Result, LResultCount);
    end;
  end;

var
  I: Integer;
  LocalName: DOMString;
  FItemTags: TDOMStringDynArray;
begin
  Result := False;
  if Supports(Node, aSelf.ItemInterface) then
  begin
    LocalName := ExtractLocalName(Node.NodeName);
    Result := (LocalName = ExtractLocalName(aSelf.ItemTag)); //here is the Bug
    //If FItemTag has semicolons in it, then there are multiple valid names and we must check each one
    if not Result and (Pos(';', aSelf.ItemTag) > 0) then
    begin
      FItemTags := SplitString(aSelf.ItemTag, ';', [ssRemoveEmptyEntries]);
      for I := Low(FItemTags) to High(FItemTags) do
        if LocalName = ExtractLocalName(FItemTags[I]) then //and here is the Bug
        begin
          Result := True;
          Break;
        end;
    end;
  end;
end;

function TXMLNodeHelper._FindNamespaceURI(const TagOrPrefix: DOMString): DOMString;
begin
  Result := FindNamespaceURI(TagOrPrefix);
end;

initialization

@TrampolineXMLNode_RegisterChildNode := InterceptCreate(@TXMLNodeHelp.RegisterChildNode, @XMLNode_RegisterChildNodeHooked);
@TrampolineXMLNode_CreateCollection := InterceptCreate(@TXMLNodeHelp.CreateCollection, @XMLNode_CreateCollectionHooked);
@TrampolineXMLNode_InternalAddChild := InterceptCreate(@TXMLNodeHelp.InternalAddChild, @XMLNode_InternalAddChildHooked);
@TrampolineXMLNodeList_GetNode := InterceptCreate(@TXMLNodeListHelp.GetNode, @XMLNodeList_GetNodeHooked);
@TrampolineXMLNodeCollection_IsCollectionItem := InterceptCreate(@TXMLNodeCollectionHelp.IsCollectionItem, @XMLNodeCollection_IsCollectionItem);

finalization

if Assigned(TrampolineXMLNode_RegisterChildNode) then
begin
  InterceptRemove(@TrampolineXMLNode_RegisterChildNode);
  TrampolineXMLNode_RegisterChildNode := nil;
end;

if Assigned(TrampolineXMLNode_CreateCollection) then
begin
  InterceptRemove(@TrampolineXMLNode_CreateCollection);
  TrampolineXMLNode_CreateCollection := nil;
end;

if Assigned(TrampolineXMLNode_InternalAddChild) then
begin
  InterceptRemove(@TrampolineXMLNode_InternalAddChild);
  TrampolineXMLNode_InternalAddChild := nil;
end;

if Assigned(TrampolineXMLNodeList_GetNode) then
begin
  InterceptRemove(@TrampolineXMLNodeList_GetNode);
  TrampolineXMLNodeList_GetNode := nil;
end;

if Assigned(TrampolineXMLNodeCollection_IsCollectionItem) then
begin
  InterceptRemove(@TrampolineXMLNodeCollection_IsCollectionItem);
  TrampolineXMLNodeCollection_IsCollectionItem := nil;
end;

end.