[[Al González]]

Recuerden que todas las funciones y constantes descritas en las entradas anteriores (cuyos nombres inician con el prefijo gh), son elementos "sueltos" de la unidad GHFRTL, el kernel de GH Freebrary. Su uso no está restringido a la clase TghXMLDoc que les dio origen. Estos átomos pueden ser utilizados por cualquier programador para lo que guste o necesite (añadir GHFRTL al Uses), incluso para crear una clase mucho mejor y más completa que la mía, lo cual es bastante factible.

Considero una buena práctica y casi un deber moral el escribir clases, componentes o aplicaciones repartiendo el código en constantes, tipos y pequeñas funciones de uso general que no solo permitan cumplir con el objetivo particular del momento, sino que además sirvan luego para construir más clases, componentes y aplicaciones, ya sea por parte de otros programadores en su labor diaria o por uno mismo cuando haya que desarrollar la siguiente solución de software. Creo que esa es la verdadera esencia de las bibliotecas y mi manera de ampliar lo que Delphi hace por nosotros.

En seguida el código de la clase (GHFXMLDoc.pas). Observen que el constructor tiene dos sobrecargas, la primera de ellas es por si nosotros mismos queremos indicar la versión, o versiones, de MSXML a usar:

Código Delphi [-]
Doc := TghXMLDoc.Create ([ghciMSXMLDoc50]);

Aunque lo habitual será no especificar ningún CLSID y dejar que la clase lo determine:

Código Delphi [-]
Doc := TghXMLDoc.Create;

En este caso se intentará con las CLSIDs contenidas en una matriz dinámica de nombre GHXMLDocDefaultClassIDs, en la cual se establecen de forma predeterminada las GUIDs ghciMSXMLDoc60, ghciMSXMLDoc40 y ghciMSXMLDoc30 (ver sección Initialization al final de la unidad).

Código Delphi [-]
Unit GHFXMLDoc;  { XML Document }

Interface

  Type
    { XML Document class }
    TghXMLDoc = Class
      Protected
        { Fields }
        FClassID :TGUID;
        FContent :OLEVariant;
        FPath :String;
        FValidationError :OLEVariant;
        FWorkNode :OLEVariant;

        { Static methods }
        Function GetVersion :String;
        Function GetWorkLevel :Integer;
        Function GetWorkNode :OLEVariant;
        Procedure SearchError (Const Expr :String);
        Procedure SetWorkLevel (Value :Integer);
        Procedure SetWorkNode (Const Value :OLEVariant);
      Public
        Constructor Create (Const ClassIDs :Array Of TGUID;
          Const AContent :String = ''); Overload; Virtual;
        Constructor Create (Const AContent :String = ''); Overload;
          Virtual;

        { Static methods }
        Procedure AddSchema (Const NameSpace :String;
          Const Schema :OLEVariant;
          Const ValidateContent :Boolean = False); Overload;
        Procedure AddSchema (Const Schema :OLEVariant;
          Const ValidateContent :Boolean = False); Overload;
        Function CreateElement (Name :String; Const Text :String = '')
          :OLEVariant; Overload;
        Function CreateElement (Const Name, Attr :String;
          Const AttrValue :OLEVariant) :OLEVariant; Overload;
        Function CreateElement (Const Name, Text :String;
          Const Attrs :Array Of Const) :OLEVariant; Overload;
        Function CreateElement (Const Name :String;
          Const Attrs :Array Of Const) :OLEVariant; Overload;
        Function CreateElement (Const ParentLevel :Integer;
          Const Name :String; Const Text :String = '') :OLEVariant;
          Overload;
        Function CreateElement (Const ParentLevel :Integer;
          Const Name, Attr :String; Const AttrValue :OLEVariant)
          :OLEVariant; Overload;
        Function CreateElement (Const ParentLevel :Integer;
          Const Name, Text :String; Const Attrs :Array Of Const)
          :OLEVariant; Overload;
        Function CreateElement (Const ParentLevel :Integer;
          Const Name :String; Const Attrs :Array Of Const)
          :OLEVariant; Overload;
        Function FindNode (Const Expr :String) :OLEVariant; Overload;
        Function FindNode (Const Expr :String;
          Const Params :Array Of Const) :OLEVariant; Overload;
        Function FindNodes (Const Expr :String) :OLEVariant; Overload;
        Function FindNodes (Const Expr :String;
          Const Params :Array Of Const) :OLEVariant; Overload;
        Function FormatContent :String;
        Function LocateNode (Const Expr :String;
          Const RaiseError :Boolean = False) :Boolean;
        Function Node (Const Expr :String; Const Params :Array Of Const)
          :OLEVariant; Overload;
        Function Nodes (Const Expr :String; Const Params :Array Of Const)
          :OLEVariant; Overload;
        Function Validate :OLEVariant;

        { Virtual methods }
        Function Load (Const AContent :String) :Boolean; Virtual;
        Function Node (Const Expr :String) :OLEVariant; Overload; Virtual;
        Function Nodes (Const Expr :String) :OLEVariant; Overload; Virtual;
        Procedure Save (Const APath :String = ''); Virtual;

        { Properties }
        Property ClassID :TGUID Read FClassID;
        Property Content :OLEVariant Read FContent;
        Property Path :String Read FPath;
        Property ValidationError :OLEVariant Read FValidationError;
        Property Version :String Read GetVersion;
        Property WorkLevel :Integer Read GetWorkLevel Write SetWorkLevel;
        Property WorkNode :OLEVariant Read GetWorkNode Write SetWorkNode;
    End;

  Var
    { XML Document Default Class IDs }
    GHXMLDocDefaultClassIDs :Array Of TGUID;

