{ VerySimpleXML v3.0.0 - a lightweight, one-unit, cross-platform XML reader/writer for Delphi 10.4+ by Dennis Spreen http://blog.spreendigital.de/2014/09/13/verysimplexml-3-0/ (c) Copyrights 2011-2020 Dennis D. Spreen This unit is free and can be used for any needs. The introduction of any changes and the use of those changed library is permitted without limitations. Only requirement: This text must be present without changes in all modifications of library. * The contents of this file are used with permission, subject to * the Mozilla Public License Version 1.1 (the "License"); you may * * not use this file except in compliance with the License. You may * * obtain a copy of the License at * * http: www.mozilla.org/MPL/MPL-1.1.html * * * * Software distributed under the License is distributed on an * * "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or * * implied. See the License for the specific language governing * * rights and limitations under the License. * } unit Xml.VerySimple; interface uses System.Classes, System.SysUtils, Generics.Defaults, Generics.Collections, System.Rtti; const TXmlSpaces = #$20 + #$0A + #$0D + #9; type TXmlVerySimple = class; TXmlNode = class; TXmlNodeType = (ntElement, ntText, ntCData, ntProcessingInstr, ntComment, ntDocument, ntDocType, ntXmlDecl); TXmlNodeTypes = set of TXmlNodeType; TXmlNodeList = class; TXmlAttributeType = (atValue, atSingle); TXmlOptions = set of (doNodeAutoIndent, doCompact, doParseProcessingInstr, doPreserveWhiteSpace, doCaseInsensitive, doWriteBOM, doSimplifyTextNodes); TExtractTextOptions = set of (etoDeleteStopChar, etoStopString); {$IFNDEF AUTOREFCOUNT} WeakAttribute = class(TCustomAttribute); {$ENDIF} TStreamReaderFillBuffer = procedure(var Encoding: TEncoding) of object; TXmlStreamReader = class(TStreamReader) protected /// Call to FillBuffer method of TStreamreader procedure FillBuffer; overload; public /// Assures the read buffer holds at least Value characters function PrepareBuffer(Value: Integer): Boolean; /// Extract text until chars found in StopChars function ReadText(const StopChars: String; Options: TExtractTextOptions): String; virtual; /// Returns fist char but does not removes it from the buffer function FirstChar: String; /// Proceed with the next character(s) (value optional, default 1) procedure IncCharPos(Value: Integer = 1); virtual; /// Returns True if the first uppercased characters at the current position match Value function IsUppercaseText(const Value: String): Boolean; virtual; end; TXmlAttribute = class(TObject) private FValue: String; protected procedure SetValue(const Value: String); virtual; public /// Attribute name Name: String; /// Attributes without values are set to atSingle, else to atValue AttributeType: TXmlAttributeType; /// Create a new attribute constructor Create; virtual; /// Return the attribute as a String function AsString: String; /// Escapes XML control characters class function Escape(const Value: String): String; virtual; /// Assign attribute values from source attribute procedure Assign(Source: TXmlAttribute); virtual; /// Attribute value (always a String) property Value: String read FValue write SetValue; end; TXmlAttributeList = class(TObjectList) public /// The xml document of the attribute list of the node [Weak] Document: TXmlVerySimple; /// Add a name only attribute function Add(const Name: String): TXmlAttribute; overload; virtual; /// Returns the attribute given by name (case insensitive), NIL if no attribute found function Find(const Name: String): TXmlAttribute; virtual; /// Deletes an attribute given by name (case insensitive) procedure Delete(const Name: String); overload; virtual; /// Returns True if an attribute with the given name is found (case insensitive) function HasAttribute(const AttrName: String): Boolean; virtual; /// Returns the attributes in string representation function AsString: String; virtual; /// Clears current attributes and assigns all attributes from source attributes procedure Assign(Source: TXmlAttributeList); virtual; end; TXmlNode = class(TObject) protected [Weak] FDocument: TXmlVerySimple; procedure SetDocument(Value: TXmlVerySimple); function GetAttr(const AttrName: String): String; virtual; procedure SetAttr(const AttrName: String; const AttrValue: String); virtual; public /// All attributes of the node AttributeList: TXmlAttributeList; /// List of child nodes, never NIL ChildNodes: TXmlNodeList; /// Name of the node Name: String; // Node name /// The node type, see TXmlNodeType NodeType: TXmlNodeType; /// Parent node, may be NIL [Weak] Parent: TXmlNode; /// Text value of the node Text: String; /// Creates a new XML node constructor Create(ANodeType: TXmlNodeType = ntElement); virtual; /// Removes the node from its parent and frees all of its childs destructor Destroy; override; /// Clears the attributes, the text and all of its child nodes (but not the name) procedure Clear; /// Find a child node by its name function Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Find a child node by name and attribute name function Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Find a child node by name, attribute name and attribute value function Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Return a list of child nodes with the given name and (optional) node types function FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; virtual; /// Return a child node by NodePath function SelectNode(const NodePath: String): TXmlNode; overload; virtual; /// Returns True if the attribute exists function HasAttribute(const AttrName: String): Boolean; virtual; /// Returns True if a child node with that name exits function HasChild(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; virtual; /// Add a child node with an optional NodeType (default: ntElement) function AddChild(const AName: String; ANodeType: TXmlNodeType = ntElement): TXmlNode; virtual; /// Insert a child node at a specific position with a (optional) NodeType (default: ntElement) function InsertChild(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; /// Fluent interface for setting the text of the node function SetText(const Value: String): TXmlNode; virtual; /// Fluent interface for setting the node attribute given by attribute name and attribute value function SetAttribute(const AttrName, AttrValue: String): TXmlNode; virtual; /// Returns first child or NIL if there aren't any child nodes function FirstChild: TXmlNode; virtual; /// Returns last child node or NIL if there aren't any child nodes function LastChild: TXmlNode; virtual; /// Returns next sibling function NextSibling: TXmlNode; overload; virtual; /// Returns previous sibling function PreviousSibling: TXmlNode; overload; virtual; /// Returns True if the node has at least one child node function HasChildNodes: Boolean; virtual; /// Returns True if the node has a text content and no child nodes function IsTextElement: Boolean; virtual; /// Fluent interface for setting the node type function SetNodeType(Value: TXmlNodeType): TXmlNode; virtual; /// Attributes of a node, accessible by attribute name (case insensitive) property Attributes[const AttrName: String]: String read GetAttr write SetAttr; /// The xml document of the node property Document: TXmlVerySimple read FDocument write SetDocument; /// The node name, same as property Name property NodeName: String read Name write Name; /// The node text, same as property Text property NodeValue: String read Text write Text; end; TXmlNodeList = class(TObjectList) protected function IsSame(const Value1, Value2: String): Boolean; virtual; public /// The xml document of the node list [Weak] Document: TXmlVerySimple; /// The parent node of the node list [Weak] Parent: TXmlNode; /// Adds a node and sets the parent of the node to the parent of the list function Add(Value: TXmlNode): Integer; overload; virtual; /// Creates a new node of type NodeType (default ntElement) and adds it to the list function Add(NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; /// Add a child node with an optional NodeType (default: ntElement) function Add(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; /// Find a node by its name (case sensitive), returns NIL if no node is found function Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Same as Find(), returnsa a node by its name (case sensitive) function FindNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; virtual; /// Find a node that has the the given attribute, returns NIL if no node is found function Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Find a node that as the given attribute name and value, returns NIL otherwise function Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; overload; virtual; /// Return a list of child nodes with the given name and (optional) node types function FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; virtual; /// Returns True if the list contains a node with the given name function HasNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; virtual; /// Inserts a node at the given position function Insert(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; overload; virtual; /// Returns the first child node, same as .First function FirstChild: TXmlNode; virtual; /// Returns next sibling node function NextSibling(Node: TXmlNode): TXmlNode; virtual; /// Returns previous sibling node function PreviousSibling(Node: TXmlNode): TXmlNode; virtual; /// Returns the node at the given position function Get(Index: Integer): TXmlNode; virtual; end; TXmlVerySimple = class(TObject) protected FRoot: TXmlNode; [Weak] FHeader: TXmlNode; [Weak] FDocumentElement: TXmlNode; SkipIndent: Boolean; procedure Parse(Reader: TXmlStreamReader); virtual; procedure ParseComment(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; procedure ParseDocType(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; procedure ParseProcessingInstr(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; procedure ParseCData(Reader: TXmlStreamReader; var Parent: TXmlNode); virtual; procedure ParseText(const Line: String; Parent: TXmlNode; ReplaceText: Boolean = False); virtual; function ParseTag(Reader: TXmlStreamReader; FindText: Boolean; var Parent: TXmlNode): TXmlNode; overload; virtual; function ParseTag(const TagStr: String; var Parent: TXmlNode): TXmlNode; overload; virtual; procedure Walk(Writer: TStreamWriter; const PrefixNode: String; Node: TXmlNode); virtual; procedure SetText(const Value: String); virtual; function GetText: String; virtual; procedure SetEncoding(const Value: String); virtual; function GetEncoding: String; virtual; procedure SetVersion(const Value: String); virtual; function GetVersion: String; virtual; procedure Compose(Writer: TStreamWriter); virtual; procedure SetStandAlone(const Value: String); virtual; function GetStandAlone: String; virtual; function GetChildNodes: TXmlNodeList; virtual; procedure CreateHeaderNode; virtual; function ExtractText(var Line: String; const StopChars: String; Options: TExtractTextOptions): String; virtual; procedure SetDocumentElement(Value: TXMlNode); virtual; procedure SetPreserveWhitespace(Value: Boolean); function GetPreserveWhitespace: Boolean; function IsSame(const Value1, Value2: String): Boolean; public /// Indent used for the xml output NodeIndentStr: String; /// LineBreak used for the xml output, default set to sLineBreak which is OS dependent LineBreak: String; /// Options for xml output like indentation type Options: TXmlOptions; /// Creates a new XML document parser constructor Create; virtual; /// Destroys the XML document parser destructor Destroy; override; /// Deletes all nodes procedure Clear; virtual; /// Adds a new node to the document, if it's the first ntElement then sets it as .DocumentElement function AddChild(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; /// Creates a new node but doesn't adds it to the document nodes function CreateNode(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; virtual; /// Escapes XML control characters class function Escape(const Value: String): String; virtual; /// Translates escaped characters back into XML control characters class function Unescape(const Value: String): String; virtual; /// Loads the XML from a file function LoadFromFile(const FileName: String; BufferSize: Integer = 4096): TXmlVerySimple; virtual; /// Loads the XML from a stream function LoadFromStream(const Stream: TStream; BufferSize: Integer = 4096): TXmlVerySimple; virtual; /// Parse attributes into the attribute list for a given string procedure ParseAttributes(const AttribStr: String; AttributeList: TXmlAttributeList); virtual; /// Saves the XML to a file function SaveToFile(const FileName: String): TXmlVerySimple; virtual; /// Saves the XML to a stream, the encoding is specified in the .Encoding property function SaveToStream(const Stream: TStream): TXmlVerySimple; virtual; /// A list of all root nodes of the document property ChildNodes: TXmlNodeList read GetChildNodes; /// Returns the first element node property DocumentElement: TXmlNode read FDocumentElement write SetDocumentElement; /// Specifies the encoding of the XML file, anything else then 'utf-8' is considered as ANSI property Encoding: String read GetEncoding write SetEncoding; /// XML declarations are stored in here as Attributes property Header: TXmlNode read FHeader; /// Set to True if all spaces and linebreaks should be included as a text node, same as doPreserve option property PreserveWhitespace: Boolean read GetPreserveWhitespace write SetPreserveWhitespace; /// The root node of the document property Root: TXmlNode read FRoot; /// Defines the xml declaration property "StandAlone", set it to "yes" or "no" property StandAlone: String read GetStandAlone write SetStandAlone; /// The XML as a string representation property Text: String read GetText write SetText; /// Defines the xml declaration property "Version", default set to "1.0" property Version: String read GetVersion write SetVersion; /// The XML as a string representation, same as .Text property Xml: String read GetText write SetText; end; implementation uses System.StrUtils; { TVerySimpleXml } function TXmlVerySimple.AddChild(const Name: String; NodeType: TXmlNodeType = ntElement): TXmlNode; begin Result := CreateNode(Name, NodeType); if (NodeType = ntElement) and (not Assigned(FDocumentElement)) then FDocumentElement := Result; try FRoot.ChildNodes.Add(Result); except Result.Free; raise; end; Result.Document := Self; end; procedure TXmlVerySimple.Clear; begin FDocumentElement := NIL; FHeader := NIL; FRoot.Clear; end; constructor TXmlVerySimple.Create; begin inherited; FRoot := TXmlNode.Create; FRoot.NodeType := ntDocument; FRoot.Parent := FRoot; FRoot.Document := Self; NodeIndentStr := ' '; Options := [doNodeAutoIndent, doWriteBOM, doSimplifyTextNodes]; LineBreak := sLineBreak; CreateHeaderNode; end; procedure TXmlVerySimple.CreateHeaderNode; begin if Assigned(FHeader) then Exit; FHeader := FRoot.ChildNodes.Insert('xml', 0, ntXmlDecl); FHeader.Attributes['version'] := '1.0'; // Default XML version FHeader.Attributes['encoding'] := 'utf-8'; end; function TXmlVerySimple.CreateNode(const Name: String; NodeType: TXmlNodeType): TXmlNode; begin Result := TXmlNode.Create(NodeType); Result.Name := Name; Result.Document := Self; end; destructor TXmlVerySimple.Destroy; begin FRoot.Parent := NIL; FRoot.Clear; FRoot.Free; inherited; end; function TXmlVerySimple.GetChildNodes: TXmlNodeList; begin Result := FRoot.ChildNodes; end; function TXmlVerySimple.GetEncoding: String; begin if Assigned(FHeader) then Result := FHeader.Attributes['encoding'] else Result := ''; end; function TXmlVerySimple.GetPreserveWhitespace: Boolean; begin Result := doPreserveWhitespace in Options; end; function TXmlVerySimple.GetStandAlone: String; begin if Assigned(FHeader) then Result := FHeader.Attributes['standalone'] else Result := ''; end; function TXmlVerySimple.GetVersion: String; begin if Assigned(FHeader) then Result := FHeader.Attributes['version'] else Result := ''; end; function TXmlVerySimple.IsSame(const Value1, Value2: String): Boolean; begin if doCaseInsensitive in Options then Result := AnsiSameText(Value1, Value2) else Result := (Value1 = Value2); end; function TXmlVerySimple.GetText: String; var Stream: TStringStream; begin if AnsiSameText(Encoding, 'utf-8') then Stream := TStringStream.Create('', TEncoding.UTF8) else Stream := TStringStream.Create('', TEncoding.ANSI); try SaveToStream(Stream); Result := Stream.DataString; finally Stream.Free; end; end; procedure TXmlVerySimple.Compose(Writer: TStreamWriter); var Child: TXmlNode; begin if doCompact in Options then begin Writer.NewLine := ''; LineBreak := ''; end else Writer.NewLine := LineBreak; SkipIndent := False; for Child in FRoot.ChildNodes do Walk(Writer, '', Child); end; function TXmlVerySimple.LoadFromFile(const FileName: String; BufferSize: Integer = 4096): TXmlVerySimple; var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead + fmShareDenyWrite); try LoadFromStream(Stream, BufferSize); finally Stream.Free; end; Result := Self; end; function TXmlVerySimple.LoadFromStream(const Stream: TStream; BufferSize: Integer = 4096): TXmlVerySimple; var Reader: TXmlStreamReader; begin if Encoding.IsEmpty then // none specified then use UTF8 with DetectBom Reader := TXmlStreamReader.Create(Stream, TEncoding.UTF8, True, BufferSize) else if AnsiSameText(Encoding, 'utf-8') then Reader := TXmlStreamReader.Create(Stream, TEncoding.UTF8, False, BufferSize) else Reader := TXmlStreamReader.Create(Stream, TEncoding.ANSI, False, BufferSize); try Parse(Reader); finally Reader.Free; end; Result := Self; end; procedure TXmlVerySimple.Parse(Reader: TXmlStreamReader); var Parent, Node: TXmlNode; FirstChar: String; ALine: String; begin Clear; Parent := FRoot; while not Reader.EndOfStream do begin ALine := Reader.ReadText('<', [etoDeleteStopChar]); if not ALine.IsEmpty then // Check for text nodes begin ParseText(Aline, Parent); if Reader.EndOfStream then // if no chars available then exit Break; end; FirstChar := Reader.FirstChar; if FirstChar = '!' then if Reader.IsUppercaseText('!--') then // check for a comment node ParseComment(Reader, Parent) else if Reader.IsUppercaseText('!DOCTYPE') then // check for a doctype node ParseDocType(Reader, Parent) else if Reader.IsUppercaseText('![CDATA[') then // check for a cdata node ParseCData(Reader, Parent) else ParseTag(Reader, False, Parent) // try to parse as tag else // Check for XML header / processing instructions if FirstChar = '?' then // could be header or processing instruction ParseProcessingInstr(Reader, Parent) else if not FirstChar.IsEmpty then begin // Parse a tag, the first tag in a document is the DocumentElement Node := ParseTag(Reader, True, Parent); if (not Assigned(FDocumentElement)) and (Parent = FRoot) then FDocumentElement := Node; end; end; end; procedure TXmlVerySimple.ParseAttributes(const AttribStr: String; AttributeList: TXmlAttributeList); var Attribute: TXmlAttribute; AttrName, AttrText: String; Quote: String; Value: String; begin Value := TrimLeft(AttribStr); while not Value.IsEmpty do begin AttrName := ExtractText(Value, ' =', []); Value := TrimLeft(Value); Attribute := AttributeList.Add(AttrName); if (Value.IsEmpty) or (Value[1] <> '=') then Continue; Delete(Value, 1, 1); Attribute.AttributeType := atValue; ExtractText(Value, '''' + '"', []); Value := TrimLeft(Value); if not Value.IsEmpty then begin Quote := Value[1]; Delete(Value, 1, 1); AttrText := ExtractText(Value, Quote, [etoDeleteStopChar]); // Get Attribute Value Attribute.Value := Unescape(AttrText); Value := TrimLeft(Value); end; end; end; procedure TXmlVerySimple.ParseText(const Line: String; Parent: TXmlNode; ReplaceText: Boolean = False); var SingleChar: Char; Node: TXmlNode; TextNode: Boolean; begin if PreserveWhiteSpace then TextNode := True else begin TextNode := False; for SingleChar in Line do if not Assigned(AnsiStrScan(TXmlSpaces, SingleChar)) then begin TextNode := True; Break; end; end; if TextNode then if ReplaceText then Parent.Text := Line else begin Node := Parent.ChildNodes.Add(ntText); Node.Text := Line; end; end; procedure TXmlVerySimple.ParseCData(Reader: TXmlStreamReader; var Parent: TXmlNode); var Node: TXmlNode; begin Node := Parent.ChildNodes.Add(ntCData); Node.Text := Reader.ReadText(']]>', [etoDeleteStopChar, etoStopString]); end; procedure TXmlVerySimple.ParseComment(Reader: TXmlStreamReader; var Parent: TXmlNode); var Node: TXmlNode; begin Node := Parent.ChildNodes.Add(ntComment); Node.Text := Reader.ReadText('-->', [etoDeleteStopChar, etoStopString]); end; procedure TXmlVerySimple.ParseDocType(Reader: TXmlStreamReader; var Parent: TXmlNode); var Node: TXmlNode; Quote: String; begin Node := Parent.ChildNodes.Add(ntDocType); Node.Text := Reader.ReadText('>[', []); if not Reader.EndOfStream then begin Quote := Reader.FirstChar; Reader.IncCharPos; if Quote = '[' then Node.Text := Node.Text + Quote + Reader.ReadText(']',[etoDeleteStopChar]) + ']' + Reader.ReadText('>', [etoDeleteStopChar]); end; end; procedure TXmlVerySimple.ParseProcessingInstr(Reader: TXmlStreamReader; var Parent: TXmlNode); var Node: TXmlNode; Tag: String; begin Reader.IncCharPos; // omit the '?' Tag := Reader.ReadText('?>', [etoDeleteStopChar, etoStopString]); Node := ParseTag(Tag, Parent); if lowercase(Node.Name) = 'xml' then begin FHeader := Node; FHeader.NodeType := ntXmlDecl; end else begin Node.NodeType := ntProcessingInstr; if not (doParseProcessingInstr in Options) then begin Node.Text := Tag; Node.AttributeList.Clear; end; end; Parent := Node.Parent; end; function TXmlVerySimple.ParseTag(Reader: TXmlStreamReader; FindText: Boolean; var Parent: TXmlNode): TXmlNode; var Tag: String; ALine: String; begin Tag := Reader.ReadText('>', [etoDeleteStopChar]); Result := ParseTag(Tag, Parent); if (Result = Parent) and (FindText) then // only non-self closing nodes may have a text begin ALine := Reader.ReadText('<', []); ALine := Unescape(ALine); // if a node consists of text only then replace text, else parse as separate text node if not Aline.IsEmpty then ParseText(ALine, Result, doSimplifyTextNodes in Options); end; end; function TXmlVerySimple.ParseTag(const TagStr: String; var Parent: TXmlNode): TXmlNode; var Node: TXmlNode; ALine: String; CharPos: Integer; Tag: String; begin // A closing tag does not have any attributes nor text if (not TagStr.IsEmpty) and (TagStr[1] = '/') then begin Result := Parent; Parent := Parent.Parent; Exit; end; // Creat a new new ntElement node Node := Parent.ChildNodes.Add; Result := Node; Tag := TagStr; // Check for a self-closing Tag (does not have any text) if (not Tag.IsEmpty) and (Tag[High(Tag)] = '/') then Delete(Tag, Length(Tag), 1) else Parent := Node; CharPos := Pos(' ', Tag); if CharPos <> 0 then // Tag may have attributes begin ALine := Tag; Delete(Tag, CharPos, Length(Tag)); Delete(ALine, 1, CharPos); if not ALine.IsEmpty then ParseAttributes(ALine, Node.AttributeList); end; Node.Name := Tag; end; function TXmlVerySimple.SaveToFile(const FileName: String): TXmlVerySimple; var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream); finally Stream.Free; end; Result := Self; end; function TXmlVerySimple.SaveToStream(const Stream: TStream): TXmlVerySimple; var Writer: TStreamWriter; begin if AnsiSameText(Encoding, 'utf-8') then if doWriteBOM in Options then Writer := TStreamWriter.Create(Stream, TEncoding.UTF8) else Writer := TStreamWriter.Create(Stream) else Writer := TStreamWriter.Create(Stream, TEncoding.ANSI); try Compose(Writer); finally Writer.Free; end; Result := Self; end; procedure TXmlVerySimple.SetDocumentElement(Value: TXMlNode); begin FDocumentElement := Value; if not Assigned(Value.Parent) then FRoot.ChildNodes.Add(Value); end; procedure TXmlVerySimple.SetEncoding(const Value: String); begin CreateHeaderNode; FHeader.Attributes['encoding'] := Value; end; procedure TXmlVerySimple.SetPreserveWhitespace(Value: Boolean); begin if Value then Options := Options + [doPreserveWhitespace] else Options := Options - [doPreserveWhitespace] end; procedure TXmlVerySimple.SetStandAlone(const Value: String); begin CreateHeaderNode; FHeader.Attributes['standalone'] := Value; end; procedure TXmlVerySimple.SetVersion(const Value: String); begin CreateHeaderNode; FHeader.Attributes['version'] := Value; end; class function TXmlVerySimple.Unescape(const Value: String): String; begin Result := ReplaceStr(Value, '<', '<'); Result := ReplaceStr(Result, '>', '>'); Result := ReplaceStr(Result, '"', '"'); Result := ReplaceStr(Result, ''', ''''); Result := ReplaceStr(Result, '&', '&'); end; procedure TXmlVerySimple.SetText(const Value: String); var Stream: TStringStream; begin Stream := TStringStream.Create('', TEncoding.UTF8); try Stream.WriteString(Value); Stream.Position := 0; LoadFromStream(Stream); finally Stream.Free; end; end; procedure TXmlVerySimple.Walk(Writer: TStreamWriter; const PrefixNode: String; Node: TXmlNode); var Child: TXmlNode; Line: String; Indent: String; begin if (Node = FRoot.ChildNodes.First) or (SkipIndent) then begin Line := '<'; SkipIndent := False; end else Line := LineBreak + PrefixNode + '<'; case Node.NodeType of ntComment: begin Writer.Write(Line + '!--' + Node.Text + '-->'); Exit; end; ntDocType: begin Writer.Write(Line + '!DOCTYPE ' + Node.Text + '>'); Exit; end; ntCData: begin Writer.Write(''); Exit; end; ntText: begin Writer.Write(Node.Text); SkipIndent := True; Exit; end; ntProcessingInstr: begin if Node.AttributeList.Count > 0 then Writer.Write(Line + '?' + Node.Name + Node.AttributeList.AsString + '?>') else Writer.Write(Line + '?' + Node.Text + '?>'); Exit; end; ntXmlDecl: begin Writer.Write(Line + '?' + Node.Name + Node.AttributeList.AsString + '?>'); Exit; end; end; Line := Line + Node.Name + Node.AttributeList.AsString; // Self closing tags if (Node.Text.IsEmpty) and (not Node.HasChildNodes) then begin Writer.Write(Line + '/>'); Exit; end; Line := Line + '>'; if not Node.Text.IsEmpty then begin Line := Line + Escape(Node.Text); if Node.HasChildNodes then SkipIndent := True; end; Writer.Write(Line); // Set indent for child nodes if doCompact in Options then Indent := '' else Indent := PrefixNode + NodeIndentStr; // Process child nodes for Child in Node.ChildNodes do Walk(Writer, Indent, Child); // If node has child nodes and last child node is not a text node then set indent for closing tag if (Node.HasChildNodes) and (not SkipIndent) then Indent := LineBreak + PrefixNode else Indent := ''; Writer.Write(Indent + ''); end; class function TXmlVerySimple.Escape(const Value: String): String; begin Result := TXmlAttribute.Escape(Value); Result := ReplaceStr(Result, '''', '''); end; function TXmlVerySimple.ExtractText(var Line: String; const StopChars: String; Options: TExtractTextOptions): String; var CharPos, FoundPos: Integer; TestChar: Char; begin FoundPos := 0; for TestChar in StopChars do begin CharPos := Pos(TestChar, Line); if (CharPos <> 0) and ((FoundPos = 0) or (CharPos < FoundPos)) then FoundPos := CharPos; end; if FoundPos <> 0 then begin Dec(FoundPos); Result := Copy(Line, 1, FoundPos); if etoDeleteStopChar in Options then Inc(FoundPos); Delete(Line, 1, FoundPos); end else begin Result := Line; Line := ''; end; end; { TXmlNode } function TXmlNode.AddChild(const AName: String; ANodeType: TXmlNodeType = ntElement): TXmlNode; begin Result := ChildNodes.Add(AName, ANodeType); end; procedure TXmlNode.Clear; begin Text := ''; AttributeList.Clear; ChildNodes.Clear; end; constructor TXmlNode.Create(ANodeType: TXmlNodeType = ntElement); begin ChildNodes := TXmlNodeList.Create; ChildNodes.Parent := Self; AttributeList := TXmlAttributeList.Create; NodeType := ANodeType; end; destructor TXmlNode.Destroy; begin Clear; ChildNodes.Free; AttributeList.Free; inherited; end; function TXmlNode.Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; begin Result := ChildNodes.Find(Name, NodeTypes); end; function TXmlNode.Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; begin Result := ChildNodes.Find(Name, AttrName, AttrValue, NodeTypes); end; function TXmlNode.Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; begin Result := ChildNodes.Find(Name, AttrName, NodeTypes); end; function TXmlNode.FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; begin Result := ChildNodes.FindNodes(Name, NodeTypes); end; function TXmlNode.FirstChild: TXmlNode; begin Result := ChildNodes.First; end; function TXmlNode.GetAttr(const AttrName: String): String; var Attribute: TXmlAttribute; begin Attribute := AttributeList.Find(AttrName); if Assigned(Attribute) then Result := Attribute.Value else Result := ''; end; function TXmlNode.HasAttribute(const AttrName: String): Boolean; begin Result := AttributeList.HasAttribute(AttrName); end; function TXmlNode.HasChild(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; begin Result := ChildNodes.HasNode(Name, NodeTypes); end; function TXmlNode.HasChildNodes: Boolean; begin Result := (ChildNodes.Count > 0); end; function TXmlNode.InsertChild(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; begin Result := ChildNodes.Insert(Name, Position, NodeType); if Assigned(Result) then Result.Parent := Self; end; function TXmlNode.IsTextElement: Boolean; begin Result := (not Text.IsEmpty) and (not HasChildNodes); end; function TXmlNode.LastChild: TXmlNode; begin if ChildNodes.Count > 0 then Result := ChildNodes.Last else Result := NIL; end; function TXmlNode.NextSibling: TXmlNode; begin if not Assigned(Parent) then Result := NIL else Result := Parent.ChildNodes.NextSibling(Self); end; function TXmlNode.PreviousSibling: TXmlNode; begin if not Assigned(Parent) then Result := NIL else Result := Parent.ChildNodes.PreviousSibling(Self); end; function TXmlNode.SelectNode(const NodePath: String): TXmlNode; var Elements: TArray; Element: String; SubNode, Node: TXmlNode; begin Result := NIL; // SplitElements by '/' delimiter Elements := NodePath.Split(['/']); if not Assigned(Elements) then Exit; // Start from the root if the path is prefixed with '/' if Elements[0].IsEmpty then begin Node := FDocument.Root; Delete(Elements, 0, 1); end else Node := Self; // Traverse all elements SubNode := NIL; for Element in Elements do begin if Element.IsEmpty then Continue; SubNode := Node.Find(Element, []); if not Assigned(SubNode) then Break; Node := SubNode; end; Result := SubNode; end; procedure TXmlNode.SetAttr(const AttrName, AttrValue: String); begin SetAttribute(AttrName, AttrValue); end; function TXmlNode.SetAttribute(const AttrName, AttrValue: String): TXmlNode; var Attribute: TXmlAttribute; begin Attribute := AttributeList.Find(AttrName); // Search for given name if not Assigned(Attribute) then // If attribute is not found, create one Attribute := AttributeList.Add(AttrName); Attribute.AttributeType := atValue; Attribute.Name := AttrName; // this allows rewriting of the attribute name (lower/upper case) Attribute.Value := AttrValue; Result := Self; end; procedure TXmlNode.SetDocument(Value: TXmlVerySimple); begin FDocument := Value; AttributeList.Document := Value; ChildNodes.Document := Value; end; function TXmlNode.SetNodeType(Value: TXmlNodeType): TXmlNode; begin NodeType := Value; Result := Self; end; function TXmlNode.SetText(const Value: String): TXmlNode; begin Text := Value; Result := Self; end; { TXmlAttributeList } function TXmlAttributeList.Add(const Name: String): TXmlAttribute; begin Result := TXmlAttribute.Create; Result.Name := Name; try Add(Result); except Result.Free; raise; end; end; procedure TXmlAttributeList.Assign(Source: TXmlAttributeList); var Attribute: TXmlAttribute; SourceAttribute: TXmlAttribute; begin Clear; for SourceAttribute in Source do begin Attribute := Add(''); Attribute.Assign(SourceAttribute); end; end; function TXmlAttributeList.AsString: String; var Attribute: TXmlAttribute; begin Result := ''; for Attribute in Self do Result := Result + ' ' + Attribute.AsString; end; procedure TXmlAttributeList.Delete(const Name: String); var Attribute: TXmlAttribute; begin Attribute := Find(Name); if Assigned(Attribute) then Remove(Attribute); end; function TXmlAttributeList.Find(const Name: String): TXmlAttribute; var Attribute: TXmlAttribute; begin Result := NIL; for Attribute in Self do if ((Assigned(Document) and Document.IsSame(Attribute.Name, Name)) or // use the documents text comparison ((not Assigned(Document)) and (Attribute.Name = Name))) then // or if not assigned then compare names case sensitive begin Result := Attribute; Break; end; end; function TXmlAttributeList.HasAttribute(const AttrName: String): Boolean; begin Result := Assigned(Find(AttrName)); end; { TXmlNodeList } function TXmlNodeList.Find(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; var Node: TXmlNode; begin Result := NIL; for Node in Self do if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and (IsSame(Node.Name, Name)) then begin Result := Node; Break; end; end; function TXmlNodeList.Add(Value: TXmlNode): Integer; begin Result := inherited Add(Value); Value.Parent := Parent; end; function TXmlNodeList.Add(NodeType: TXmlNodeType = ntElement): TXmlNode; begin Result := TXmlNode.Create(NodeType); try Add(Result); except Result.Free; raise; end; Result.Document := Document; end; function TXmlNodeList.Add(const Name: String; NodeType: TXmlNodeType): TXmlNode; begin Result := Add(NodeType); Result.Name := Name; end; function TXmlNodeList.Find(const Name, AttrName, AttrValue: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; var Node: TXmlNode; begin Result := NIL; for Node in Self do if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and // if no type specified or node type in types IsSame(Node.Name, Name) and Node.HasAttribute(AttrName) and IsSame(Node.Attributes[AttrName], AttrValue) then begin Result := Node; Break; end; end; function TXmlNodeList.Find(const Name, AttrName: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; var Node: TXmlNode; begin Result := NIL; for Node in Self do if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and IsSame(Node.Name, Name) and Node.HasAttribute(AttrName) then begin Result := Node; Break; end; end; function TXmlNodeList.FindNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNode; begin Result := Find(Name, NodeTypes); end; function TXmlNodeList.FindNodes(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): TXmlNodeList; var Node: TXmlNode; begin Result := TXmlNodeList.Create(False); Result.Document := Document; try for Node in Self do if ((NodeTypes = []) or (Node.NodeType in NodeTypes)) and IsSame(Node.Name, Name) then begin Result.Parent := Node.Parent; Result.Add(Node); end; Result.Parent := NIL; except Result.Free; raise; end; end; function TXmlNodeList.FirstChild: TXmlNode; begin Result := First; end; function TXmlNodeList.Get(Index: Integer): TXmlNode; begin Result := Items[Index]; end; function TXmlNodeList.HasNode(const Name: String; NodeTypes: TXmlNodeTypes = [ntElement]): Boolean; begin Result := Assigned(Find(Name, NodeTypes)); end; function TXmlNodeList.Insert(const Name: String; Position: Integer; NodeType: TXmlNodeType = ntElement): TXmlNode; begin Result := TXmlNode.Create; Result.Document := Document; try Result.Name := Name; Result.NodeType := NodeType; Insert(Position, Result); except Result.Free; raise; end; end; function TXmlNodeList.IsSame(const Value1, Value2: String): Boolean; begin Result := ((Assigned(Document) and Document.IsSame(Value1, Value2)) or // use the documents text comparison ((not Assigned(Document)) and (Value1 = Value2))); // or if not assigned then compare names case sensitive end; function TXmlNodeList.NextSibling(Node: TXmlNode): TXmlNode; var Index: Integer; begin if (not Assigned(Node)) and (Count > 0) then Result := First else begin Index := IndexOf(Node); if (Index >= 0) and (Index + 1 < Count) then Result := Self[Index + 1] else Result := NIL; end; end; function TXmlNodeList.PreviousSibling(Node: TXmlNode): TXmlNode; var Index: Integer; begin Index := IndexOf(Node); if Index - 1 >= 0 then Result := Self[Index - 1] else Result := NIL; end; { TXmlAttribute } procedure TXmlAttribute.Assign(Source: TXmlAttribute); begin FValue := Source.Value; Name := Source.Name; AttributeType := Source.AttributeType; end; function TXmlAttribute.AsString: String; begin Result := Name; if AttributeType = atSingle then Exit; Result := Result + '="' + Escape(Value) + '"'; end; constructor TXmlAttribute.Create; begin AttributeType := atSingle; end; class function TXmlAttribute.Escape(const Value: String): String; begin Result := ReplaceStr(Value, '&', '&'); Result := ReplaceStr(Result, '<', '<'); Result := ReplaceStr(Result, '>', '>'); Result := ReplaceStr(Result, '"', '"'); end; procedure TXmlAttribute.SetValue(const Value: String); begin FValue := Value; AttributeType := atValue; end; { TXmlStreamReader } procedure TXmlStreamReader.FillBuffer; var TempEncoding: TEncoding; begin TempEncoding := CurrentEncoding; FillBuffer(TempEncoding); if TempEncoding <> CurrentEncoding then TRttiContext.Create.GetType(TStreamReader).GetField('FEncoding').SetValue(Self, TempEncoding) end; function TXmlStreamReader.FirstChar: String; begin if PrepareBuffer(1) then Result := FBufferedData.Chars[0] else Result := ''; end; procedure TXmlStreamReader.IncCharPos(Value: Integer); begin if PrepareBuffer(Value) then FBufferedData.Remove(0, Value); end; function TXmlStreamReader.IsUppercaseText(const Value: String): Boolean; var ValueLength: Integer; Text: String; begin Result := False; ValueLength := Length(Value); if PrepareBuffer(ValueLength) then begin Text := FBufferedData.ToString(0, ValueLength); if Text = Value then begin FBufferedData.Remove(0, ValueLength); Result := True; end; end; end; function TXmlStreamReader.PrepareBuffer(Value: Integer): Boolean; begin Result := False; if not Assigned(FBufferedData) then Exit; if (FBufferedData.Length < Value) and (not FNoDataInStream) then FillBuffer; Result := (FBufferedData.Length >= Value); end; function TXmlStreamReader.ReadText(const StopChars: String; Options: TExtractTextOptions): String; var NewLineIndex: Integer; PostNewLineIndex: Integer; StopChar: Char; Found: Boolean; TempIndex: Integer; StopCharLength: Integer; PrevLength: Integer; begin Result := ''; if not Assigned(FBufferedData) then Exit; NewLineIndex := 0; PostNewLineIndex := 0; StopCharLength := Length(StopChars); while True do begin // if we're searching for a string then assure the buffer is wide enough if (etoStopString in Options) and (NewLineIndex + StopCharLength > FBufferedData.Length) and (not FNoDataInStream) then FillBuffer; if NewLineIndex >= FBufferedData.Length then begin if FNoDataInStream then begin PostNewLineIndex := NewLineIndex; Break; end else begin PrevLength := FBufferedData.Length; FillBuffer; // Break if no more data if (FBufferedData.Length = 0) or (FBufferedData.Length = PrevLength) then Break; end; end; if etoStopString in Options then begin if NewLineIndex + StopCharLength - 1 < FBufferedData.Length then begin Found := True; TempIndex := NewLineIndex; for StopChar in StopChars do if FBufferedData[TempIndex] <> StopChar then begin Found := False; Break; end else Inc(TempIndex); if Found then begin if etoDeleteStopChar in Options then PostNewLineIndex := NewLineIndex + StopCharLength else PostNewLineIndex := NewLineIndex; Break; end; end; end else begin Found := False; for StopChar in StopChars do if FBufferedData[NewLineIndex] = StopChar then begin if etoDeleteStopChar in Options then PostNewLineIndex := NewLineIndex + 1 else PostNewLineIndex := NewLineIndex; Found := True; Break; end; if Found then Break; end; Inc(NewLineIndex); end; if NewLineIndex > 0 then Result := FBufferedData.ToString(0, NewLineIndex); FBufferedData.Remove(0, PostNewLineIndex); end; end.