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:
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;
Interface
Type
TghXMLDoc = Class
Protected
FClassID :TGUID;
FContent :OLEVariant;
FPath :String;
FValidationError :OLEVariant;
FWorkNode :OLEVariant;
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;
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;
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;
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
GHXMLDocDefaultClassIDs :Array Of TGUID;
Implementation
Uses
GHFRTL, Variants, MSXML, SysUtils, XMLDoc;
Constructor TghXMLDoc.Create (Const ClassIDs :Array Of TGUID;
Const AContent :String = '');
Begin
ghCheckMSXMLDocClassIDs (ClassIDs);
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;
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 FWorkNode := FindNode (Value)
Else FWorkNode := IDispatch (Value);
End;
Procedure TghXMLDoc.AddSchema (Const NameSpace :String;
Const Schema :OLEVariant; Const ValidateContent :Boolean = False);
Begin
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 With ghLeftRight (Name, ' ') Do
Begin
Name := Value1;
NameSpace := Value2;
End
Else 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
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;
Function TghXMLDoc.Load (Const AContent :String) :Boolean;
Var
Prefix :String;
Begin
If (AContent = '') Or (AContent [1] = '<') Then
Begin
Result := Content.LoadXML (AContent); FPath := '';
End
Else 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
Prefix := '_';
Content.SetProperty ('SelectionNamespaces', Format ('xmlns:%s="%s"',
[Prefix, Content.DocumentElement.NameSpaceURI]));
End;
End;
Function TghXMLDoc.Node (Const Expr :String) :OLEVariant;
Begin
Result := WorkNode.SelectSingleNode (Expr);
End;
Function TghXMLDoc.Nodes (Const Expr :String) :OLEVariant;
Begin
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); FPath := ExpandedPath;
End;
End;
Initialization
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.