Implementation

  Uses
    GHFRTL, Variants, MSXML, SysUtils, XMLDoc;

  { TghXMLDoc }

  Constructor TghXMLDoc.Create (Const ClassIDs :Array Of TGUID;
    Const AContent :String = '');
  Begin
    ghCheckMSXMLDocClassIDs (ClassIDs);

    { After calling ghCOMDispatch, FClassID is the class ID that this
      function used to create the FContent COM object (a DOMDocument).
      NOTE: With some versions of MSXML, it is not reliable to use
      IProvideClassInfo or IPersistStream.GetClassID to get the class ID of
      a DOMDocument instance (do not use them for that purpose). }
    FContent := ghCOMDispatch (ClassIDs, @FClassID);
    Content.Async := False;

    If (AContent <> '') And Not Load (AContent) Then
      ghRaise ('Invalid content or file for XML document.');
  End;

  Constructor TghXMLDoc.Create (Const AContent :String = '');
  Begin
    Create (GHXMLDocDefaultClassIDs, AContent);
  End;

  { Protected static methods }

  Function TghXMLDoc.GetVersion :String;
  Begin
    Result := ghMSXMLVersion (ClassID);
  End;

  Function TghXMLDoc.GetWorkLevel :Integer;
  Var
    ANode :OLEVariant;
  Begin
    ANode := WorkNode;
    Result := 0;

    While Not VarIsClear (ANode.ParentNode) Do
    Begin
      ANode := ANode.ParentNode;
      Inc (Result);
    End;
  End;

  Function TghXMLDoc.GetWorkNode :OLEVariant;
  Begin
    If VarIsClear (FWorkNode) Then
      If VarIsClear (Content.DocumentElement) Then
        FWorkNode := Content
      Else
        FWorkNode := Content.DocumentElement;

    Result := FWorkNode;
  End;

  Procedure TghXMLDoc.SearchError (Const Expr :String);
  Begin
    ghRaise ('Node(s) not found in XML document, expression: "%s".',
      [Expr]);
  End;

  Procedure TghXMLDoc.SetWorkLevel (Value :Integer);
  Begin
    If Value = WorkLevel Then
      Exit;

    Case Value Of
      0 : WorkNode := Content;
      1 : WorkNode := Content.DocumentElement;
      Else
        If Value > 0 Then
          If Value > WorkLevel Then
            ghRaise ('Can not point out a work level greater than 1 ' +
              '(%d) if current level is less than it (%d).',
              [Value, WorkLevel])
          Else
            WorkLevel := Value - WorkLevel
        Else
          While (Value < 0) And (WorkLevel > 0) Do
          Begin
            WorkNode := WorkNode.ParentNode;
            Inc (Value);
          End;
    End;
  End;

  Procedure TghXMLDoc.SetWorkNode (Const Value :OLEVariant);
  Begin
    If VarIsStr (Value) Then  // Node by expression
      FWorkNode := FindNode (Value)
    Else  // Node by automation object
      FWorkNode := IDispatch (Value);
  End;

  { Public static methods }

  Procedure TghXMLDoc.AddSchema (Const NameSpace :String;
    Const Schema :OLEVariant; Const ValidateContent :Boolean = False);
  Begin
    { NOTE: This call to VarIsNull is correct here, instead of the typical
      VarIsClear (automation/MSXML bug?). }
    If VarIsNull (Content.Schemas) Then
      Content.Schemas := ghMSXMLSchemaCache (ClassID);

    Content.Schemas.Add (NameSpace, Schema);

    If ValidateContent Then
      Validate;
  End;

  Procedure TghXMLDoc.AddSchema (Const Schema :OLEVariant;
    Const ValidateContent :Boolean = False);
  Begin
    AddSchema ('', Schema, ValidateContent);
  End;

  Function TghXMLDoc.CreateElement (Name :String; Const Text :String = '')
    :OLEVariant;
  Var
    NameSpace :String;
  Begin
    If Content.ChildNodes.Length = 0 Then
      Content.AppendChild (Content.CreateProcessingInstruction ('xml',
        'version="1.0" encoding="UTF-8"'));

    If ghIndex (Name, ' ') > 0 Then  // Name and name space
      With ghLeftRight (Name, ' ') Do
      Begin
        Name := Value1;
        NameSpace := Value2;
      End
    Else  // Name only, we use the document name space (if any)
      If Not VarIsClear (Content.DocumentElement) Then
        NameSpace := Content.DocumentElement.NameSpaceURI;

    Result := Content.CreateNode (Node_Element, Name, NameSpace);

    If Text <> '' Then
      Result.Text := Text;

    WorkNode.AppendChild (Result);
    WorkNode := Result;
  End;

  Function TghXMLDoc.CreateElement (Const Name, Attr :String;
    Const AttrValue :OLEVariant) :OLEVariant;
  Begin
    Result := CreateElement (Name);
    Result.SetAttribute (Attr, AttrValue);
  End;

  Function TghXMLDoc.CreateElement (Const Name, Text :String;
    Const Attrs :Array Of Const) :OLEVariant;
  Var
    I :Integer;
  Begin
    Result := CreateElement (Name, Text);

    For I := 0 To High (Attrs) Div 2 Do
      { NOTE: We use ghOLEVar instead of ghVar because, in Delphi 7,
        automation has a possible bug with Delphi string variants passed by
        value (SetAttribute takes the second parameter as if it were an
        empty string), even their value is internally converted to OLE
        string.  Delphi string variants passed by reference do not present
        such a problem. }
     Result.SetAttribute (ghOLEVar (Attrs [I * 2]),
       ghOLEVar (Attrs [(I * 2) + 1]));
  End;

  Function TghXMLDoc.CreateElement (Const Name :String;
    Const Attrs :Array Of Const) :OLEVariant;
  Begin
    Result := CreateElement (Name, '', Attrs);
  End;

  Function TghXMLDoc.CreateElement (Const ParentLevel :Integer;
    Const Name :String; Const Text :String = '') :OLEVariant;
  Begin
    WorkLevel := ParentLevel;
    Result := CreateElement (Name, Text);
  End;

  Function TghXMLDoc.CreateElement (Const ParentLevel :Integer;
    Const Name, Attr :String; Const AttrValue :OLEVariant) :OLEVariant;
  Begin
    WorkLevel := ParentLevel;
    Result := CreateElement (Name, Attr, AttrValue);
  End;

  Function TghXMLDoc.CreateElement (Const ParentLevel :Integer;
    Const Name, Text :String; Const Attrs :Array Of Const)
    :OLEVariant;
  Begin
    WorkLevel := ParentLevel;
    Result := CreateElement (Name, Text, Attrs);
  End;

  Function TghXMLDoc.CreateElement (Const ParentLevel :Integer;
    Const Name :String; Const Attrs :Array Of Const) :OLEVariant;
  Begin
    WorkLevel := ParentLevel;
    Result := CreateElement (Name, Attrs);
  End;

  Function TghXMLDoc.FindNode (Const Expr :String) :OLEVariant;
  Begin
    Result := Node (Expr);

    If VarIsClear (Result) Then
      SearchError (Expr);
  End;

  Function TghXMLDoc.FindNode (Const Expr :String;
    Const Params :Array Of Const) :OLEVariant;
  Begin
    Result := FindNode (Format (Expr, Params));
  End;

  Function TghXMLDoc.FindNodes (Const Expr :String) :OLEVariant;
  Begin
    Result := Nodes (Expr);

    If Result.Length = 0 Then
      SearchError (Expr);
  End;

  Function TghXMLDoc.FindNodes (Const Expr :String;
    Const Params :Array Of Const) :OLEVariant;
  Begin
    Result := FindNodes (Format (Expr, Params));
  End;

  Function TghXMLDoc.FormatContent :String;
  Begin
    Result := FormatXMLData (Content.XML);
  End;

  {$Warn No_RetVal Off}
  Function TghXMLDoc.LocateNode (Const Expr :String;
    Const RaiseError :Boolean = False) :Boolean;
  Var
    ANode :OLEVariant;
  Begin
    ANode := Node (Expr);

    If VarIsClear (ANode) Then
      If RaiseError Then
        SearchError (Expr)
      Else
        Result := False
    Else
    Begin
      WorkNode := ANode;
      Result := True;
    End;
  End;
  {$Warn No_RetVal On}

  Function TghXMLDoc.Node (Const Expr :String;
    Const Params :Array Of Const) :OLEVariant;
  Begin
    Result := Node (Format (Expr, Params));
  End;

  Function TghXMLDoc.Nodes (Const Expr :String;
    Const Params :Array Of Const) :OLEVariant;
  Begin
    Result := Nodes (Format (Expr, Params));
  End;

  Function TghXMLDoc.Validate :OLEVariant;
  Begin
    FValidationError := Content.Validate;
    Result := FValidationError;
  End;

  { Public virtual methods }

  Function TghXMLDoc.Load (Const AContent :String) :Boolean;
  Var
    Prefix :String;
  Begin
    If (AContent = '') Or (AContent [1] = '<') Then
    Begin
      Result := Content.LoadXML (AContent);  // XML text
      FPath := '';
    End
    Else  // File path
    Begin
      FPath := ghSearchPath (AContent, True);
      Result := Content.Load (FPath);

      If Not Result Then
        FPath := '';
    End;

    FWorkNode := Unassigned;

    If Result And (Content.DocumentElement.NameSpaceURI <> '') Then
    Begin
      Prefix := Content.DocumentElement.Prefix;

      If Prefix = '' Then
        { NOTE: The SelectNodes and SelectSingleNode methods of MSXML need
          that every name space in SelectionNamespaces has a prefix.  We
          use the "_" alias when the document element has no prefix. }
        Prefix := '_';

      Content.SetProperty ('SelectionNamespaces', Format ('xmlns:%s="%s"',
        [Prefix, Content.DocumentElement.NameSpaceURI]));
    End;
  End;

  Function TghXMLDoc.Node (Const Expr :String) :OLEVariant;
  Begin
    { We search from the current work node by using the given XPath
      expression.  NOTE: Expr can be a relative or absolute path. }
    Result := WorkNode.SelectSingleNode (Expr);
  End;

  Function TghXMLDoc.Nodes (Const Expr :String) :OLEVariant;
  Begin
    { We search from the current work node by using the given XPath
      expression.  NOTE: Expr can be a relative or absolute path. }
    Result := WorkNode.SelectNodes (Expr);
  End;

  Procedure TghXMLDoc.Save (Const APath :String = '');
  Var
    ExpandedPath :String;
  Begin
    If APath = '' Then
      Content.Save (Path)
    Else
    Begin
      ExpandedPath := ExpandFileName (APath);
      Content.Save (ExpandedPath);  // Exception if the Save method fails
      FPath := ExpandedPath;
    End;
  End;

Initialization
  { Preferred class IDs of MSXML DOMDocument.  NOTE: MSXML2.DOMDocument.5.0
    (ghciMSXMLDoc50) is part of Microsoft Office and not a formal Windows
    standard. }
  SetLength (GHXMLDocDefaultClassIDs, 3);
  GHXMLDocDefaultClassIDs [0] := ghciMSXMLDoc60;
  GHXMLDocDefaultClassIDs [1] := ghciMSXMLDoc40;
  GHXMLDocDefaultClassIDs [2] := ghciMSXMLDoc30;

End.

Lo único nuevo en la clase son las propiedades ClassID y Version, los constructores rehechos (conservando compatibilidad con versiones anteriores) y la adaptación del método TghXMLDoc.AddSchema. El largo pergamino de los mensajes anteriores fue para esas cuatro cosillas.

Por favor, no duden en preguntar sobre cualquier cuestión que les surja. Les recuerdo que necesito voluntarios para probar el código, más que nada para sacar nuevas ideas y perfeccionarlo entre todos. El estándar XML llegó para quedarse y cada vez se usa para más cosas. Esta humilde clase sólo es una propuesta de cómo facilitárnoslo en Delphi. Espero incluirla la semana que viene en la siguiente liberación para XE2.

¡Un abrazo!

Al González.