nativexml.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:199k
源码类别:

Email服务器

开发平台:

Delphi

  1. { unit NativeXml
  2.   This is a small-footprint implementation to read and write XML documents
  3.   natively from Delpi code.
  4.   You can use this code to read XML documents from files, streams or strings.
  5.   The load routine generates events that can be used to display load progress
  6.   on the fly.
  7.   Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
  8.   Version: see below
  9.   Original date: 01-Apr-2003
  10.   Last Modified: 19-Mar-2007
  11.   Note: any external encoding (ANSI, UTF16, etc) is converted to an internal
  12.   encoding that is ANSI or UTF8. When the loaded document is ANSI based,
  13.   the encoding will be ANSI, in other cases (UTF8, UTF16) the encoding
  14.   will be UTF8.
  15.   Author: Nils Haeck M.Sc.
  16.   Copyright (c) 2003-2006 Simdesign B.V.
  17.   It is NOT allowed under ANY circumstances to publish or copy this code
  18.   without prior written permission of the Author!
  19.   This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
  20.   ANY KIND, either express or implied.
  21.   Please visit http://www.simdesign.nl/xml.html for more information.
  22. }
  23. {$DEFINE USEGRAPHICS} // uncomment if you do not want to include the Graphics unit.
  24. // Delphi and BCB versions
  25. // Delphi 3
  26. {$IFDEF VER110}
  27.   {$DEFINE D3UP}
  28. {$ENDIF}
  29. // Delphi 4
  30. {$IFDEF VER120}
  31.   {$DEFINE D3UP}
  32.   {$DEFINE D4UP}
  33. {$ENDIF}
  34. // BCB 4
  35. {$IFDEF VER125}
  36.   {$DEFINE D4UP}
  37. {$ENDIF}
  38. // Delphi 5
  39. {$IFDEF VER130}
  40.   {$DEFINE D3UP}
  41.   {$DEFINE D4UP}
  42.   {$DEFINE D5UP}
  43. {$ENDIF}
  44. //Delphi 6
  45. {$IFDEF VER140}
  46.   {$DEFINE D3UP}
  47.   {$DEFINE D4UP}
  48.   {$DEFINE D5UP}
  49.   {$DEFINE D6UP}
  50. {$ENDIF}
  51. //Delphi 7
  52. {$IFDEF VER150}
  53.   {$DEFINE D3UP}
  54.   {$DEFINE D4UP}
  55.   {$DEFINE D5UP}
  56.   {$DEFINE D6UP}
  57.   {$DEFINE D7UP}
  58. {$ENDIF}
  59. //Delphi 8
  60. {$IFDEF VER160}
  61.   {$DEFINE D3UP}
  62.   {$DEFINE D4UP}
  63.   {$DEFINE D5UP}
  64.   {$DEFINE D6UP}
  65.   {$DEFINE D7UP}
  66.   {$DEFINE D8UP}
  67. {$ENDIF}
  68. // Delphi 2005
  69. {$IFDEF VER170}
  70.   {$DEFINE D3UP}
  71.   {$DEFINE D4UP}
  72.   {$DEFINE D5UP}
  73.   {$DEFINE D6UP}
  74.   {$DEFINE D7UP}
  75.   {$DEFINE D8UP}
  76.   {$DEFINE D9UP}
  77. {$ENDIF}
  78. // Delphi 2006
  79. {$IFDEF VER180}
  80.   {$DEFINE D3UP}
  81.   {$DEFINE D4UP}
  82.   {$DEFINE D5UP}
  83.   {$DEFINE D6UP}
  84.   {$DEFINE D7UP}
  85.   {$DEFINE D8UP}
  86.   {$DEFINE D9UP}
  87.   {$DEFINE D10UP}
  88. {$ENDIF}
  89. unit NativeXml;
  90. interface
  91. uses
  92.   {$IFDEF D9UP}
  93.   Windows,
  94.   {$ENDIF}
  95.   {$IFDEF CLR}
  96.   System.Text,
  97.   {$ENDIF}
  98.   Classes,
  99.   {$IFDEF USEGRAPHICS}
  100.   {$IFDEF LINUX}
  101.   QGraphics,
  102.   {$ELSE}
  103.   Graphics,
  104.   {$ENDIF}
  105.   {$ENDIF}
  106.   SysUtils;
  107. const
  108.   // Current version of the NativeXml unit
  109.   cNativeXmlVersion = '2.32';
  110. // Delphi 3 and below stubs
  111. {$IFNDEF D4UP}
  112. type
  113.   TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);
  114.   int64 = integer;
  115. function StringReplace(const S, OldPattern, NewPattern: string;
  116.   Flags: TReplaceFlags): string;
  117. function StrToInt64Def(const AValue: string; ADefault: int64): int64;
  118. function StrToInt64(const AValue: string): int64;
  119. {$ENDIF}
  120. // Delphi 4 stubs
  121. {$IFNDEF D5UP}
  122. type
  123.   widestring = string;
  124. function AnsiPos(const Substr, S: string): Integer;
  125. function AnsiQuotedStr(const S: string; Quote: Char): string;
  126. function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
  127. procedure FreeAndNil(var Obj);
  128. {$ENDIF}
  129. // cross-platform pointer type
  130. type
  131.   {$IFDEF CLR}
  132.   TPointer = TObject;
  133.   {$ELSE}
  134.   TPointer = Pointer;
  135.   {$ENDIF}
  136. // Delphi 5 stubs
  137. {$IFNDEF D6UP}
  138. type
  139.   TSeekOrigin = Word;
  140. const
  141.   soBeginning = soFromBeginning;
  142.   soCurrent = soFromCurrent;
  143.   soEnd = soFromEnd;
  144. {$ENDIF}
  145. type
  146.   // Note on TNativeXml.Format:
  147.   // - xfReadable (default) to be able to read the xml file with a standard editor.
  148.   // - xfCompact to save the xml fully compliant and at smallest size
  149.   TXmlFormatType = (
  150.     xfReadable,   // Save in readable format with CR-LF and indents
  151.     xfCompact     // Save without any control chars except LF after declarations
  152.   );
  153.   // TXmlElementType enumerates the different kinds of elements that can be found
  154.   // in the XML document.
  155.   TXmlElementType = (
  156.     xeNormal,      // Normal element <name {attr}>[value][sub-elements]</name>
  157.     xeComment,     // Comment <!--{comment}-->
  158.     xeCData,       // literal data <![CDATA[{data}]]>
  159.     xeDeclaration, // XML declaration <?xml{declaration}?>
  160.     xeStylesheet,  // Stylesheet <?xml-stylesheet{stylesheet}?>
  161.     xeDoctype,     // DOCTYPE DTD declaration <!DOCTYPE{spec}>
  162.     xeElement,     // <!ELEMENT >
  163.     xeAttList,     // <!ATTLIST >
  164.     xeEntity,      // <!ENTITY >
  165.     xeNotation,    // <!NOTATION >
  166.     xeExclam,      // Any <!data>
  167.     xeQuestion,    // Any <?data?>
  168.     xeCharData,    // Character data in a node
  169.     xeUnknown      // Any <data>
  170.   );
  171.   // Choose what kind of binary encoding will be used when calling
  172.   // TXmlNode BufferRead and BufferWrite.
  173.   TBinaryEncodingType = (
  174.     xbeBinHex,  { With this encoding, each byte is stored as a hexadecimal
  175.                   number, e.g. 0 = 00 and 255 = FF.                        }
  176.     xbeBase64   { With this encoding, each group of 3 bytes are stored as 4
  177.                   characters, requiring 64 different characters.}
  178.   );
  179.   // Definition of different methods of string encoding.
  180.   TStringEncodingType = (
  181.     se8Bit,      // General 8 bit encoding, encoding must be determined from encoding declaration
  182.     seUCS4BE,    // UCS-4 Big Endian
  183.     seUCS4LE,    // UCS-4 Little Endian
  184.     seUCS4_2143, // UCS-4 unusual octet order (2143)
  185.     seUCS4_3412, // UCS-4 unusual octet order (3412)
  186.     se16BitBE,   // General 16 bit Big Endian, encoding must be determined from encoding declaration
  187.     se16BitLE,   // General 16 bit Little Endian, encoding must be determined from encoding declaration
  188.     seUTF8,      // UTF-8
  189.     seUTF16BE,   // UTF-16 Big Endian
  190.     seUTF16LE,   // UTF-16 Little Endian
  191.     seEBCDIC     // EBCDIC flavour
  192.   );
  193.   TXmlCompareOption = (
  194.     xcNodeName,
  195.     xcNodeType,
  196.     xcNodeValue,
  197.     xcAttribCount,
  198.     xcAttribNames,
  199.     xcAttribValues,
  200.     xcChildCount,
  201.     xcChildNames,
  202.     xcChildValues,
  203.     xcRecursive
  204.   );
  205.   TXmlCompareOptions = set of TXmlCompareOption;
  206. const
  207.   xcAll: TXmlCompareOptions = [xcNodeName, xcNodeType, xcNodeValue, xcAttribCount,
  208.     xcAttribNames, xcAttribValues, xcChildCount, xcChildNames, xcChildValues,
  209.     xcRecursive];
  210. var
  211.   // XML Defaults
  212.   cDefaultEncodingString:          string              = 'windows-1252';
  213.   cDefaultExternalEncoding:        TStringEncodingType = se8bit;
  214.   cDefaultVersionString:           string              = '1.0';
  215.   cDefaultXmlFormat:               TXmlFormatType      = xfCompact;
  216.   cDefaultWriteOnDefault:          boolean             = True;
  217.   cDefaultBinaryEncoding:          TBinaryEncodingType = xbeBase64;
  218.   cDefaultUtf8Encoded:             boolean             = False;
  219.   cDefaultIndentString:            string              = '  ';
  220.   cDefaultDropCommentsOnParse:     boolean             = False;
  221.   cDefaultUseFullNodes:            boolean             = False;
  222.   cDefaultSortAttributes:          boolean             = False;
  223.   cDefaultFloatAllowScientific:    boolean             = True;
  224.   cDefaultFloatSignificantDigits:  integer             = 6;
  225. type
  226.   TXmlNode = class;
  227.   TNativeXml = class;
  228.   TsdCodecStream = class;
  229.   // An event that is based on the TXmlNode object Node.
  230.   TXmlNodeEvent = procedure(Sender: TObject; Node: TXmlNode) of object;
  231.   // An event that is used to indicate load or save progress.
  232.   TXmlProgressEvent = procedure(Sender: TObject; Size: integer) of object;
  233.   // This event is used in the TNativeXml.OnNodeCompare event, and should
  234.   // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
  235.   TXmlNodeCompareEvent = function(Sender: TObject; Node1, Node2: TXmlNode; Info: TPointer): integer of object;
  236.   // Pass a function of this kind to TXmlNode.SortChildNodes. The function should
  237.   // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
  238.   TXMLNodeCompareFunction = function(Node1, Node2: TXmlNode; Info: TPointer): integer;
  239.   // The TXmlNode represents an element in the XML file. Each TNativeXml holds
  240.   // one Root element. Under ths root element, sub-elements can be nested (there
  241.   // is no limit on how deep). Property ElementType defines what kind of element
  242.   // this node is.
  243.   TXmlNode = class(TPersistent)
  244.   private
  245.     FAttributes: TStringList;      // List with attributes
  246.     FDocument: TNativeXml;         // Pointer to parent XmlDocument
  247.     FElementType: TXmlElementType; // The type of element
  248.     FName: string;                 // The element name
  249.     FNodes: TList;                 // These are the child elements
  250.     FParent: TXmlNode;             // Pointer to parent element
  251.     FTag: integer;                 // A value the developer can use
  252.     FValue: string;                // The *escaped* value
  253.     function GetValueAsString: string;
  254.     procedure SetAttributeName(Index: integer; const Value: string);
  255.     procedure SetAttributeValue(Index: integer; const Value: string);
  256.     procedure SetValueAsString(const AValue: string);
  257.     function GetIndent: string;
  258.     function GetLineFeed: string;
  259.     function GetTreeDepth: integer;
  260.     function GetAttributeCount: integer;
  261.     function GetAttributePair(Index: integer): string;
  262.     function GetAttributeName(Index: integer): string;
  263.     function GetAttributeValue(Index: integer): string;
  264.     function GetWriteOnDefault: boolean;
  265.     function GetBinaryEncoding: TBinaryEncodingType;
  266.     function GetCascadedName: string;
  267.     function QualifyAsDirectNode: boolean;
  268.     procedure SetName(const Value: string);
  269.     function GetFullPath: string;
  270.     procedure SetBinaryEncoding(const Value: TBinaryEncodingType);
  271.     function GetBinaryString: string;
  272.     procedure SetBinaryString(const Value: string);
  273.     function UseFullNodes: boolean;
  274.     function GetValueAsWidestring: widestring;
  275.     procedure SetValueAsWidestring(const Value: widestring);
  276.     function GetAttributeByName(const AName: string): string;
  277.     procedure SetAttributeByName(const AName, Value: string);
  278.     function GetValueAsInteger: integer;
  279.     procedure SetValueAsInteger(const Value: integer);
  280.     function GetValueAsFloat: double;
  281.     procedure SetValueAsFloat(const Value: double);
  282.     function GetValueAsDateTime: TDateTime;
  283.     procedure SetValueAsDateTime(const Value: TDateTime);
  284.     function GetValueAsBool: boolean;
  285.     procedure SetValueAsBool(const Value: boolean);
  286.     function GetValueAsInt64: int64;
  287.     procedure SetValueAsInt64(const Value: int64);
  288.     procedure CheckCreateAttributesList;
  289.     function GetAttributeValueAsWidestring(Index: integer): widestring;
  290.     procedure SetAttributeValueAsWidestring(Index: integer;
  291.       const Value: widestring);
  292.     function GetAttributeValueAsInteger(Index: integer): integer;
  293.     procedure SetAttributeValueAsInteger(Index: integer;
  294.       const Value: integer);
  295.     function GetAttributeByNameWide(const AName: string): widestring;
  296.     procedure SetAttributeByNameWide(const AName: string;
  297.       const Value: widestring);
  298.     function GetTotalNodeCount: integer;
  299.     function FloatSignificantDigits: integer;
  300.     function FloatAllowScientific: boolean;
  301.   protected
  302.     function CompareNodeName(const NodeName: string): integer;
  303.     function GetNodes(Index: integer): TXmlNode; virtual;
  304.     function GetNodeCount: integer; virtual;
  305.     procedure ParseTag(const AValue: string; TagStart, TagClose: integer);
  306.     procedure ReadFromStream(S: TStream); virtual;
  307.     procedure ReadFromString(const AValue: string); virtual;
  308.     procedure ResolveEntityReferences;
  309.     function UnescapeString(const AValue: string): string; virtual;
  310.     function Utf8Encoded: boolean;
  311.     function WriteInnerTag: string; virtual;
  312.     procedure WriteToStream(S: TStream); virtual;
  313.   public
  314.     // Create a new TXmlNode object. ADocument must be the TNativeXml that is
  315.     // going to hold this new node.
  316.     constructor Create(ADocument: TNativeXml); virtual;
  317.     // Create a new TXmlNode with name AName. ADocument must be the TNativeXml
  318.     // that is going to hold this new node.
  319.     constructor CreateName(ADocument: TNativeXml; const AName: string); virtual;
  320.     // Create a new TXmlNode with name AName and string value AValue. ADocument
  321.     // must be the TNativeXml that is going to hold this new node.
  322.     constructor CreateNameValue(ADocument: TNativeXml; const AName, AValue: string); virtual;
  323.     // Create a new TXmlNode with XML element type AType. ADocument must be the
  324.     // TNativeXml that is going to hold this new node.
  325.     constructor CreateType(ADocument: TNativeXml; AType: TXmlElementType); virtual;
  326.     // Use Assign to assign another TXmlNode to this node. This means that all
  327.     // properties and subnodes from the Source TXmlNode are copied to the current
  328.     // node. You can also Assign a TNativeXml document to the node, in that case
  329.     // the RootNodeList property of the TNativeXml object will be copied.
  330.     procedure Assign(Source: TPersistent); override;
  331.     // Call Delete to delete this node completely from the parent node list. This
  332.     // call only succeeds if the node has a parent. It has no effect when called for
  333.     // the root node.
  334.     procedure Delete; virtual;
  335.     // Delete all nodes that are empty (this means, which have no subnodes, no
  336.     // attributes, and no value assigned). This procedure works recursively.
  337.     procedure DeleteEmptyNodes;
  338.     // Destroy a TXmlNode object. This will free the child node list automatically.
  339.     // Never call this method directly. All TXmlNodes in the document will be
  340.     // recursively freed when TNativeXml.Free is called.
  341.     destructor Destroy; override;
  342.     {$IFDEF D4UP}
  343.     // Use this method to add an integer attribute to the node.
  344.     procedure AttributeAdd(const AName: string; AValue: integer); overload;
  345.     {$ENDIF}
  346.     // Use this method to add a string attribute with value AValue to the node.
  347.     procedure AttributeAdd(const AName, AValue: string); {$IFDEF D4UP}overload;{$ENDIF}
  348.     // Use this method to delete the attribute at Index in the list. Index must be
  349.     // equal or greater than 0, and smaller than AttributeCount. Using an index
  350.     // outside of that range has no effect.
  351.     procedure AttributeDelete(Index: integer);
  352.     // Switch position of the attributes at Index1 and Index2.
  353.     procedure AttributeExchange(Index1, Index2: integer);
  354.     // Use this method to find the index of an attribute with name AName.
  355.     function AttributeIndexByname(const AName: string): integer;
  356.     // Clear all attributes from the current node.
  357.     procedure AttributesClear; virtual;
  358.     // Use this method to read binary data from the node into Buffer with a length of Count.
  359.     procedure BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual;
  360.     // Use this method to write binary data in Buffer with a length of Count to the
  361.     // current node. The data will appear as text using either BinHex or Base64
  362.     // method) in the final XML document.
  363.     // Notice that NativeXml does only support up to 2Gb bytes of data per file,
  364.     // so do not use this option for huge files. The binary encoding method (converting
  365.     // binary data into text) can be selected using property BinaryEncoding.
  366.     // xbeBase64 is most efficient, but slightly slower. Always use identical methods
  367.     // for reading and writing.
  368.     procedure BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual;
  369.     // Returns the length of the data in the buffer, once it would be decoded by
  370.     // method xbeBinHex or xbeBase64. If BinaryEncoding is xbeSixBits, this function
  371.     // cannot be used. The length of the unencoded data is determined from the
  372.     // length of the encoded data. For xbeBinHex this is trivial (just half the
  373.     // length), for xbeBase64 this is more difficult (must use the padding characters)
  374.     function BufferLength: integer; virtual;
  375.     // Clear all child nodes and attributes, and the name and value of the current
  376.     // XML node. However, the node is not deleted. Call Delete instead for that.
  377.     procedure Clear; virtual;
  378.     // Find the first node which has name NodeName. Contrary to the NodeByName
  379.     // function, this function will search the whole subnode tree, using the
  380.     // DepthFirst method. It is possible to search for a full path too, e.g.
  381.     // FoundNode := MyNode.FindNode('/Root/SubNode1/SubNode2/ThisNode');
  382.     function FindNode(const NodeName: string): TXmlNode;
  383.     // Find all nodes which have name NodeName. Contrary to the NodesByName
  384.     // function, this function will search the whole subnode tree. If you use
  385.     // a TXmlNodeList for the AList parameter, you don't need to cast the list
  386.     // items to TXmlNode.
  387.     procedure FindNodes(const NodeName: string; const AList: TList);
  388.     // Use FromAnsiString to convert a normal ANSI string to a string for the node
  389.     // (name, value, attributes). If the TNativeXml property UtfEncoded is True,
  390.     // the ANSI characters are encoded into UTF8. Use this function if you work
  391.     // with special codebases (characters in the range $7F-$FF) and want to produce
  392.     // unicode or UTF8 XML documents.
  393.     function FromAnsiString(const s: string): string;
  394.     // Use FromWidestring to convert widestring to a string for the node (name, value,
  395.     // attributes). If the TNativeXml property UtfEncoded is True, all
  396.     // character codes higher than $FF are preserved.
  397.     function FromWidestring(const W: widestring): string;
  398.     // Use HasAttribute to determine if the node has an attribute with name AName.
  399.     function HasAttribute(const AName: string): boolean; virtual;
  400.     // This function returns the index of this node in the parent's node list.
  401.     // If Parent is not assigned, this function returns -1.
  402.     function IndexInParent: integer;
  403.     // This function returns True if the node has no subnodes and no attributes,
  404.     // and if the node Name and value are empty.
  405.     function IsClear: boolean; virtual;
  406.     // This function returns True if the node has no subnodes and no attributes,
  407.     // and if the node value is empty.
  408.     function IsEmpty: boolean; virtual;
  409.     function IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; MismatchNodes: TList {$IFDEF D4UP}= nil{$ENDIF}): boolean;
  410.     // Add the node ANode as a new subelement in the nodelist. The node will be
  411.     // added in position NodeCount (which will be returned).
  412.     function NodeAdd(ANode: TXmlNode): integer; virtual;
  413.     // This function returns a pointer to the first subnode that has an attribute with
  414.     // name AttribName and value AttribValue. If ShouldRecurse = True (default), the
  415.     // function works recursively, using the depthfirst method.
  416.     function NodeByAttributeValue(const NodeName, AttribName, AttribValue: string;
  417.       ShouldRecurse: boolean {$IFDEF D4UP}= True{$ENDIF}): TXmlNode;
  418.     // Return a pointer to the first subnode with this Elementype, or return nil
  419.     // if no subnode with that type is found.
  420.     function NodeByElementType(ElementType: TXmlElementType): TXmlNode;
  421.     // Return a pointer to the first subnode in the nodelist that has name AName.
  422.     // If no subnodes with AName are found, the function returns nil.
  423.     function NodeByName(const AName: string): TXmlNode; virtual;
  424.     // Delete the subnode at Index. The node will also be freed, so do not free the
  425.     // node in the application.
  426.     procedure NodeDelete(Index: integer); virtual;
  427.     // Switch position of the nodes at Index1 and Index2.
  428.     procedure NodeExchange(Index1, Index2: integer);
  429.     // Extract the node ANode from the subnode list. The node will no longer appear
  430.     // in the subnodes list, so the application is responsible for freeing ANode later.
  431.     function NodeExtract(ANode: TXmlNode): TXmlNode; virtual;
  432.     // This function returns a pointer to the first node with AName. If this node
  433.     // is not found, then it creates a new node with AName and returns its pointer.
  434.     function NodeFindOrCreate(const AName: string): TXmlNode; virtual;
  435.     // Find the index of the first subnode with name AName.
  436.     function NodeIndexByName(const AName: string): integer; virtual;
  437.     // Find the index of the first subnode with name AName that appears after or on
  438.     // the index AFrom. This function can be used in a loop to retrieve all nodes
  439.     // with a certain name, without using a helper list. See also NodesByName.
  440.     function NodeIndexByNameFrom(const AName: string; AFrom: integer): integer; virtual;
  441.     // Call NodeIndexOf to get the index for ANode in the Nodes array. The first
  442.     // node in the array has index 0, the second item has index 1, and so on. If
  443.     // a node is not in the list, NodeIndexOf returns -1.
  444.     function NodeIndexOf(ANode: TXmlNode): integer;
  445.     // Insert the node ANode at location Index in the list.
  446.     procedure NodeInsert(Index: integer; ANode: TXmlNode); virtual;
  447.     // Create a new node with AName, add it to the subnode list, and return a
  448.     // pointer to it.
  449.     function NodeNew(const AName: string): TXmlNode; virtual;
  450.     // Create a new node with AName, and insert it into the subnode list at location
  451.     // Index, and return a pointer to it.
  452.     function NodeNewAtIndex(Index: integer; const AName: string): TXmlNode; virtual;
  453.     // Call NodeRemove to remove a specific node from the Nodes array when its index
  454.     // is unknown. The value returned is the index of the item in the Nodes array
  455.     // before it was removed. After an item is removed, all the items that follow
  456.     // it are moved up in index position and the NodeCount is reduced by one.
  457.     function NodeRemove(ANode: TxmlNode): integer;
  458.     // Clear (and free) the complete list of subnodes.
  459.     procedure NodesClear; virtual;
  460.     // Use this procedure to retrieve all nodes that have name AName. Pointers to
  461.     // these nodes are added to the list in AList. AList must be initialized
  462.     // before calling this procedure. If you use a TXmlNodeList you don't need
  463.     // to cast the list items to TXmlNode.
  464.     procedure NodesByName(const AName: string; const AList: TList);
  465.     // Find the attribute with AName, and convert its value to a boolean. If the
  466.     // attribute is not found, or cannot be converted, the default ADefault will
  467.     // be returned.
  468.     function ReadAttributeBool(const AName: string; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}): boolean; virtual;
  469.     // Find the attribute with AName, and convert its value to an integer. If the
  470.     // attribute is not found, or cannot be converted, the default ADefault will
  471.     // be returned.
  472.     function ReadAttributeInteger(const AName: string; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}): integer; virtual;
  473.     // Find the attribute with AName, and convert its value to an int64. If the
  474.     // attribute is not found, or cannot be converted, the default ADefault will
  475.     // be returned.
  476.     function ReadAttributeInt64(const AName: string; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}): int64; virtual;
  477.     // Find the attribute with AName, and convert its value to a float. If the
  478.     // attribute is not found, or cannot be converted, the default ADefault will
  479.     // be returned.
  480.     function ReadAttributeFloat(const AName: string; ADefault: double {$IFDEF D4UP}= 0{$ENDIF}): double;
  481.     function ReadAttributeString(const AName: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}): string; virtual;
  482.     // Read the subnode with AName and convert it to a boolean value. If the
  483.     // subnode is not found, or cannot be converted, the boolean ADefault will
  484.     // be returned.
  485.     function ReadBool(const AName: string; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}): boolean; virtual;
  486.     {$IFDEF USEGRAPHICS}
  487.     // Read the properties Color and Style for the TBrush object ABrush from the
  488.     // subnode with AName.
  489.     procedure ReadBrush(const AName: string; ABrush: TBrush); virtual;
  490.     // Read the subnode with AName and convert its value to TColor. If the
  491.     // subnode is not found, or cannot be converted, ADefault will be returned.
  492.     function ReadColor(const AName: string; ADefault: TColor {$IFDEF D4UP}= clBlack{$ENDIF}): TColor; virtual;
  493.     // Read the properties Name, Color, Size and Style for the TFont object AFont
  494.     // from the subnode with AName.
  495.     procedure ReadFont(const AName: string; AFont: TFont); virtual;
  496.     // Read the properties Color, Mode, Style and Width for the TPen object APen
  497.     // from the subnode with AName.
  498.     procedure ReadPen(const AName: string; APen: TPen); virtual;
  499.     {$ENDIF}
  500.     // Read the subnode with AName and convert its value to TDateTime. If the
  501.     // subnode is not found, or cannot be converted, ADefault will be returned.
  502.     function ReadDateTime(const AName: string; ADefault: TDateTime {$IFDEF D4UP}= 0{$ENDIF}): TDateTime; virtual;
  503.     // Read the subnode with AName and convert its value to a double. If the
  504.     // subnode is not found, or cannot be converted, ADefault will be returned.
  505.     function ReadFloat(const AName: string; ADefault: double {$IFDEF D4UP}= 0.0{$ENDIF}): double; virtual;
  506.     {$IFDEF D4UP}
  507.     // Read the subnode with AName and convert its value to an int64. If the
  508.     // subnode is not found, or cannot be converted, ADefault will be returned.
  509.     function ReadInt64(const AName: string; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}): int64; virtual;
  510.     {$ENDIF}
  511.     // Read the subnode with AName and convert its value to an integer. If the
  512.     // subnode is not found, or cannot be converted, ADefault will be returned.
  513.     function ReadInteger(const AName: string; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}): integer; virtual;
  514.     // Read the subnode with AName and return its string value. If the subnode is
  515.     // not found, ADefault will be returned.
  516.     function ReadString(const AName: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}): string; virtual;
  517.     // Read the subnode with AName and return its widestring value. If the subnode is
  518.     // not found, ADefault will be returned.
  519.     function ReadWidestring(const AName: string; const ADefault: widestring {$IFDEF D4UP}= ''{$ENDIF}): widestring; virtual;
  520.     // Sort the child nodes of this node. Provide a custom node compare function in Compare,
  521.     // or attach an event handler to the parent documents' OnNodeCompare in order to
  522.     // provide custom sorting. If no compare function is given (nil) and OnNodeCompare
  523.     // is not implemented, SortChildNodes will simply sort the nodes by name (ascending,
  524.     // case insensitive). The Info pointer parameter can be used to pass any custom
  525.     // information to the compare function. Default value for Info is nil.
  526.     procedure SortChildNodes(Compare: TXMLNodeCompareFunction {$IFDEF D4UP}= nil{$ENDIF}; Info: TPointer {$IFDEF D4UP}= nil{$ENDIF});
  527.     // Use ToAnsiString to convert any string from the node (name, value, attributes)
  528.     // to a normal ANSI string. If the TNativeXml property UtfEncoded is True,
  529.     // you may loose characters with codes higher than $FF. To prevent this, use
  530.     // widestrings in your application and use ToWidestring instead.
  531.     function ToAnsiString(const s: string): string;
  532.     // Use ToWidestring to convert any string from the node (name, value, attributes)
  533.     // to a widestring. If the TNativeXml property UtfEncoded is True, all
  534.     // character codes higher than $FF are preserved.
  535.     function ToWidestring(const s: string): widestring;
  536.     // Convert the node's value to boolean and return the result. If this conversion
  537.     // fails, or no value is found, then the function returns ADefault.
  538.     function ValueAsBoolDef(ADefault: boolean): boolean; virtual;
  539.     // Convert the node's value to a TDateTime and return the result. If this conversion
  540.     // fails, or no value is found, then the function returns ADefault.
  541.     function ValueAsDateTimeDef(ADefault: TDateTime): TDateTime; virtual;
  542.     // Convert the node's value to a double and return the result. If this conversion
  543.     // fails, or no value is found, then the function returns ADefault.
  544.     function ValueAsFloatDef(ADefault: double): double; virtual;
  545.     // Convert the node's value to int64 and return the result. If this conversion
  546.     // fails, or no value is found, then the function returns ADefault.
  547.     function ValueAsInt64Def(ADefault: int64): int64; virtual;
  548.     // Convert the node's value to integer and return the result. If this conversion
  549.     // fails, or no value is found, then the function returns ADefault.
  550.     function ValueAsIntegerDef(ADefault: integer): integer; virtual;
  551.     // If the attribute with name AName exists, then set its value to the boolean
  552.     // AValue. If it does not exist, then create a new attribute AName with the
  553.     // boolean value converted to either "True" or "False". If ADefault = AValue, and
  554.     // WriteOnDefault = False, no attribute will be added.
  555.     procedure WriteAttributeBool(const AName: string; AValue: boolean; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}); virtual;
  556.     // If the attribute with name AName exists, then set its value to the integer
  557.     // AValue. If it does not exist, then create a new attribute AName with the
  558.     // integer value converted to a quoted string. If ADefault = AValue, and
  559.     // WriteOnDefault = False, no attribute will be added.
  560.     procedure WriteAttributeInteger(const AName: string; AValue: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
  561.     procedure WriteAttributeFloat(const AName: string; AValue: double; ADefault: double {$IFDEF D4UP} = 0{$ENDIF}); virtual;
  562.     // If the attribute with name AName exists, then set its value to the string
  563.     // AValue. If it does not exist, then create a new attribute AName with the
  564.     // value AValue. If ADefault = AValue, and WriteOnDefault = False, no attribute
  565.     // will be added.
  566.     procedure WriteAttributeString(const AName: string; const AValue: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}); virtual;
  567.     // Add or replace the subnode with AName and set its value to represent the boolean
  568.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  569.     procedure WriteBool(const AName: string; AValue: boolean; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}); virtual;
  570.     {$IFDEF USEGRAPHICS}
  571.     // Write properties Color and Style of the TBrush object ABrush to the subnode
  572.     // with AName. If AName does not exist, it will be created.
  573.     procedure WriteBrush(const AName: string; ABrush: TBrush); virtual;
  574.     // Add or replace the subnode with AName and set its value to represent the TColor
  575.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  576.     procedure WriteColor(const AName: string; AValue: TColor; ADefault: TColor {$IFDEF D4UP}= clBlack{$ENDIF}); virtual;
  577.     // Write properties Name, Color, Size and Style of the TFont object AFont to
  578.     // the subnode with AName. If AName does not exist, it will be created.
  579.     procedure WriteFont(const AName: string; AFont: TFont); virtual;
  580.     // Write properties Color, Mode, Style and Width of the TPen object APen to
  581.     // the subnode with AName. If AName does not exist, it will be created.
  582.     procedure WritePen(const AName: string; APen: TPen); virtual;
  583.     {$ENDIF}
  584.     // Add or replace the subnode with AName and set its value to represent the TDateTime
  585.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  586.     // The XML format used is compliant with W3C's specification of date and time.
  587.     procedure WriteDateTime(const AName: string; AValue: TDateTime; ADefault: TDateTime {$IFDEF D4UP}= 0{$ENDIF}); virtual;
  588.     // Add or replace the subnode with AName and set its value to represent the double
  589.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  590.     procedure WriteFloat(const AName: string; AValue: double; ADefault: double {$IFDEF D4UP}= 0.0{$ENDIF}); virtual;
  591.     // Add or replace the subnode with AName and set its value to represent the hexadecimal representation of
  592.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  593.     procedure WriteHex(const AName: string; AValue: integer; Digits: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
  594.     {$IFDEF D4UP}
  595.     // Add or replace the subnode with AName and set its value to represent the int64
  596.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  597.     procedure WriteInt64(const AName: string; AValue: int64; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}); virtual;
  598.     {$ENDIF}
  599.     // Add or replace the subnode with AName and set its value to represent the integer
  600.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  601.     procedure WriteInteger(const AName: string; AValue: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
  602.     // Add or replace the subnode with AName and set its value to represent the string
  603.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  604.     procedure WriteString(const AName, AValue: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}); virtual;
  605.     // Call WriteToString to save the XML node to a string. This method can be used to store
  606.     // individual nodes instead of the complete XML document.
  607.     function WriteToString: string; virtual;
  608.     // Add or replace the subnode with AName and set its value to represent the widestring
  609.     // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
  610.     procedure WriteWidestring(const AName: string; const AValue: widestring; const ADefault: widestring {$IFDEF D4UP}= ''{$ENDIF}); virtual;
  611.     // AttributeByName returns the attribute value for the attribute that has name AName.
  612.     // Set AttributeByName to add an attribute to the attribute list, or replace an
  613.     // existing one.
  614.     property AttributeByName[const AName: string]: string read GetAttributeByName write
  615.       SetAttributeByName;
  616.     // AttributeByNameWide returns the attribute value for the attribute that has name AName
  617.     // as widestring. Set AttributeByNameWide to add an attribute to the attribute list, or replace an
  618.     // existing one.
  619.     property AttributeByNameWide[const AName: string]: widestring read GetAttributeByNameWide write
  620.       SetAttributeByNameWide;
  621.     // Returns the number of attributes in the current node.
  622.     property AttributeCount: integer read GetAttributeCount;
  623.     // Read this property to get the name of the attribute at Index. Note that Index
  624.     // is zero-based: Index goes from 0 to AttributeCount - 1
  625.     property AttributeName[Index: integer]: string read GetAttributeName write SetAttributeName;
  626.     // Read this property to get the Attribute Name and Value pair at index Index.
  627.     // This is a string with Name and Value separated by a TAB character (#9).
  628.     property AttributePair[Index: integer]: string read GetAttributePair;
  629.     // Read this property to get the string value of the attribute at index Index.
  630.     // Write to it to set the string value.
  631.     property AttributeValue[Index: integer]: string read GetAttributeValue write SetAttributeValue;
  632.     // Read this property to get the widestring value of the attribute at index Index.
  633.     // Write to it to set the widestring value.
  634.     property AttributeValueAsWidestring[Index: integer]: widestring read GetAttributeValueAsWidestring write SetAttributeValueAsWidestring;
  635.     // Read this property to get the integer value of the attribute at index Index.
  636.     // If the value cannot be converted, 0 will be returned. Write to it to set the integer value.
  637.     property AttributeValueAsInteger[Index: integer]: integer read GetAttributeValueAsInteger write SetAttributeValueAsInteger;
  638.     // BinaryEncoding reflects the same value as the BinaryEncoding setting of the parent
  639.     // Document.
  640.     property BinaryEncoding: TBinaryEncodingType read GetBinaryEncoding write SetBinaryEncoding;
  641.     // Use BinaryString to add/extract binary data in an easy way to/from the node. Internally the
  642.     // data gets stored as Base64-encoded data. Do not use this method for normal textual
  643.     // information, it is better to use ValueAsString in that case (adds less overhead).
  644.     property BinaryString: string read GetBinaryString write SetBinaryString;
  645.     // This property returns the name and index and all predecessors with underscores
  646.     // to separate, in order to get a unique reference that can be used in filenames.
  647.     property CascadedName: string read GetCascadedName;
  648.     // Pointer to parent NativeXml document, or Nil if none.
  649.     property Document: TNativeXml read FDocument write FDocument;
  650.     // ElementType contains the type of element that this node holds.
  651.     property ElementType: TXmlElementType read FElementType write FElementType;
  652.     // Fullpath will return the complete path of the node from the root, e.g.
  653.     // /Root/SubNode1/SubNode2/ThisNode
  654.     property FullPath: string read GetFullPath;
  655.     // Read Name to get the name of the element, and write Name to set the name.
  656.     // This is the full name and may include a namespace. (Namespace:Name)
  657.     property Name: string read FName write SetName;
  658.     // Parent points to the parent node of the current XML node.
  659.     property Parent: TXmlNode read FParent write FParent;
  660.     // NodeCount is the number of child nodes that this node holds. In order to
  661.     // loop through all child nodes, use a construct like this:
  662.     // <CODE>
  663.     // with MyNode do
  664.     //   for i := 0 to NodeCount - 1 do
  665.     //     with Nodes[i] do
  666.     //     ..processing here
  667.     // </CODE>
  668.     property NodeCount: integer read GetNodeCount;
  669.     // Use Nodes to access the child nodes of the current XML node by index. Note
  670.     // that the list is zero-based, so Index is valid from 0 to NodeCount - 1.
  671.     property Nodes[Index: integer]: TXmlNode read GetNodes; default;
  672.     // Tag is an integer value the developer can use in any way. Tag does not get
  673.     // saved to the XML. Tag is often used to point to a GUI element (and is then
  674.     // cast to a pointer).
  675.     property Tag: integer read FTag write FTag;
  676.     // TotalNodeCount represents the total number of child nodes, and child nodes
  677.     // of child nodes etcetera of this particular node. Use the following to get
  678.     // the total number of nodes in the XML document:
  679.     // <CODE>
  680.     // Total := MyDoc.RootNodes.TotalNodeCount;
  681.     // </CODE>
  682.     property TotalNodeCount: integer read GetTotalNodeCount;
  683.     // Read TreeDepth to find out many nested levels there are for the current XML
  684.     // node. Root has a TreeDepth of zero.
  685.     property TreeDepth: integer read GetTreeDepth;
  686.     // ValueAsBool returns the node's value as boolean, or raises an
  687.     // exception if the value cannot be converted to boolean. Set ValueAsBool
  688.     // to convert a boolean to a string in the node's value field. See also
  689.     // function ValueAsBoolDef.
  690.     property ValueAsBool: boolean read GetValueAsBool write SetValueAsBool;
  691.     // ValueAsDateTime returns the node's value as TDateTime, or raises an
  692.     // exception if the value cannot be converted to TDateTime. Set ValueAsDateTime
  693.     // to convert a TDateTime to a string in the node's value field. See also
  694.     // function ValueAsDateTimeDef.
  695.     property ValueAsDateTime: TDateTime read GetValueAsDateTime write SetValueAsDateTime;
  696.     // ValueAsIn64 returns the node's value as int64, or raises an
  697.     // exception if the value cannot be converted to int64. Set ValueAsInt64
  698.     // to convert an int64 to a string in the node's value field. See also
  699.     // function ValueAsInt64Def.
  700.     property ValueAsInt64: int64 read GetValueAsInt64 write SetValueAsInt64;
  701.     // ValueAsInteger returns the node's value as integer, or raises an
  702.     // exception if the value cannot be converted to integer. Set ValueAsInteger
  703.     // to convert an integer to a string in the node's value field. See also
  704.     // function ValueAsIntegerDef.
  705.     property ValueAsInteger: integer read GetValueAsInteger write SetValueAsInteger;
  706.     // ValueAsFloat returns the node's value as float, or raises an
  707.     // exception if the value cannot be converted to float. Set ValueAsFloat
  708.     // to convert a float to a string in the node's value field. See also
  709.     // function ValueAsFloatDef.
  710.     property ValueAsFloat: double read GetValueAsFloat write SetValueAsFloat;
  711.     // ValueAsString returns the unescaped version of ValueDirect. All neccesary
  712.     // characters in ValueDirect must be escaped (e.g. "&" becomes "&amp;") but
  713.     // ValueAsString returns them in original format. Always use ValueAsString to
  714.     // set the text value of a node, to make sure all neccesary charaters are
  715.     // escaped.
  716.     property ValueAsString: string read GetValueAsString write SetValueAsString;
  717.     // ValueAsWidestring returns the unescaped version of ValueDirect as a widestring.
  718.     // Always use ValueAsWidestring to set the text value of a node, to make sure all
  719.     // neccesary charaters are escaped. Character codes bigger than $FF are preserved
  720.     // if the document is set to Utf8Encoded.
  721.     property ValueAsWidestring: widestring read GetValueAsWidestring write SetValueAsWidestring;
  722.     // ValueDirect is the exact text value as was parsed from the stream. If multiple
  723.     // text elements are encountered, they are added to ValueDirect with a CR to
  724.     // separate them.
  725.     property ValueDirect: string read FValue write FValue;
  726.     // WriteOnDefault reflects the same value as the WriteOnDefault setting of the parent
  727.     // Document.
  728.     property WriteOnDefault: boolean read GetWriteOnDefault;
  729.   end;
  730.   // TXmlNodeList is a utility TList descendant that can be used to work with selection
  731.   // lists. An example:
  732.   // <code>
  733.   // procedure FindAllZips(ANode: TXmlNode);
  734.   // var
  735.   //   i: integer;
  736.   //   AList: TXmlNodeList;
  737.   // begin
  738.   //   AList := TXmlNodeList.Create;
  739.   //   try
  740.   //     // Get a list of all nodes named 'ZIP'
  741.   //     ANode.NodesByName('ZIP', AList);
  742.   //     for i := 0 to AList.Count - 1 do
  743.   //       // Write the value of the node to output. Since AList[i] will be
  744.   //       // of type TXmlNode, we can directly access the Value property.
  745.   //       WriteLn(AList[i].Value);
  746.   //   finally
  747.   //     AList.Free;
  748.   //   end;
  749.   // end;
  750.   // </code>
  751.   TXmlNodeList = class(TList)
  752.   private
  753.     function GetItems(Index: Integer): TXmlNode;
  754.     procedure SetItems(Index: Integer; const Value: TXmlNode);
  755.   public
  756.     property Items[Index: Integer]: TXmlNode read GetItems write SetItems; default;
  757.   end;
  758.   // TNativeXml is the XML document holder. Create a TNativeXml and then use
  759.   // methods LoadFromFile, LoadFromStream or ReadFromString to load an XML document
  760.   // into memory. Or start from scratch and use Root.NodeNew to add nodes and
  761.   // eventually SaveToFile and SaveToStream to save the results as an XML document.
  762.   // Use property Xmlformat = xfReadable to ensure that indented (readable) output
  763.   // is produced.
  764.   TNativeXml = class(TPersistent)
  765.   private
  766.     FAbortParsing: boolean;         // Signal to abort the parsing process
  767.     FBinaryEncoding: TBinaryEncodingType; // xbeBinHex or xbeBase64
  768.     FCodecStream: TsdCodecStream;   // Temporary stream used to read encoded files
  769.     FDropCommentsOnParse: boolean;  // If true, comments are dropped (deleted) when parsing
  770.     FExternalEncoding: TStringEncodingType;
  771.     FFloatAllowScientific: boolean;
  772.     FFloatSignificantDigits: integer;
  773.     FParserWarnings: boolean;       // Show parser warnings for non-critical errors
  774.     FRootNodes: TXmlNode;           // Root nodes in the document (which contains one normal element that is the root)
  775.     FIndentString: string;          // The indent string used to indent content (default is two spaces)
  776.     FUseFullNodes: boolean;         // If true, nodes are never written in short notation.
  777.     FUtf8Encoded: boolean;          // If true, all internal strings are UTF-8 encoded
  778.     FWriteOnDefault: boolean;       // Set this option to "False" to only write values <> default value (default = true)
  779.     FXmlFormat: TXmlFormatType;     // xfReadable, xfCompact
  780.     FSortAttributes: boolean;       // If true, sort the String List that holds the parsed attributes.
  781.     FOnNodeCompare: TXmlNodeCompareEvent; // Compare two nodes
  782.     FOnNodeNew: TXmlNodeEvent;      // Called after a node is added
  783.     FOnNodeLoaded: TXmlNodeEvent;   // Called after a node is loaded completely
  784.     FOnProgress: TXmlProgressEvent; // Called after a node is loaded/saved, with the current position in the file
  785.     FOnUnicodeLoss: TNotifyEvent;   // This event is called when there is a warning for unicode conversion loss when reading unicode
  786.     procedure DoNodeNew(Node: TXmlNode);
  787.     procedure DoNodeLoaded(Node: TXmlNode);
  788.     procedure DoUnicodeLoss(Sender: TObject);
  789.     function GetCommentString: string;
  790.     procedure SetCommentString(const Value: string);
  791.     function GetEntityByName(AName: string): string;
  792.     function GetRoot: TXmlNode;
  793.     function GetEncodingString: string;
  794.     procedure SetEncodingString(const Value: string);
  795.     function GetVersionString: string;
  796.     procedure SetVersionString(const Value: string);
  797.     function GetStyleSheetNode: TXmlNode;
  798.   protected
  799.     procedure CopyFrom(Source: TNativeXml); virtual;
  800.     procedure DoProgress(Size: integer);
  801.     function LineFeed: string; virtual;
  802.     procedure ParseDTD(ANode: TXmlNode; S: TStream); virtual;
  803.     procedure ReadFromStream(S: TStream); virtual;
  804.     procedure WriteToStream(S: TStream); virtual;
  805.     procedure SetDefaults; virtual;
  806.   public
  807.     // Create a new NativeXml document which can then be used to read or write XML files.
  808.     // A document that is created with Create must later be freed using Free.
  809.     // Example:
  810.     // <Code>
  811.     // var
  812.     //   ADoc: TNativeXml;
  813.     // begin
  814.     //   ADoc := TNativeXml.Create;
  815.     //   try
  816.     //     ADoc.LoadFromFile('c:\temp\myxml.xml');
  817.     //     {do something with the document here}
  818.     //   finally
  819.     //     ADoc.Free;
  820.     //   end;
  821.     // end;
  822.     // </Code>
  823.     constructor Create; virtual;
  824.     // Use CreateName to Create a new Xml document that will automatically
  825.     // contain a root element with name ARootName.
  826.     constructor CreateName(const ARootName: string); virtual;
  827.     // Destroy will free all data in the TNativeXml object. This includes the
  828.     // root node and all subnodes under it. Do not call Destroy directly, call
  829.     // Free instead.
  830.     destructor Destroy; override;
  831.     // When calling Assign with a Source object that is a TNativeXml, will cause
  832.     // it to copy all data from Source.
  833.     procedure Assign(Source: TPersistent); override;
  834.     // Call Clear to remove all data from the object, and restore all defaults.
  835.     procedure Clear; virtual;
  836.     // Function IsEmpty returns true if the root is clear, or in other words, the
  837.     // root contains no value, no name, no subnodes and no attributes.
  838.     function IsEmpty: boolean; virtual;
  839.     // Load an XML document from the TStream object in Stream. The LoadFromStream
  840.     // procedure will raise an exception of type EFilerError when it encounters
  841.     // non-wellformed XML. This method can be used with any TStream descendant.
  842.     // See also LoadFromFile and ReadFromString.
  843.     procedure LoadFromStream(Stream: TStream); virtual;
  844.     // Call procedure LoadFromFile to load an XML document from the filename
  845.     // specified. See Create for an example. The LoadFromFile procedure will raise
  846.     // an exception of type EFilerError when it encounters non-wellformed XML.
  847.     procedure LoadFromFile(const FileName: string); virtual;
  848.     // Call procedure ReadFromString to load an XML document from the string AValue.
  849.     // The ReadFromString procedure will raise an exception of type EFilerError
  850.     // when it encounters non-wellformed XML.
  851.     procedure ReadFromString(const AValue: string); virtual;
  852.     // Call ResolveEntityReferences after the document has been loaded to resolve
  853.     // any present entity references (&Entity;). When an entity is found in the
  854.     // DTD, it will replace the entity reference. Whenever an entity contains
  855.     // XML markup, it will be parsed and become part of the document tree. Since
  856.     // calling ResolveEntityReferences is adding quite some extra overhead, it
  857.     // is not done automatically. If you want to do the entity replacement, a good
  858.     // moment to call ResolveEntityReferences is right after LoadFromFile.
  859.     procedure ResolveEntityReferences;
  860.     // Call SaveToStream to save the XML document to the Stream. Stream
  861.     // can be any TStream descendant. Set XmlFormat to xfReadable if you want
  862.     // the stream to contain indentations to make the XML more human-readable. This
  863.     // is not the default and also not compliant with the XML specification. See
  864.     // SaveToFile for information on how to save in special encoding.
  865.     procedure SaveToStream(Stream: TStream); virtual;
  866.     // Call SaveToFile to save the XML document to a file with FileName. If the
  867.     // filename exists, it will be overwritten without warning. If the file cannot
  868.     // be created, a standard I/O exception will be generated. Set XmlFormat to
  869.     // xfReadable if you want the file to contain indentations to make the XML
  870.     // more human-readable. This is not the default and also not compliant with
  871.     // the XML specification.<p>
  872.     // Saving to special encoding types can be achieved by setting two properties
  873.     // before saving:
  874.     // * ExternalEncoding
  875.     // * EncodingString
  876.     // ExternalEncoding can be se8bit (for plain ascii), seUtf8 (UTF-8), seUtf16LE
  877.     // (for unicode) or seUtf16BE (unicode big endian).<p> Do not forget to also
  878.     // set the EncodingString (e.g. "UTF-8" or "UTF-16") which matches with your
  879.     // ExternalEncoding.
  880.     procedure SaveToFile(const FileName: string); virtual;
  881.     // Call WriteToString to save the XML document to a string. Set XmlFormat to
  882.     // xfReadable if you want the string to contain indentations to make the XML
  883.     // more human-readable. This is not the default and also not compliant with
  884.     // the XML specification.
  885.     function WriteToString: string; virtual;
  886.     // Set AbortParsing to True if you use the OnNodeNew and OnNodeLoaded events in
  887.     // a SAX-like manner, and you want to abort the parsing process halfway. Example:
  888.     // <code>
  889.     // procedure MyForm.NativeXmlNodeLoaded(Sender: TObject; Node: TXmlNode);
  890.     // begin
  891.     //   if (Node.Name = 'LastNode') and (Sender is TNativeXml) then
  892.     //     TNativeXml(Sender).AbortParsing := True;
  893.     // end;
  894.     // </code>
  895.     property AbortParsing: boolean read FAbortParsing write FAbortParsing;
  896.     // Choose what kind of binary encoding will be used when calling TXmlNode.BufferRead
  897.     // and TXmlNode.BufferWrite. Default value is xbeBase64.
  898.     property BinaryEncoding: TBinaryEncodingType read FBinaryEncoding write FBinaryEncoding;
  899.     // A comment string above the root element <!--{comment}--> can be accessed with
  900.     // this property. Assign a comment to this property to add it to the XML document.
  901.     // Use property RootNodeList to add/insert/extract multiple comments.
  902.     property CommentString: string read GetCommentString write SetCommentString;
  903.     // Set DropCommentsOnParse if you're not interested in any comment nodes in your object
  904.     // model data. All comments encountered during parsing will simply be skipped and
  905.     // not added as a node with ElementType = xeComment (which is default). Note that
  906.     // when you set this option, you cannot later reconstruct an XML file with the comments
  907.     // back in place.
  908.     property DropCommentsOnParse: boolean read FDropCommentsOnParse write FDropCommentsOnParse;
  909.     // Encoding string (e.g. "UTF-8" or "UTF-16"). This encoding string is stored in
  910.     // the header.
  911.     // Example: In order to get this header:
  912.     // <?xml version="1.0" encoding="UTF-16" ?>
  913.     // enter this code:
  914.     // <CODE>MyXmlDocument.EncodingString := 'UTF-16';</CODE>
  915.     // When reading a file, EncodingString will contain the encoding used.
  916.     property EncodingString: string read GetEncodingString write SetEncodingString;
  917.     // Returns the value of the named entity in Name, where name should be stripped
  918.     // of the leading & and trailing ;. These entity values are parsed from the
  919.     // Doctype declaration (if any).
  920.     property EntityByName[AName: string]: string read GetEntityByName;
  921.     // ExternalEncoding defines in which format XML files are saved. Set ExternalEncoding
  922.     // to se8bit to save as plain text files, to seUtf8 to save as UTF8 files (with
  923.     // Byte Order Mark #EF BB FF) and to seUTF16LE to save as unicode (Byte Order
  924.     // Mark #FF FE). When reading an XML file, the value of ExternalEncoding will
  925.     // be set according to the byte order mark and/or encoding declaration found.
  926.     property ExternalEncoding: TStringEncodingType read FExternalEncoding write FExternalEncoding;
  927.     // When converting floating point values to strings (e.g. in WriteFloat),
  928.     // NativeXml will allow to output scientific notation in some cases, if the
  929.     // result is significantly shorter than normal output, but only if the value
  930.     // of FloatAllowScientific is True (default).
  931.     property FloatAllowScientific: boolean read FFloatAllowScientific write FFloatAllowScientific;
  932.     // When converting floating point values to strings (e.g. in WriteFloat),
  933.     // NativeXml will use this number of significant digits. The default is
  934.     // cDefaultFloatSignificantDigits, and set to 6.
  935.     property FloatSignificantDigits: integer read FFloatSignificantDigits write FFloatSignificantDigits;
  936.     // IndentString is the string used for indentations. By default, it is two
  937.     // spaces: '  '. Set IndentString to something else if you need to have
  938.     // specific indentation, or set it to an empty string to avoid indentation.
  939.     property IndentString: string read FIndentString write FIndentString;
  940.     // Root is the topmost element in the XML document. Access Root to read any
  941.     // child elements. When creating a new XML document, you can automatically
  942.     // include a Root node, by creating using CreateName.
  943.     property Root: TXmlNode read GetRoot;
  944.     // RootNodeList can be used to directly access the nodes in the root of the
  945.     // XML document. Usually this list consists of one declaration node followed
  946.     // by a normal node which is the Root. You can use this property to add or
  947.     // delete comments, stylesheets, dtd's etc.
  948.     property RootNodeList: TXmlNode read FRootNodes;
  949.     // Get the stylesheet node used for this XML document. If the node does not
  950.     // exist yet, it will be created (thus if you use this property, and don't
  951.     // set any of the attributes, an empty stylesheet node will be the result).
  952.     property StyleSheetNode: TXmlNode read GetStyleSheetNode;
  953.     // Set UseFullNodes to True before saving the XML document to ensure that all
  954.     // nodes are represented by <Node>...</Node> instead of the short version
  955.     // <Node/>. UseFullNodes is False by default.
  956.     property UseFullNodes: boolean read FUseFullNodes write FUseFullNodes;
  957.     // When Utf8Encoded is True, all strings inside the document represent
  958.     // UTF-8 encoded strings. Use function ToWidestring to convert strings to
  959.     // widestring (without loss) or ToAnsiString to convert to ANSI string
  960.     // (with loss). When Utf8Encoded is False (default), all strings represent
  961.     // normal ANSI strings. Set Utf8Encoded to True before adding info to the XML
  962.     // file to ensure internal strings are all UTF-8. Use methods FromWidestring,
  963.     // sdAnsiToUTF8 or sdUnicodeToUtf8 before setting any strings in that case.
  964.     property Utf8Encoded: boolean read FUtf8Encoded write FUtf8Encoded;
  965.     // After reading, this property contains the XML version (usually "1.0").
  966.     property VersionString: string read GetVersionString write SetVersionString;
  967.     // Set WriteOnDefault to False if you do not want to write default values to
  968.     // the XML document. This option can avoid creating huge documents with
  969.     // redundant info, and will speed up writing.
  970.     property WriteOnDefault: boolean read FWriteOnDefault write FWriteOnDefault;
  971.     // XmlFormat by default is set to xfCompact. This setting is compliant to the spec,
  972.     // and NativeXml will only generate XML files with #$0A as control character.
  973.     // By setting XmlFormat to xfReadable, you can generate easily readable XML
  974.     // files that contain indentation and carriage returns after each element.
  975.     property XmlFormat: TXmlFormatType read FXmlFormat write FXmlFormat;
  976.     // ParserWarnings by default is True. If True, the parser will raise an
  977.     // exception in cases where the XML document is not technically valid. If False,
  978.     // the parser will try to ignore non-critical warnings. Set ParserWarnings
  979.     // to False for some types of XML-based documents such as SOAP messages.
  980.     property ParserWarnings: boolean read FParserWarnings write FParserWarnings;
  981.     // SortAttributes by default is set to False.  Attributes will appear in the
  982.     // String list in the same order that they appear in the XML Document.  Setting
  983.     // this to true will cause the TStringList that holds the attributes to be sorted
  984.     // This can help speed lookup and allow you to iterate the list looking for
  985.     // specific attributes.
  986.     property SortAttributes: boolean read FSortAttributes write FSortAttributes;
  987.     // This event is called whenever a node's SortChildNodes method is called and
  988.     // no direct compare method is provided. Implement this event if you want to
  989.     // use object-event based methods for comparison of nodes.
  990.     property OnNodeCompare: TXmlNodeCompareEvent read FOnNodeCompare write FOnNodeCompare;
  991.     // This event is called whenever the parser has encountered a new node.
  992.     property OnNodeNew: TXmlNodeEvent read FOnNodeNew write FOnNodeNew;
  993.     // This event is called when the parser has finished parsing the node, and
  994.     // has created its complete contents in memory.
  995.     property OnNodeLoaded: TXmlNodeEvent read FOnNodeLoaded write FOnNodeLoaded;
  996.     // OnProgress is called during loading and saving of the XML document. The
  997.     // Size parameter contains the position in the stream. This event can be used
  998.     // to implement a progress indicator during loading and saving. The event is
  999.     // called after each node that is read or written.
  1000.     property OnProgress: TXmlProgressEvent read FOnProgress write FOnProgress;
  1001.     // This event is called if there is a warning for unicode conversion loss,
  1002.     // when reading from Unicode streams or files.
  1003.     property OnUnicodeLoss: TNotifyEvent read FOnUnicodeLoss write FOnUnicodeLoss;
  1004.   end;
  1005.   // This enumeration defines the conversion stream access mode.
  1006.   TsdStreamModeType = (
  1007.     umUnknown, // The stream access mode is not yet known
  1008.     umRead,    // UTF stream opened for reading
  1009.     umWrite    // UTF stream opened for writing
  1010.   );
  1011.   // TBigByteArray is an array of bytes like the standard TByteArray (windows
  1012.   // unit) but which can contain up to MaxInt bytes. This type helps avoiding
  1013.   // range check errors when working with buffers larger than 32768 bytes.
  1014.   TBigByteArray = array[0..MaxInt - 1] of byte;
  1015.   PBigByteArray = ^TBigByteArray;
  1016. {$IFDEF CLR}
  1017.   // not implemented
  1018.   TsdBufferedStream = class(TStream)
  1019.   private
  1020.     FStream: TStream;
  1021.     FOwned: Boolean;
  1022.   protected
  1023.     procedure SetSize(NewSize: Int64); override;
  1024.   public
  1025.     constructor Create(AStream: TStream; Owned: Boolean = False);
  1026.     destructor Destroy; override;
  1027.     function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  1028.     function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  1029.     function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  1030.   end;
  1031.   TsdBufferedReadStream = TsdBufferedStream;
  1032.   TsdBufferedWriteStream = TsdBufferedStream;
  1033. {$ELSE}
  1034.   // TsdBufferedReadStream is a buffered stream that takes another TStream
  1035.   // and reads only buffer-wise from it, and reads to the stream are first
  1036.   // done from the buffer. This stream type can only support reading.
  1037.   TsdBufferedReadStream = class(TStream)
  1038.   private
  1039.     FStream: TStream;
  1040.     FBuffer: PBigByteArray;
  1041.     FPage: integer;
  1042.     FBufPos: integer;
  1043.     FBufSize: integer;
  1044.     FPosition: longint;
  1045.     FOwned: boolean;
  1046.     FMustCheck: boolean;
  1047.   protected
  1048.     procedure CheckPosition;
  1049.   public
  1050.     // Create the buffered reader stream by passing the source stream in AStream,
  1051.     // this source stream must already be initialized. If Owned is set to True,
  1052.     // the source stream will be freed by TsdBufferedReadStream.
  1053.     constructor Create(AStream: TStream; Owned: boolean{$IFDEF D4UP} = False{$ENDIF});
  1054.     destructor Destroy; override;
  1055.     function Read(var Buffer; Count: Longint): Longint; override;
  1056.     function Write(const Buffer; Count: Longint): Longint; override;
  1057.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  1058.   end;
  1059.   // TsdBufferedWriteStream is a buffered stream that takes another TStream
  1060.   // and writes only buffer-wise to it, and writes to the stream are first
  1061.   // done to the buffer. This stream type can only support writing.
  1062.   TsdBufferedWriteStream = class(TStream)
  1063.   private
  1064.     FStream: TStream;
  1065.     FBuffer: PBigByteArray;
  1066.     FBufPos: integer;
  1067.     FPosition: longint;
  1068.     FOwned: boolean;
  1069.   protected
  1070.     procedure Flush;
  1071.   public
  1072.     // Create the buffered writer stream by passing the destination stream in AStream,
  1073.     // this destination stream must already be initialized. If Owned is set to True,
  1074.     // the destination stream will be freed by TsdBufferedWriteStream.
  1075.     constructor Create(AStream: TStream; Owned: boolean{$IFDEF D4UP} = False{$ENDIF});
  1076.     destructor Destroy; override;
  1077.     function Read(var Buffer; Count: Longint): Longint; override;
  1078.     function Write(const Buffer; Count: Longint): Longint; override;
  1079.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  1080.   end;
  1081. {$ENDIF}
  1082.   // TsdCodecStream is the base codec class for reading and writing encoded files.
  1083.   // See TsdAnsiStream and TsdUtf8Stream for more information.
  1084.   TsdCodecStream = class(TStream)
  1085.   private
  1086.     FBuffer: string;                // Buffer that holds temporary utf8 characters
  1087.     FBufferPos: integer;            // Current character in buffer
  1088.     FEncoding: TStringEncodingType; // Type of string encoding used for the external stream
  1089.     FMode: TsdStreamModeType;       // Access mode of this UTF stream, determined after first read/write
  1090.     FPosMin1: integer;              // Position for seek(-1)
  1091.     FPosMin2: integer;              // Position for seek(-2)
  1092.     FStream: TStream;               // Referenced stream
  1093.     FSwapByteOrder: boolean;
  1094.     FWarningUnicodeLoss: boolean;   // There was a warning for a unicode conversion loss
  1095.     FWriteBom: boolean;
  1096.     FOnUnicodeLoss: TNotifyEvent;   // This event is called if there is a warning for unicode conversion loss
  1097.   protected
  1098.     function ReadByte: byte; virtual;
  1099.     procedure StorePrevPositions; virtual;
  1100.     procedure WriteByte(const B: byte); virtual;
  1101.     procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); virtual;
  1102.     function InternalRead(var Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
  1103.     function InternalSeek(Offset: Longint; Origin: TSeekOrigin): Longint;
  1104.     function InternalWrite(const Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
  1105.     {$IFDEF CLR}
  1106.     procedure SetSize(NewSize: Int64); override;
  1107.     {$ENDIF}
  1108.   public
  1109.     // Call Create to create a new TsdCodectream based on an input or output stream
  1110.     // in AStream. After the first Read, the input streamtype will be determined,
  1111.     // and the Encoding property will be set accordingly. When using Write to
  1112.     // write data to the referenced stream, the Encoding property must be set prior
  1113.     // to this, indicating what kind of stream to produce.
  1114.     constructor Create(AStream: TStream); virtual;
  1115.     // Read Count bytes from the referenced stream, and put them in Buffer. The function
  1116.     // returns the actual number of bytes read. The codec stream can only read
  1117.     // one byte at the time!
  1118.     {$IFDEF CLR}
  1119.     function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  1120.     {$ELSE}
  1121.     function Read(var Buffer; Count: Longint): Longint; override;
  1122.     {$ENDIF}
  1123.     // Seek to a new position in the stream, with Origin as a reference. The codec
  1124.     // stream can not seek when writing, and when reading can only go back one
  1125.     // character, or return a position. Position returned is the position
  1126.     // in the referenced stream.
  1127.     {$IFDEF CLR}
  1128.     function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  1129.     {$ELSE}
  1130.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  1131.     {$ENDIF}
  1132.     // Write Count bytes from Buffer to the referenced stream, The function
  1133.     // returns the actual number of bytes written.
  1134.     {$IFDEF CLR}
  1135.     function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  1136.     {$ELSE}
  1137.     function Write(const Buffer; Count: Longint): Longint; override;
  1138.     {$ENDIF}
  1139.     // Set Encoding when writing to the preferred encoding of the output stream,
  1140.     // or read Encoding after reading the output stream to determine encoding type.
  1141.     property Encoding: TstringEncodingType read FEncoding write FEncoding;
  1142.     // Read this value after loading an XML file. It will be True if there was a
  1143.     // warning for a unicode conversion loss.
  1144.     property WarningUnicodeLoss: boolean read FWarningUnicodeLoss;
  1145.     // This event is called if there is a warning for unicode conversion loss.
  1146.     property OnUnicodeLoss: TNotifyEvent read FOnUnicodeLoss write FOnUnicodeLoss;
  1147.   end;
  1148.   // TsdAnsiStream is a conversion stream that will load ANSI, UTF8 or
  1149.   // Unicode files and convert them into ANSI only. The stream can
  1150.   // also save ANSI data as UTF8 or Unicode. When there is a conversion
  1151.   // problem, the conversion routine gives proper warnings through
  1152.   // WarningUnicodeLoss and OnUnicodeLoss.
  1153.   TsdAnsiStream = class(TsdCodecStream)
  1154.   protected
  1155.     function ReadByte: byte; override;
  1156.     procedure WriteByte(const B: byte); override;
  1157.     procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); override;
  1158.   end;
  1159.   // TsdUdf8tream is a conversion stream that will load ANSI, UTF8 or
  1160.   // Unicode files and convert them into UTF8 only. The stream can
  1161.   // also save UTF8 data as Ansi, UTF8 or Unicode.
  1162.   TsdUtf8Stream = class(TsdCodecStream)
  1163.   private
  1164.   protected
  1165.     function ReadByte: byte; override;
  1166.     procedure WriteByte(const B: byte); override;
  1167.     procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); override;
  1168.   end;
  1169.   // TsdSurplusReader is a simple class that can store a few surplus characters
  1170.   // and returns these first before reading from the underlying stream
  1171.   TsdSurplusReader = class
  1172.   private
  1173.     FStream: TStream;
  1174.     FSurplus: string;
  1175.   public
  1176.     constructor Create(AStream: TStream);
  1177.     property Surplus: string read FSurplus write FSurplus;
  1178.     function ReadChar(var Ch: char): integer;
  1179.     function ReadCharSkipBlanks(var Ch: char): boolean;
  1180.   end;
  1181.   // Simple string builder class that allocates string memory more effectively
  1182.   // to avoid repeated re-allocation
  1183.   TsdStringBuilder = class
  1184.   private
  1185.     FData: string;
  1186.     FCurrentIdx: integer;
  1187.     function GetData(Index: integer): Char;
  1188.     procedure Reallocate(RequiredLength: integer);
  1189.   public
  1190.     constructor Create;
  1191.     procedure Clear;
  1192.     procedure AddChar(Ch: Char);
  1193.     procedure AddString(var S: string);
  1194.     function StringCopy(AFirst, ALength: integer): string;
  1195.     function Value: string;
  1196.     property Length: integer read FCurrentIdx;
  1197.     property Data[Index: integer]: Char read GetData; default;
  1198.   end;
  1199. // string functions
  1200. // Escape all required characters in string AValue.
  1201. function EscapeString(const AValue: string): string;
  1202. // Replace all escaped characters in string AValue by their original. This includes
  1203. // character references using &#...; and &#x...;
  1204. function UnEscapeStringUTF8(const AValue: string): string;
  1205. // Replace all escaped characters in string AValue by their original. This includes
  1206. // character references using &#...; and &#x...;, however, character codes above
  1207. // 255 are not replaced.
  1208. function UnEscapeStringANSI(const AValue: string): string;
  1209. // Enclose the string AValue in quotes.
  1210. function QuoteString(const AValue: string): string;
  1211. // Remove the quotes from string AValue.
  1212. function UnQuoteString(const AValue: string): string;
  1213. // This function adds control characters Chars repeatedly after each Interval
  1214. // of characters to string Value.
  1215. function AddControlChars(const AValue: string; const Chars: string; Interval: integer): string;
  1216. // This function removes control characters from string AValue (Tab, CR, LF and Space)
  1217. function RemoveControlChars(const AValue: string): string;
  1218. // Convert the string ADate to a TDateTime according to the W3C date/time specification
  1219. // as found here: http://www.w3.org/TR/NOTE-datetime
  1220. // If there is a conversion error, an exception will be raised.
  1221. function sdDateTimeFromString(const ADate: string): TDateTime;
  1222. // Convert the string ADate to a TDateTime according to the W3C date/time specification
  1223. // as found here: http://www.w3.org/TR/NOTE-datetime
  1224. // If there is a conversion error, the default value ADefault is returned.
  1225. function sdDateTimeFromStringDefault(const ADate: string; ADefault: TDateTime): TDateTime;
  1226. // Convert the TDateTime ADate to a string according to the W3C date/time specification
  1227. // as found here: http://www.w3.org/TR/NOTE-datetime
  1228. function sdDateTimeToString(ADate: TDateTime): string;
  1229. // Convert a number to a string, using SignificantDigits to indicate the number of
  1230. // significant digits, and AllowScientific to allow for scientific notation if that
  1231. // results in much shorter notatoin.
  1232. function sdWriteNumber(Value: double; SignificantDigits: integer; AllowScientific: boolean): string;
  1233. // Conversion between Ansi, UTF8 and Unicode
  1234. // Convert a widestring to a UTF8 encoded string
  1235. function sdUnicodeToUtf8(const W: widestring): string;
  1236. // Convert a normal ansi string to a UTF8 encoded string
  1237. function sdAnsiToUtf8(const S: string): string;
  1238. // Convert a UTF8 encoded string to a widestring
  1239. function sdUtf8ToUnicode(const S: string): widestring;
  1240. // Convert a UTF8 encoded string to a normal ansi string
  1241. function sdUtf8ToAnsi(const S: string): string;
  1242. // parse functions
  1243. // Find SubString within string S, only process characters between Start and Close.
  1244. // First occurrance is reported in APos. If something is found, function returns True.
  1245. function FindString(const SubString: string; const S: string; Start, Close: integer; var APos: integer): boolean;
  1246. // Detect if the SubString matches the characters in S from position Start. S may be
  1247. // actually longer than SubString, only length(SubString) characters are checked.
  1248. function MatchString(const SubString: string; const S: string; Start: integer): boolean;
  1249. // Find all Name="Value" pairs in string AValue (from Start to Close - 1), and put
  1250. // the resulting attributes in stringlist Attributes. This stringlist must already
  1251. // be initialized when calling this function.
  1252. procedure ParseAttributes(const AValue: string; Start, Close: integer; Attributes: TStrings);
  1253. // Trim the string AValue between Start and Close - 1 (remove whitespaces at start
  1254. // and end), not by adapting the string but by adjusting the Start and Close indices.
  1255. // If the resulting string still has a length > 0, the function returns True.
  1256. function TrimPos(const AValue: string; var Start, Close: integer): boolean;
  1257. // Encoding/Decoding functions
  1258. // Encode binary data in Source as BASE64. The function returns the BASE64 encoded
  1259. // data as string, without any linebreaks.
  1260. function EncodeBase64(const Source: string): string;
  1261. // Decode BASE64 data in Source into binary data. The function returns the binary
  1262. // data as string. Use a TStringStream to convert this data to a stream. The Source
  1263. // string may contain linebreaks and control characters, these will be stripped.
  1264. function DecodeBase64(const Source: string): string;
  1265. // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
  1266. // data as string, without any linebreaks.
  1267. function EncodeBinHex(const Source: string): string;
  1268. // Decode BINHEX data in Source into binary data. The function returns the binary
  1269. // data as string. Use a TStringStream to convert this data to a stream. The Source
  1270. // string may contain linebreaks and control characters, these will be stripped.
  1271. function DecodeBinHex(const Source: string): string;
  1272. {$IFDEF D4UP}
  1273. resourcestring
  1274. {$ELSE}
  1275. const
  1276. {$ENDIF}
  1277.   sxeErrorCalcStreamLength       = 'Error while calculating streamlength';
  1278.   sxeMissingDataInBinaryStream   = 'Missing data in binary stream';
  1279.   sxeMissingElementName          = 'Missing element name';
  1280.   sxeMissingCloseTag             = 'Missing close tag in element %s';
  1281.   sxeMissingDataAfterGreaterThan = 'Missing data after "<" in element %s';
  1282.   sxeMissingLessThanInCloseTag   = 'Missing ">" in close tag of element %s';
  1283.   sxeIncorrectCloseTag           = 'Incorrect close tag in element %s';
  1284.   sxeIllegalCharInNodeName       = 'Illegal character in node name "%s"';
  1285.   sxeMoreThanOneRootElement      = 'More than one root element found in xml';
  1286.   sxeMoreThanOneDeclaration      = 'More than one xml declaration found in xml';
  1287.   sxeDeclarationMustBeFirstElem  = 'Xml declaration must be first element';
  1288.   sxeMoreThanOneDoctype          = 'More than one doctype declaration found in root';
  1289.   sxeDoctypeAfterRootElement     = 'Doctype declaration found after root element';
  1290.   sxeNoRootElement               = 'No root element found in xml';
  1291.   sxeIllegalElementType          = 'Illegal element type';
  1292.   sxeCDATAInRoot                 = 'No CDATA allowed in root';
  1293.   sxeRootElementNotDefined       = 'XML root element not defined.';
  1294.   sxeCodecStreamNotAssigned      = 'Encoding stream unassigned';
  1295.   sxeUnsupportedEncoding         = 'Unsupported string encoding';
  1296.   sxeCannotReadCodecForWriting   = 'Cannot read from a conversion stream opened for writing';
  1297.   sxeCannotWriteCodecForReading  = 'Cannot write to an UTF stream opened for reading';
  1298.   sxeCannotReadMultipeChar       = 'Cannot read multiple chars from conversion stream at once';
  1299.   sxeCannotPerformSeek           = 'Cannot perform seek on codec stream';
  1300.   sxeCannotSeekBeforeReadWrite   = 'Cannot seek before reading or writing in conversion stream';
  1301.   sxeCannotSeek                  = 'Cannot perform seek in conversion stream';
  1302.   sxeCannotWriteToOutputStream   = 'Cannot write to output stream';
  1303.   sxeXmlNodeNotAssigned          = 'XML Node is not assigned';
  1304.   sxeCannotConverToBool          = 'Cannot convert value to bool';
  1305.   sxeCannotConvertToFloat        = 'Cannot convert value to float';
  1306.   sxeSignificantDigitsOutOfRange = 'Significant digits out of range';
  1307. implementation
  1308. {$IFDEF TRIALXML}
  1309. uses
  1310.   Dialogs;
  1311. {$ENDIF}
  1312. type
  1313.   // Internal type
  1314.   TTagType = record
  1315.     FStart: string;
  1316.     FClose: string;
  1317.     FStyle: TXmlElementType;
  1318.   end;
  1319.   PByte = ^byte;
  1320.   TBomInfo = packed record
  1321.     BOM: array[0..3] of byte;
  1322.     Len: integer;
  1323.     Enc: TStringEncodingType;
  1324.     HasBOM: boolean;
  1325.   end;
  1326. const
  1327.   // Count of different escape characters
  1328.   cEscapeCount = 5;
  1329.   // These are characters that must be escaped. Note that "&" is first since
  1330.   // when another would be replaced first (eg ">" by "&lt;") this could
  1331.   // cause the new "&" in "&lt;" to be replaced by "&amp;";
  1332.   cEscapes: array[0..cEscapeCount - 1] of string =
  1333.     ('&', '<', '>', '''', '"');
  1334.   // These are the strings that replace the escape strings - in the same order
  1335.   cReplaces: array[0..cEscapeCount - 1] of string =
  1336.     ('&amp;', '&lt;', '&gt;', '&apos;', '&quot;');
  1337.   cQuoteChars: set of char = ['"', ''''];
  1338.   cControlChars: set of char = [#9, #10, #13, #32]; {Tab, LF, CR, Space}
  1339.   // Count of different XML tags
  1340.   cTagCount = 12;
  1341.   cTags: array[0..cTagCount - 1] of TTagType = (
  1342.     // The order is important here; the items are searched for in appearing order
  1343.     (FStart: '<![CDATA[';        FClose: ']]>'; FStyle: xeCData),
  1344.     (FStart: '<!DOCTYPE';        FClose: '>';   FStyle: xeDoctype),
  1345.     (FStart: '<!ELEMENT';        FClose: '>';   FStyle: xeElement),
  1346.     (FStart: '<!ATTLIST';        FClose: '>';   FStyle: xeAttList),
  1347.     (FStart: '<!ENTITY';         FClose: '>';   FStyle: xeEntity),
  1348.     (FStart: '<!NOTATION';       FClose: '>';   FStyle: xeNotation),
  1349.     (FStart: '<?xml-stylesheet'; FClose: '?>';  FStyle: xeStylesheet),
  1350.     (FStart: '<?xml';            FClose: '?>';  FStyle: xeDeclaration),
  1351.     (FStart: '<!--';             FClose: '-->'; FStyle: xeComment),
  1352.     (FStart: '<!';               FClose: '>';   FStyle: xeExclam),
  1353.     (FStart: '<?';               FClose: '?>';  FStyle: xeQuestion),
  1354.     (FStart: '<';                FClose: '>';   FStyle: xeNormal) );
  1355.     // direct tags are derived from Normal tags by checking for the />
  1356.   // These constant are used when generating hexchars from buffer data
  1357.   cHexChar:       array[0..15] of char = '0123456789ABCDEF';
  1358.   cHexCharLoCase: array[0..15] of char = '0123456789abcdef';
  1359.   // These characters are used when generating BASE64 chars from buffer data
  1360.   cBase64Char: array[0..63] of char =
  1361.     'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  1362.   cBase64PadChar: char = '=';
  1363.   // The amount of bytes to allocate with each increase of the value buffer
  1364.   cNodeValueBuf = 2048;
  1365.   // byte order marks for strings
  1366.   // Unicode text files should contain $FFFE as first character to identify such a file clearly. Depending on the system
  1367.   // where the file was created on this appears either in big endian or little endian style.
  1368.   const cBomInfoCount = 15;
  1369.   const cBomInfo: array[0..cBomInfoCount - 1] of TBomInfo =
  1370.   ( (BOM: ($00,$00,$FE,$FF); Len: 4; Enc: seUCS4BE;    HasBOM: true),
  1371.     (BOM: ($FF,$FE,$00,$00); Len: 4; Enc: seUCS4LE;    HasBOM: true),
  1372.     (BOM: ($00,$00,$FF,$FE); Len: 4; Enc: seUCS4_2143; HasBOM: true),
  1373.     (BOM: ($FE,$FF,$00,$00); Len: 4; Enc: seUCS4_3412; HasBOM: true),
  1374.     (BOM: ($FE,$FF,$00,$00); Len: 2; Enc: seUTF16BE;   HasBOM: true),
  1375.     (BOM: ($FF,$FE,$00,$00); Len: 2; Enc: seUTF16LE;   HasBOM: true),
  1376.     (BOM: ($EF,$BB,$BF,$00); Len: 3; Enc: seUTF8;      HasBOM: true),
  1377.     (BOM: ($00,$00,$00,$3C); Len: 4; Enc: seUCS4BE;    HasBOM: false),
  1378.     (BOM: ($3C,$00,$00,$00); Len: 4; Enc: seUCS4LE;    HasBOM: false),
  1379.     (BOM: ($00,$00,$3C,$00); Len: 4; Enc: seUCS4_2143; HasBOM: false),
  1380.     (BOM: ($00,$3C,$00,$00); Len: 4; Enc: seUCS4_3412; HasBOM: false),
  1381.     (BOM: ($00,$3C,$00,$3F); Len: 4; Enc: seUTF16BE;   HasBOM: false),
  1382.     (BOM: ($3C,$00,$3F,$00); Len: 4; Enc: seUTF16LE;   HasBOM: false),
  1383.     (BOM: ($3C,$3F,$78,$6D); Len: 4; Enc: se8Bit;      HasBOM: false),
  1384.     (BOM: ($4C,$6F,$A7,$94); Len: 4; Enc: seEBCDIC;    HasBOM: false)
  1385.   );
  1386. // .NET compatible stub for TBytes (array of byte) type
  1387. {$IFNDEF CLR}
  1388. type
  1389.   TBytes = TBigByteArray;
  1390. {$ENDIF}
  1391. // Delphi 3 and below stubs
  1392. {$IFNDEF D4UP}
  1393. function StringReplace(const S, OldPattern, NewPattern: string;
  1394.   Flags: TReplaceFlags): string;
  1395. var
  1396.   SearchStr, Patt, NewStr: string;
  1397.   Offset: Integer;
  1398. begin
  1399.   if rfIgnoreCase in Flags then
  1400.   begin
  1401.     SearchStr := UpperCase(S);
  1402.     Patt := UpperCase(OldPattern);
  1403.   end else
  1404.   begin
  1405.     SearchStr := S;
  1406.     Patt := OldPattern;
  1407.   end;
  1408.   NewStr := S;
  1409.   Result := '';
  1410.   while SearchStr <> '' do
  1411.   begin
  1412.     Offset := Pos(Patt, SearchStr);
  1413.     if Offset = 0 then
  1414.     begin
  1415.       Result := Result + NewStr;
  1416.       Break;
  1417.     end;
  1418.     Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
  1419.     NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
  1420.     if not (rfReplaceAll in Flags) then
  1421.     begin
  1422.       Result := Result + NewStr;
  1423.       Break;
  1424.     end;
  1425.     SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  1426.   end;
  1427. end;
  1428. function StrToInt64Def(const AValue: string; ADefault: int64): int64;
  1429. begin
  1430.   Result := StrToIntDef(AValue, ADefault);
  1431. end;
  1432. function StrToInt64(const AValue: string): int64;
  1433. begin
  1434.   Result := StrToInt(AValue);
  1435. end;
  1436. {$ENDIF}
  1437. // Delphi 4 stubs
  1438. {$IFNDEF D5UP}
  1439. function AnsiPos(const Substr, S: string): Integer;
  1440. begin
  1441.   Result := Pos(Substr, S);
  1442. end;
  1443. function AnsiQuotedStr(const S: string; Quote: Char): string;
  1444. var
  1445.   P, Src, Dest: PChar;
  1446.   AddCount: Integer;
  1447. begin
  1448.   AddCount := 0;
  1449.   P := StrScan(PChar(S), Quote);
  1450.   while P <> nil do begin
  1451.     Inc(P);
  1452.     Inc(AddCount);
  1453.     P := StrScan(P, Quote);
  1454.   end;
  1455.   if AddCount = 0 then begin
  1456.     Result := Quote + S + Quote;
  1457.     Exit;
  1458.   end;
  1459.   SetLength(Result, Length(S) + AddCount + 2);
  1460.   Dest := Pointer(Result);
  1461.   Dest^ := Quote;
  1462.   Inc(Dest);
  1463.   Src := Pointer(S);
  1464.   P := StrScan(Src, Quote);
  1465.   repeat
  1466.     Inc(P);
  1467.     Move(Src^, Dest^, P - Src);
  1468.     Inc(Dest, P - Src);
  1469.     Dest^ := Quote;
  1470.     Inc(Dest);
  1471.     Src := P;
  1472.     P := StrScan(Src, Quote);
  1473.   until P = nil;
  1474.   P := StrEnd(Src);
  1475.   Move(Src^, Dest^, P - Src);
  1476.   Inc(Dest, P - Src);
  1477.   Dest^ := Quote;
  1478. end;
  1479. function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
  1480. var
  1481.   P, Dest: PChar;
  1482.   DropCount: Integer;
  1483. begin
  1484.   Result := '';
  1485.   if (Src = nil) or (Src^ <> Quote) then Exit;
  1486.   Inc(Src);
  1487.   DropCount := 1;
  1488.   P := Src;
  1489.   Src := StrScan(Src, Quote);
  1490.   while Src <> nil do begin
  1491.     Inc(Src);
  1492.     if Src^ <> Quote then Break;
  1493.     Inc(Src);
  1494.     Inc(DropCount);
  1495.     Src := StrScan(Src, Quote);
  1496.   end;
  1497.   if Src = nil then Src := StrEnd(P);
  1498.   if ((Src - P) <= 1) then Exit;
  1499.   if DropCount = 1 then
  1500.     SetString(Result, P, Src - P - 1)
  1501.   else begin
  1502.     SetLength(Result, Src - P - DropCount);
  1503.     Dest := PChar(Result);
  1504.     Src := StrScan(P, Quote);
  1505.     while Src <> nil do begin
  1506.       Inc(Src);
  1507.       if Src^ <> Quote then Break;
  1508.       Move(P^, Dest^, Src - P);
  1509.       Inc(Dest, Src - P);
  1510.       Inc(Src);
  1511.       P := Src;
  1512.       Src := StrScan(Src, Quote);
  1513.     end;
  1514.     if Src = nil then Src := StrEnd(P);
  1515.     Move(P^, Dest^, Src - P - 1);
  1516.   end;
  1517. end;
  1518. procedure FreeAndNil(var Obj);
  1519. var
  1520.   P: TObject;
  1521. begin
  1522.   P := TObject(Obj);
  1523.   TObject(Obj) := nil;
  1524.   P.Free;
  1525. end;
  1526. {$ENDIF}
  1527. // .NET-compatible TStream.Write
  1528. function StreamWrite(Stream: TStream; const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: Longint): Longint;
  1529. begin
  1530. {$IFDEF CLR}
  1531.   Result := Stream.Write(Buffer, Offset, Count);
  1532. {$ELSE}
  1533.   Result := Stream.Write(TBytes(Buffer)[Offset], Count);
  1534. {$ENDIF}
  1535. end;
  1536. {$IFNDEF CLR}
  1537. // Delphi's implementation of TStringStream is severely flawed, it does a SetLength
  1538. // on each write, which slows down everything to a crawl. This implementation over-
  1539. // comes this issue.
  1540. type
  1541.   TsdStringStream = class(TMemoryStream)
  1542.   public
  1543.     constructor Create(const S: string);
  1544.     function DataString: string;
  1545.   end;
  1546. constructor TsdStringStream.Create(const S: string);
  1547. begin
  1548.   inherited Create;
  1549.   SetSize(length(S));
  1550.   if Size > 0 then begin
  1551.     Write(S[1], Size);
  1552.     Position := 0;
  1553.   end;
  1554. end;
  1555. function TsdStringStream.DataString: string;
  1556. begin
  1557.   SetLength(Result, Size);
  1558.   if Size > 0 then begin
  1559.     Position := 0;
  1560.     Read(Result[1], length(Result));
  1561.   end;
  1562. end;
  1563. {$ELSE}
  1564. // In .NET we use the standard TStringStream
  1565. type
  1566.   TsdStringStream = TStringStream;
  1567. {$ENDIF}
  1568. // Utility functions
  1569. function Min(A, B: integer): integer;
  1570. begin
  1571.   if A < B then Result := A else Result := B;
  1572. end;
  1573. function Max(A, B: integer): integer;
  1574. begin
  1575.   if A > B then Result := A else Result := B;
  1576. end;
  1577. function EscapeString(const AValue: string): string;
  1578. var
  1579.   i: integer;
  1580. begin
  1581.   Result := AValue;
  1582.   for i := 0 to cEscapeCount - 1 do
  1583.     Result := StringReplace(Result, cEscapes[i], cReplaces[i], [rfReplaceAll]);
  1584. end;
  1585. function UnEscapeStringUTF8(const AValue: string): string;
  1586. var
  1587.   SearchStr, Reference, Replace: string;
  1588.   i, Offset, Code: Integer;
  1589.   W: word;
  1590. begin
  1591.   SearchStr := AValue;
  1592.   Result := '';
  1593.   while SearchStr <> '' do begin
  1594.     // find '&'
  1595.     Offset := AnsiPos('&', SearchStr);
  1596.     if Offset = 0 then begin
  1597.       // Nothing found
  1598.       Result := Result + SearchStr;
  1599.       Break;
  1600.     end;
  1601.     Result := Result + Copy(SearchStr, 1, Offset - 1);
  1602.     SearchStr := Copy(SearchStr, Offset, MaxInt);
  1603.     // find next ';'
  1604.     Offset := AnsiPos(';', SearchStr);
  1605.     if Offset = 0 then begin
  1606.       // Error: encountered a '&' but not a ';'.. we will ignore, just return
  1607.       // the unmodified value
  1608.       Result := Result + SearchStr;
  1609.       Break;
  1610.     end;
  1611.     // Reference
  1612.     Reference := copy(SearchStr, 1, Offset);
  1613.     SearchStr := Copy(SearchStr, Offset + 1, MaxInt);
  1614.     Replace := Reference;
  1615.     // See if it is a character reference
  1616.     if copy(Reference, 1, 2) = '&#' then begin
  1617.       Reference := copy(Reference, 3, length(Reference) - 3);
  1618.       if length(Reference) > 0 then begin
  1619.         if lowercase(Reference[1]) = 'x' then
  1620.           // Hex notation
  1621.           Reference[1] := '$';
  1622.         Code := StrToIntDef(Reference, -1);
  1623.         if (Code >= 0) and (Code < $FFFF) then begin
  1624.           W := Code;
  1625.           {$IFDEF D5UP}
  1626.           Replace := sdUnicodeToUtf8(WideChar(W));
  1627.           {$ELSE}
  1628.           Replace := char(W and $FF);
  1629.           {$ENDIF}
  1630.         end;
  1631.       end;
  1632.     end else begin
  1633.       // Look up default escapes
  1634.       for i := 0 to cEscapeCount - 1 do
  1635.         if Reference = cReplaces[i] then begin
  1636.           // Replace
  1637.           Replace := cEscapes[i];
  1638.           Break;
  1639.         end;
  1640.     end;
  1641.     // New result
  1642.     Result := Result + Replace;
  1643.   end;
  1644. end;
  1645. function UnEscapeStringANSI(const AValue: string): string;
  1646. var
  1647.   SearchStr, Reference, Replace: string;
  1648.   i, Offset, Code: Integer;
  1649.   B: byte;
  1650. begin
  1651.   SearchStr := AValue;
  1652.   Result := '';
  1653.   while SearchStr <> '' do begin
  1654.     // find '&'
  1655.     Offset := AnsiPos('&', SearchStr);
  1656.     if Offset = 0 then begin
  1657.       // Nothing found
  1658.       Result := Result + SearchStr;
  1659.       Break;
  1660.     end;
  1661.     Result := Result + Copy(SearchStr, 1, Offset - 1);
  1662.     SearchStr := Copy(SearchStr, Offset, MaxInt);
  1663.     // find next ';'
  1664.     Offset := AnsiPos(';', SearchStr);
  1665.     if Offset = 0 then begin
  1666.       // Error: encountered a '&' but not a ';'.. we will ignore, just return
  1667.       // the unmodified value
  1668.       Result := Result + SearchStr;
  1669.       Break;
  1670.     end;
  1671.     // Reference
  1672.     Reference := copy(SearchStr, 1, Offset);
  1673.     SearchStr := Copy(SearchStr, Offset + 1, MaxInt);
  1674.     Replace := Reference;
  1675.     // See if it is a character reference
  1676.     if copy(Reference, 1, 2) = '&#' then begin
  1677.       Reference := copy(Reference, 3, length(Reference) - 3);
  1678.       if length(Reference) > 0 then begin
  1679.         if lowercase(Reference[1]) = 'x' then
  1680.           // Hex notation
  1681.           Reference[1] := '$';
  1682.         Code := StrToIntDef(Reference, -1);
  1683.         if (Code >= 0) and (Code < $FF) then begin
  1684.           B := Code;
  1685.           Replace := char(B);
  1686.         end;
  1687.       end;
  1688.     end else begin
  1689.       // Look up default escapes
  1690.       for i := 0 to cEscapeCount - 1 do
  1691.         if Reference = cReplaces[i] then begin
  1692.           // Replace
  1693.           Replace := cEscapes[i];
  1694.           Break;
  1695.         end;
  1696.     end;
  1697.     // New result
  1698.     Result := Result + Replace;
  1699.   end;
  1700. end;
  1701. function QuoteString(const AValue: string): string;
  1702. var
  1703.   AQuoteChar: char;
  1704. begin
  1705.   AQuoteChar := '"';
  1706.   if Pos('"', AValue) > 0 then
  1707.     AQuoteChar := '''';
  1708. {$IFDEF CLR}
  1709.   Result := QuotedStr(AValue, AQuoteChar);
  1710. {$ELSE}
  1711.   Result := AnsiQuotedStr(AValue, AQuoteChar);
  1712. {$ENDIF}
  1713. end;
  1714. function UnQuoteString(const AValue: string): string;
  1715. {$IFNDEF CLR}
  1716. var
  1717.   P: PChar;
  1718. {$ENDIF}
  1719. begin
  1720.   if Length(AValue) < 2 then begin
  1721.     Result := AValue;
  1722.     exit;
  1723.   end;
  1724.   if AValue[1] in cQuoteChars then begin
  1725.   {$IFDEF CLR}
  1726.     Result := DequotedStr(AValue, AValue[1]);
  1727.   {$ELSE}
  1728.     P := PChar(AValue);
  1729.     Result := AnsiExtractQuotedStr(P, AValue[1]);
  1730.   {$ENDIF}
  1731.   end else
  1732.     Result := AValue;
  1733. end;
  1734. function AddControlChars(const AValue: string; const Chars: string; Interval: integer): string;
  1735. // Insert Chars in AValue at each Interval chars
  1736. var
  1737.   i, j, ALength: integer;
  1738. // local
  1739. procedure InsertControlChars;
  1740. var
  1741.   k: integer;
  1742. begin
  1743.   for k := 1 to Length(Chars) do begin
  1744.     Result[j] := Chars[k];
  1745.     inc(j);
  1746.   end;
  1747. end;
  1748. // main
  1749. begin
  1750.   if (Length(Chars) = 0) or (Interval <= 0) then begin
  1751.     Result := AValue;
  1752.     exit;
  1753.   end;
  1754.   // Calculate length based on original length and total extra length for control chars
  1755.   ALength := Length(AValue) + ((Length(AValue) - 1) div Interval + 3) * Length(Chars);
  1756.   SetLength(Result, ALength);
  1757.   // Copy and insert
  1758.   j := 1;
  1759.   for i := 1 to Length(AValue) do begin
  1760.     if (i mod Interval) = 1 then begin
  1761.       // Insert control chars
  1762.       InsertControlChars;
  1763.     end;
  1764.     Result[j] := AValue[i];
  1765.     inc(j);
  1766.   end;
  1767.   InsertControlChars;
  1768.   // Adjust length
  1769.   dec(j);
  1770.   if ALength > j then
  1771.     SetLength(Result, j);
  1772. end;
  1773. function RemoveControlChars(const AValue: string): string;
  1774. // Remove control characters from string in AValue
  1775. var
  1776.   i, j: integer;
  1777. begin
  1778.   Setlength(Result, Length(AValue));
  1779.   i := 1;
  1780.   j := 1;
  1781.   while i <= Length(AValue) do
  1782.     if AValue[i] in cControlChars then
  1783.       inc(i)
  1784.     else begin
  1785.       Result[j] := AValue[i];
  1786.       inc(i);
  1787.       inc(j);
  1788.     end;
  1789.   // Adjust length
  1790.   if i <> j then
  1791.     SetLength(Result, j - 1);
  1792. end;
  1793. function FindString(const SubString: string; const S: string; Start, Close: integer; var APos: integer): boolean;
  1794. // Check if the Substring matches the string S in any position in interval Start to Close - 1
  1795. // and returns found positon in APos. Result = True if anything is found.
  1796. // Note: this funtion is case-insensitive
  1797. var
  1798.   CharIndex: integer;
  1799. begin
  1800.   Result := False;
  1801.   APos   := 0;
  1802.   for CharIndex := Start to Close - Length(SubString) do
  1803.     if MatchString(SubString, S, CharIndex) then begin
  1804.       APos := CharIndex;
  1805.       Result := True;
  1806.       exit;
  1807.     end;
  1808. end;
  1809. function MatchString(const SubString: string; const S: string; Start: integer): boolean;
  1810. // Check if the Substring matches the string S at position Start.
  1811. // Note: this funtion is case-insensitive
  1812. var
  1813.   CharIndex: integer;
  1814. begin
  1815.   Result := False;
  1816.   // Check range just in case
  1817.   if (Length(S) - Start + 1) < Length(Substring) then exit;
  1818.   CharIndex := 0;
  1819.   while CharIndex < Length(SubString) do
  1820.     if Upcase(SubString[CharIndex + 1]) = Upcase(S[Start + CharIndex]) then
  1821.       inc(CharIndex)
  1822.     else
  1823.       exit;
  1824.   // All chars were the same, so we succeeded
  1825.   Result := True;
  1826. end;
  1827. procedure ParseAttributes(const AValue: string; Start, Close: integer; Attributes: TStrings);
  1828. // Convert the attributes string AValue in [Start, Close - 1] to the attributes stringlist
  1829. var
  1830.   i: integer;
  1831.   InQuotes: boolean;
  1832.   AQuoteChar: char;
  1833. begin
  1834.   InQuotes := False;
  1835.   AQuoteChar := '"';
  1836.   if not assigned(Attributes) then exit;
  1837.   if not TrimPos(AValue, Start, Close) then exit;
  1838.   // Clear first
  1839.   Attributes.Clear;
  1840.   // Loop through characters
  1841.   for i := Start to Close - 1 do begin
  1842.     // In quotes?
  1843.     if InQuotes then begin
  1844.       if AValue[i] = AQuoteChar then
  1845.         InQuotes := False;
  1846.     end else begin
  1847.       if AValue[i] in cQuoteChars then begin
  1848.         InQuotes   := True;
  1849.         AQuoteChar := AValue[i];
  1850.       end;
  1851.     end;
  1852.     // Add attribute strings on each controlchar break
  1853.     if not InQuotes then
  1854.       if AValue[i] in cControlChars then begin
  1855.         if i > Start then
  1856.           Attributes.Add(copy(AValue, Start, i - Start));
  1857.         Start := i + 1;
  1858.       end;
  1859.   end;
  1860.   // Add last attribute string
  1861.   if Start < Close then
  1862.     Attributes.Add(copy(AValue, Start, Close - Start));
  1863.   // First-char "=" signs should append to previous
  1864.   for i := Attributes.Count - 1 downto 1 do
  1865.     if Attributes[i][1] = '=' then begin
  1866.       Attributes[i - 1] := Attributes[i - 1] + Attributes[i];
  1867.       Attributes.Delete(i);
  1868.     end;
  1869.   // First-char quotes should append to previous
  1870.   for i := Attributes.Count - 1 downto 1 do
  1871.     if (Attributes[i][1] in cQuoteChars) and (Pos('=', Attributes[i - 1]) > 0) then begin
  1872.       Attributes[i - 1] := Attributes[i - 1] + Attributes[i];
  1873.       Attributes.Delete(i);
  1874.     end;
  1875. end;
  1876. function TrimPos(const AValue: string; var Start, Close: integer): boolean;
  1877. // Trim the string in AValue in [Start, Close - 1] by adjusting Start and Close variables
  1878. begin
  1879.   // Checks
  1880.   Start := Max(1, Start);
  1881.   Close := Min(Length(AValue) + 1, Close);
  1882.   if Close <= Start then begin
  1883.     Result := False;
  1884.     exit;
  1885.   end;
  1886.   // Trim left
  1887.   while
  1888.     (Start < Close) and
  1889.     (AValue[Start] in cControlChars) do
  1890.     inc(Start);
  1891.   // Trim right
  1892.   while
  1893.     (Start < Close) and
  1894.     (AValue[Close - 1] in cControlChars) do
  1895.     dec(Close);
  1896.   // Do we have a string left?
  1897.   Result := Close > Start;
  1898. end;
  1899. procedure WriteStringToStream(S: TStream; const AString: string);
  1900. begin
  1901.   if Length(AString) > 0 then
  1902.   {$IFDEF CLR}
  1903.     S.Write(BytesOf(AString), Length(AString));
  1904.   {$ELSE}
  1905.     S.Write(AString[1], Length(AString));
  1906.   {$ENDIF}
  1907. end;
  1908. function ReadOpenTag(AReader: TsdSurplusReader): integer;
  1909. // Try to read the type of open tag from S
  1910. var
  1911.   AIndex, i: integer;
  1912.   Found: boolean;
  1913.   Ch: char;
  1914.   Candidates: array[0..cTagCount - 1] of boolean;
  1915.   Surplus: string;
  1916. begin
  1917.   Surplus := '';
  1918.   Result := cTagCount - 1;
  1919.   for i := 0 to cTagCount - 1 do Candidates[i] := True;
  1920.   AIndex := 1;
  1921.   repeat
  1922.     Found := False;
  1923.     inc(AIndex);
  1924.     if AReader.ReadChar(Ch) = 0 then
  1925.       exit;
  1926.     Surplus := Surplus + Ch;
  1927.     for i := cTagCount - 1 downto 0 do
  1928.       if Candidates[i] and (length(cTags[i].FStart) >= AIndex) then begin
  1929.         if cTags[i].FStart[AIndex] = Ch then begin
  1930.           Found := True;
  1931.           if length(cTags[i].FStart) = AIndex then
  1932.             Result := i;
  1933.         end else
  1934.           Candidates[i] := False;
  1935.       end;
  1936.   until Found = False;
  1937.   // The surplus string that we already read (everything after the tag)
  1938.   AReader.Surplus := copy(Surplus, length(cTags[Result].FStart), length(Surplus));
  1939. end;
  1940. function ReadStringFromStreamUntil(AReader: TsdSurplusReader; const ASearch: string;
  1941.   var AValue: string; SkipQuotes: boolean): boolean;
  1942. var
  1943.   AIndex, ValueIndex, SearchIndex: integer;
  1944.   LastSearchChar, Ch: char;
  1945.   InQuotes: boolean;
  1946.   QuoteChar: Char;
  1947.   SB: TsdStringBuilder;
  1948. begin
  1949.   Result := False;
  1950.   InQuotes := False;
  1951.   // Get last searchstring character
  1952.   AIndex := length(ASearch);
  1953.   if AIndex = 0 then exit;
  1954.   LastSearchChar := ASearch[AIndex];
  1955.   SB := TsdStringBuilder.Create;
  1956.   try
  1957.     QuoteChar := #0;
  1958.     repeat
  1959.       // Add characters to the value to be returned
  1960.       if AReader.ReadChar(Ch) = 0 then exit;
  1961.       SB.AddChar(Ch);
  1962.       // Do we skip quotes?
  1963.       if SkipQuotes then begin
  1964.         if InQuotes then begin
  1965.           if (Ch = QuoteChar) then
  1966.             InQuotes := false;
  1967.         end else begin
  1968.           if Ch in cQuoteChars then begin
  1969.              InQuotes := true;
  1970.              QuoteChar := Ch;
  1971.           end;
  1972.         end;
  1973.       end;
  1974.       // In quotes? If so, we don't check the end condition
  1975.       if not InQuotes then begin
  1976.         // Is the last char the same as the last char of the search string?
  1977.         if Ch = LastSearchChar then begin
  1978.           // Check to see if the whole search string is present
  1979.           ValueIndex  := SB.Length - 1;
  1980.           SearchIndex := length(ASearch) - 1;
  1981.           if ValueIndex < SearchIndex then continue;
  1982.           Result := True;
  1983.           while (SearchIndex > 0)and Result do begin
  1984.             Result := SB[ValueIndex] = ASearch[SearchIndex];
  1985.             dec(ValueIndex);
  1986.             dec(SearchIndex);
  1987.           end;
  1988.         end;
  1989.       end;
  1990.     until Result;
  1991.     // Use only the part before the search string
  1992.     AValue := SB.StringCopy(1, SB.Length - length(ASearch));
  1993.   finally
  1994.     SB.Free;
  1995.   end;
  1996. end;
  1997. function ReadStringFromStreamWithQuotes(S: TStream; const Terminator: string;
  1998.   var AValue: string): boolean;
  1999. var
  2000.   Ch, QuoteChar: char;
  2001.   InQuotes: boolean;
  2002.   SB: TsdStringBuilder;
  2003. begin
  2004.   SB := TsdStringBuilder.Create;
  2005.   try
  2006.     QuoteChar := #0;
  2007.     Result := False;
  2008.     InQuotes := False;
  2009.     repeat
  2010.       if S.Read(Ch, 1) = 0 then exit;
  2011.       if not InQuotes then begin
  2012.         if (Ch = '"') or (Ch = '''') then begin
  2013.           InQuotes := True;
  2014.           QuoteChar := Ch;
  2015.         end;
  2016.       end else begin
  2017.         if Ch = QuoteChar then
  2018.           InQuotes := False;
  2019.       end;
  2020.       if not InQuotes and (Ch = Terminator) then
  2021.         break;
  2022.       SB.AddChar(Ch);
  2023.     until False;
  2024.     AValue := SB.Value;
  2025.     Result := True;
  2026.   finally
  2027.     SB.Free;
  2028.   end;
  2029. end;
  2030. function sdDateTimeFromString(const ADate: string): TDateTime;
  2031. // Convert the string ADate to a TDateTime according to the W3C date/time specification
  2032. // as found here: http://www.w3.org/TR/NOTE-datetime
  2033. var
  2034.   AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word;
  2035. begin
  2036.   AYear  := StrToInt(copy(ADate, 1, 4));
  2037.   AMonth := StrToInt(copy(ADate, 6, 2));
  2038.   ADay   := StrToInt(copy(ADate, 9, 2));
  2039.   if Length(ADate) > 16 then begin // Suggestion JH
  2040.     AHour := StrToInt(copy(ADate, 12, 2));
  2041.     AMin  := StrToInt(copy(ADate, 15, 2));
  2042.     ASec  := StrToIntDef(copy(ADate, 18, 2), 0); // They might be omitted, so default to 0
  2043.     AMSec := StrToIntDef(copy(ADate, 21, 3), 0); // They might be omitted, so default to 0
  2044.   end else begin
  2045.     AHour := 0;
  2046.     AMin  := 0;
  2047.     ASec  := 0;
  2048.     AMSec := 0;
  2049.   end;
  2050.   Result :=
  2051.     EncodeDate(AYear, AMonth, ADay) +
  2052.     EncodeTime(AHour, AMin, ASec, AMSec);
  2053. end;
  2054. function sdDateTimeFromStringDefault(const ADate: string; ADefault: TDateTime): TDateTime;
  2055. // Convert the string ADate to a TDateTime according to the W3C date/time specification
  2056. // as found here: http://www.w3.org/TR/NOTE-datetime
  2057. // If there is a conversion error, the default value ADefault is returned.
  2058. begin
  2059.   try
  2060.     Result := sdDateTimeFromString(ADate);
  2061.   except
  2062.     Result := ADefault;
  2063.   end;
  2064. end;
  2065. function sdDateTimeToString(ADate: TDateTime): string;
  2066. // Convert the TDateTime ADate to a string according to the W3C date/time specification
  2067. // as found here: http://www.w3.org/TR/NOTE-datetime
  2068. var
  2069.   AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word;
  2070. begin
  2071.   DecodeDate(ADate, AYear, AMonth, ADay);
  2072.   DecodeTime(ADate, AHour, AMin, ASec, AMSec);
  2073.   if frac(ADate) = 0 then begin
  2074.     Result := Format('%.4d-%.2d-%.2d', [AYear, AMonth, ADay]);
  2075.   end else begin
  2076.     Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d.%.3dZ',
  2077.       [AYear, AMonth, ADay, AHour, AMin, ASec, AMSec]);
  2078.   end;
  2079. end;
  2080. function sdWriteNumber(Value: double; SignificantDigits: integer; AllowScientific: boolean): string;
  2081. const
  2082.   Limits: array[1..9] of integer =
  2083.     (10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000);
  2084. var
  2085.   Limit, Limitd, PointPos, IntVal, ScPower: integer;
  2086.   Body: string;
  2087. begin
  2088.   if (SignificantDigits < 1) or (SignificantDigits > 9) then
  2089.     raise Exception.Create(sxeSignificantDigitsOutOfRange);
  2090.   // Zero
  2091.   if Value = 0 then begin
  2092.     Result := '0';
  2093.     exit;
  2094.   end;
  2095.   // Sign
  2096.   if Value < 0 then begin
  2097.     Result := '-';
  2098.     Value := -Value;
  2099.   end else
  2100.     Result := '';
  2101.   // Determine point position
  2102.   Limit := Limits[SignificantDigits];
  2103.   Limitd := Limit div 10;
  2104.   PointPos := SignificantDigits;
  2105.   while Value < Limitd do begin
  2106.     Value := Value * 10;
  2107.     dec(PointPos);
  2108.   end;
  2109.   while Value >= Limit do begin
  2110.     Value := Value * 0.1;
  2111.     inc(PointPos);
  2112.   end;
  2113.   // Round
  2114.   IntVal := round(Value);
  2115.   // Strip off any zeros, these reduce significance count
  2116.   while (IntVal mod 10 = 0) and (PointPos < SignificantDigits) do begin
  2117.     dec(SignificantDigits);
  2118.     IntVal := IntVal div 10;
  2119.   end;
  2120.   // Check for scientific notation
  2121.   ScPower := 0;
  2122.   if AllowScientific and ((PointPos < -1) or (PointPos > SignificantDigits + 2)) then begin
  2123.     ScPower := PointPos - 1;
  2124.     dec(PointPos, ScPower);
  2125.   end;
  2126.   // Body
  2127.   Body := IntToStr(IntVal);
  2128.   while PointPos > SignificantDigits do begin
  2129.     Body := Body + '0';
  2130.     inc(SignificantDigits);
  2131.   end;
  2132.   while PointPos < 0 do begin
  2133.     Body := '0' + Body;
  2134.     inc(PointPos);
  2135.   end;
  2136.   if PointPos = 0 then
  2137.     Body := '.' + Body
  2138.   else if PointPos < SignificantDigits then
  2139.     Body := copy(Body, 1, PointPos) + '.' + copy(Body, PointPos + 1, SignificantDigits);
  2140.   // Final result
  2141.   if ScPower = 0 then
  2142.     Result := Result + Body
  2143.   else
  2144.     Result := Result + Body + 'E' + IntToStr(ScPower);
  2145. end;
  2146. {$IFDEF CLR}
  2147. function sdUnicodeToUtf8(const W: widestring): string;
  2148. begin
  2149.   Result := Encoding.UTF8.GetBytes(W);
  2150. end;
  2151. function sdUtf8ToUnicode(const S: string): widestring;
  2152. begin
  2153.   Result := Encoding.UTF8.GetString(BytesOf(S));
  2154. end;
  2155. function EncodeBase64Buf(const Buffer: TBytes; Count: Integer): string;
  2156. begin
  2157.   Result := Convert.ToBase64String(Buffer, 0, Count);
  2158. end;
  2159. function EncodeBase64(const Source: string): string;
  2160. begin
  2161.   Result := Convert.ToBase64String(BytesOf(Source));
  2162. end;
  2163. procedure DecodeBase64Buf(const Source: string; var Buffer: TBytes; Count: Integer);
  2164. var
  2165.   ADecoded: TBytes;
  2166. begin
  2167.   ADecoded := Convert.FromBase64String(Source);
  2168.   if Count > Length(ADecoded) then
  2169.     raise EFilerError.Create(sxeMissingDataInBinaryStream);
  2170.   SetLength(ADecoded, Count);
  2171.   Buffer := ADecoded;
  2172. end;
  2173. function DecodeBase64(const Source: string): string;
  2174. begin
  2175.   Result := AnsiString(Convert.FromBase64String(Source));
  2176. end;
  2177. {$ELSE}
  2178. function PtrUnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
  2179. var
  2180.   i, count: Cardinal;
  2181.   c: Cardinal;
  2182. begin
  2183.   Result := 0;
  2184.   if not assigned(Source) or not assigned(Dest) then exit;
  2185.   count := 0;
  2186.   i := 0;
  2187.   while (i < SourceChars) and (count < MaxDestBytes) do begin
  2188.     c := Cardinal(Source[i]);
  2189.     Inc(i);
  2190.     if c <= $7F then begin
  2191.       Dest[count] := Char(c);
  2192.       Inc(count);
  2193.     end else
  2194.       if c > $7FF then begin
  2195.         if count + 3 > MaxDestBytes then
  2196.           break;
  2197.         Dest[count] := Char($E0 or (c shr 12));
  2198.         Dest[count+1] := Char($80 or ((c shr 6) and $3F));
  2199.         Dest[count+2] := Char($80 or (c and $3F));
  2200.         Inc(count,3);
  2201.       end else begin //  $7F < Source[i] <= $7FF
  2202.         if count + 2 > MaxDestBytes then
  2203.           break;
  2204.         Dest[count] := Char($C0 or (c shr 6));
  2205.         Dest[count+1] := Char($80 or (c and $3F));
  2206.         Inc(count,2);
  2207.       end;
  2208.   end;
  2209.   if count >= MaxDestBytes then
  2210.     count := MaxDestBytes-1;
  2211.   Dest[count] := #0;
  2212.   Result := count + 1;  // convert zero based index to byte count
  2213. end;
  2214. function PtrUtf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar;
  2215.   SourceBytes: Cardinal): Cardinal;
  2216. var
  2217.   i, count: Cardinal;
  2218.   c: Byte;
  2219.   wc: Cardinal;
  2220. begin
  2221.   if not assigned(Dest) or not assigned(Source) then begin
  2222.     Result := 0;
  2223.     Exit;
  2224.   end;
  2225.   Result := Cardinal(-1);
  2226.   count := 0;
  2227.   i := 0;
  2228.   while (i < SourceBytes) and (count < MaxDestChars) do begin
  2229.     wc := Cardinal(Source[i]);
  2230.     Inc(i);
  2231.     if (wc and $80) <> 0 then begin
  2232.       if i >= SourceBytes then
  2233.         // incomplete multibyte char
  2234.         Exit;
  2235.       wc := wc and $3F;
  2236.       if (wc and $20) <> 0 then begin
  2237.         c := Byte(Source[i]);
  2238.         Inc(i);
  2239.         if (c and $C0) <> $80 then
  2240.           // malformed trail byte or out of range char
  2241.           Exit;
  2242.         if i >= SourceBytes then
  2243.           // incomplete multibyte char
  2244.           Exit;
  2245.         wc := (wc shl 6) or (c and $3F);
  2246.       end;
  2247.       c := Byte(Source[i]);
  2248.       Inc(i);
  2249.       if (c and $C0) <> $80 then
  2250.         // malformed trail byte
  2251.         Exit;
  2252.       Dest[count] := WideChar((wc shl 6) or (c and $3F));
  2253.     end else
  2254.       Dest[count] := WideChar(wc);
  2255.     Inc(count);
  2256.   end;
  2257.   if count >= MaxDestChars then
  2258.     count := MaxDestChars-1;
  2259.   Dest[count] := #0;
  2260.   Result := count + 1;
  2261. end;
  2262. function sdUnicodeToUtf8(const W: widestring): string;
  2263. var
  2264.   L: integer;
  2265.   Temp: string;
  2266. begin
  2267.   Result := '';
  2268.   if W = '' then Exit;
  2269.   SetLength(Temp, Length(W) * 3); // SetLength includes space for null terminator
  2270.   L := PtrUnicodeToUtf8(PChar(Temp), Length(Temp) + 1, PWideChar(W), Length(W));
  2271.   if L > 0 then
  2272.     SetLength(Temp, L - 1)
  2273.   else
  2274.     Temp := '';
  2275.   Result := Temp;
  2276. end;
  2277. function sdUtf8ToUnicode(const S: string): widestring;
  2278. var
  2279.   L: Integer;
  2280.   Temp: WideString;
  2281. begin
  2282.   Result := '';
  2283.   if S = '' then Exit;
  2284.   SetLength(Temp, Length(S));
  2285.   L := PtrUtf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
  2286.   if L > 0 then
  2287.     SetLength(Temp, L-1)
  2288.   else
  2289.     Temp := '';
  2290.   Result := Temp;
  2291. end;
  2292. function EncodeBase64Buf(const Buffer; Count: Integer): string;
  2293. var
  2294.   i, j: integer;
  2295.   ACore: integer;
  2296.   ALong: cardinal;
  2297.   S: PByte;
  2298. begin
  2299.   // Make sure ASize is always a multiple of 3, and this multiple
  2300.   // gets saved as 4 characters
  2301.   ACore := (Count + 2) div 3;
  2302.   // Set the length of the string that stores encoded characters
  2303.   SetLength(Result, ACore * 4);
  2304.   S := @Buffer;
  2305.   // Do the loop ACore times
  2306.   for i := 0 to ACore - 1 do begin
  2307.     ALong := 0;
  2308.     for j := 0 to 2 do begin
  2309.       ALong := ALong shl 8 + S^;
  2310.       inc(S);
  2311.     end;
  2312.     for j := 0 to 3 do begin
  2313.       Result[i * 4 + 4 - j] := cBase64Char[ALong and $3F];
  2314.       ALong := ALong shr 6;
  2315.     end;
  2316.   end;
  2317.   // For comformity to Base64, we must pad the data instead of zero out
  2318.   // if the size is not an exact multiple of 3
  2319.   case ACore * 3 - Count of
  2320.   0:;// nothing to do
  2321.   1: // pad one byte
  2322.     Result[ACore * 4] := cBase64PadChar;
  2323.   2: // pad two bytes
  2324.     begin
  2325.       Result[ACore * 4    ] := cBase64PadChar;
  2326.       Result[ACore * 4 - 1] := cBase64PadChar;
  2327.     end;
  2328.   end;//case
  2329. end;
  2330. function EncodeBase64(const Source: string): string;
  2331. // Encode binary data in Source as BASE64. The function returns the BASE64 encoded
  2332. // data as string, without any linebreaks.
  2333. begin
  2334.   if length(Source) > 0 then
  2335.     Result := EncodeBase64Buf(Source[1], length(Source))
  2336.   else
  2337.     Result := '';
  2338. end;
  2339. procedure DecodeBase64Buf(var Source: string; var Buffer; Count: Integer);
  2340. var
  2341.   i, j: integer;
  2342.   APos, ACore: integer;
  2343.   ALong: cardinal;
  2344.   D: PByte;
  2345.   Map: array[Char] of byte;
  2346. begin
  2347.   // Core * 4 is the number of chars to read - check length
  2348.   ACore := Length(Source) div 4;
  2349.   if Count > ACore * 3 then
  2350.     raise EFilerError.Create(sxeMissingDataInBinaryStream);
  2351.   // Prepare map
  2352.   for i := 0 to 63 do
  2353.     Map[cBase64Char[i]] := i;
  2354.   D := @Buffer;
  2355.   // Check for final padding, and replace with "zeros". There can be
  2356.   // at max two pad chars ('=')
  2357.   APos := length(Source);
  2358.   if (APos > 0) and (Source[APos] = cBase64PadChar) then begin
  2359.     Source[APos] := cBase64Char[0];
  2360.     dec(APos);
  2361.     if (APos > 0) and (Source[APos] = cBase64PadChar) then
  2362.       Source[APos] := cBase64Char[0];
  2363.   end;
  2364.   // Do this ACore times
  2365.   for i := 0 to ACore - 1 do begin
  2366.     ALong := 0;
  2367.     // Unroll the characters
  2368.     for j := 0 to 3 do
  2369.       ALong := ALong shl 6 + Map[Source[i * 4 + j + 1]];
  2370.     // and unroll the bytes
  2371.     for j := 2 downto 0 do begin
  2372.       // Check overshoot
  2373.       if integer(D) - integer(@Buffer) >= Count then
  2374.         exit;
  2375.       D^ := ALong shr (j * 8) and $FF;
  2376.       inc(D);
  2377.     end;
  2378.   end;
  2379. end;
  2380. function DecodeBase64(const Source: string): string;
  2381. // Decode BASE64 data in Source into binary data. The function returns the binary
  2382. // data as string. Use a TStringStream to convert this data to a stream.
  2383. var
  2384.   AData: string;
  2385.   ASize, APos: integer;
  2386. begin
  2387.   AData := RemoveControlChars(Source);
  2388.   // Determine length of data
  2389.   ASize := length(AData) div 4;
  2390.   if ASize * 4 <> length(AData) then
  2391.     raise EFilerError.Create(sxeErrorCalcStreamLength);
  2392.   ASize := ASize * 3;
  2393.   // Check padding chars
  2394.   APos := length(AData);
  2395.   if (APos > 0) and (AData[APos] = cBase64PadChar) then begin
  2396.     dec(APos);
  2397.     dec(ASize);
  2398.     if (APos > 0) and (AData[APos] = cBase64PadChar) then
  2399.       dec(ASize);
  2400.   end;
  2401.   Setlength(Result, ASize);
  2402.   // Decode
  2403.   if ASize > 0 then
  2404.     DecodeBase64Buf(AData, Result[1], ASize);
  2405. end;
  2406. {$ENDIF}
  2407. function sdAnsiToUtf8(const S: string): string;
  2408. begin
  2409.   Result := sdUnicodeToUtf8(S);
  2410. end;
  2411. function sdUtf8ToAnsi(const S: string): string;
  2412. begin
  2413.   Result := sdUtf8ToUnicode(S);
  2414. end;
  2415. function EncodeBinHexBuf(const Source; Count: Integer): string;
  2416. // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
  2417. // data as string, without any linebreaks.
  2418. var
  2419. {$IFDEF CLR}
  2420.   Text: TBytes;
  2421. {$ELSE}
  2422.   Text: string;
  2423. {$ENDIF}
  2424. begin
  2425.   SetLength(Text, Count * 2);
  2426. {$IFDEF CLR}
  2427.   BinToHex(TBytes(Source), 0, Text, 0, Count);
  2428. {$ELSE}
  2429. {$IFDEF D4UP}
  2430.   BinToHex(PChar(@Source), PChar(Text), Count);
  2431. {$ELSE}
  2432.   raise Exception.Create(sxeUnsupportedEncoding);
  2433. {$ENDIF}
  2434. {$ENDIF}
  2435.   Result := Text;
  2436. end;
  2437. function EncodeBinHex(const Source: string): string;
  2438. // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
  2439. // data as string, without any linebreaks.
  2440. var
  2441. {$IFDEF CLR}
  2442.   Text: TBytes;
  2443. {$ELSE}
  2444.   Text: string;
  2445. {$ENDIF}
  2446. begin
  2447.   SetLength(Text, Length(Source) * 2);
  2448. {$IFDEF CLR}
  2449.   BinToHex(BytesOf(Source), 0, Text, 0, Length(Source));
  2450. {$ELSE}
  2451. {$IFDEF D4UP}
  2452.   BinToHex(PChar(Source), PChar(Text), Length(Source));
  2453. {$ELSE}
  2454.   raise Exception.Create(sxeUnsupportedEncoding);
  2455. {$ENDIF}
  2456. {$ENDIF}
  2457.   Result := Text;
  2458. end;
  2459. procedure DecodeBinHexBuf(const Source: string; var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
  2460. // Decode BINHEX data in Source into binary data.
  2461. begin
  2462.   if Length(Source) div 2 < Count then
  2463.     raise EFilerError.Create(sxeMissingDataInBinaryStream);
  2464. {$IFDEF CLR}
  2465.   HexToBin(BytesOf(Source), 0, Buffer, 0, Count);
  2466. {$ELSE}
  2467. {$IFDEF D4UP}
  2468.   HexToBin(PChar(Source), PChar(@Buffer), Count);
  2469. {$ELSE}
  2470.   raise Exception.Create(sxeUnsupportedEncoding);
  2471. {$ENDIF}
  2472. {$ENDIF}
  2473. end;
  2474. function DecodeBinHex(const Source: string): string;
  2475. // Decode BINHEX data in Source into binary data. The function returns the binary
  2476. // data as string. Use a TStringStream to convert this data to a stream.
  2477. var
  2478.   AData: string;
  2479.   ASize: integer;
  2480. {$IFDEF CLR}
  2481.   Buffer: TBytes;
  2482. {$ELSE}
  2483.   Buffer: string;
  2484. {$ENDIF}
  2485. begin
  2486.   AData := RemoveControlChars(Source);
  2487.   // Determine length of data
  2488.   ASize := length(AData) div 2;
  2489.   if ASize * 2 <> length(AData) then
  2490.     raise EFilerError.Create(sxeErrorCalcStreamLength);
  2491.   SetLength(Buffer, ASize);
  2492. {$IFDEF CLR}
  2493.   HexToBin(BytesOf(AData), 0, Buffer, 0, ASize);
  2494. {$ELSE}
  2495. {$IFDEF D4UP}
  2496.   HexToBin(PChar(AData), PChar(Buffer), ASize);
  2497. {$ELSE}
  2498.   raise Exception.Create(sxeUnsupportedEncoding);
  2499. {$ENDIF}
  2500. {$ENDIF}
  2501.   Result := Buffer;
  2502. end;
  2503. function sdStringToBool(const AValue: string): boolean;
  2504. var
  2505.   Ch: Char;
  2506. begin
  2507.   if Length(AValue) > 0 then begin
  2508.     Ch := UpCase(AValue[1]);
  2509.     if Ch in ['T', 'Y'] then begin
  2510.       Result := True;
  2511.       exit;
  2512.     end;
  2513.     if Ch in ['F', 'N'] then begin
  2514.       Result := False;
  2515.       exit;
  2516.     end;
  2517.   end;
  2518.   raise Exception.Create(sxeCannotConverToBool);
  2519. end;
  2520. function sdStringFromBool(ABool: boolean): string;
  2521. const
  2522.   cBoolValues: array[boolean] of string = ('False', 'True');
  2523. begin
  2524.   Result := cBoolValues[ABool];
  2525. end;
  2526. { TXmlNode }
  2527. procedure TXmlNode.Assign(Source: TPersistent);
  2528. var
  2529.   i: integer;
  2530.   ANode: TXmlNode;
  2531. begin
  2532.   if Source is TXmlNode then begin
  2533.     // Clear first
  2534.     Clear;
  2535.     // Properties
  2536.     FElementType := TXmlNode(Source).FElementType;
  2537.     FName := TXmlNode(Source).FName;
  2538.     FTag := TXmlNode(Source).FTag;
  2539.     FValue := TXmlNode(Source).FValue;
  2540.     // Attributes
  2541.     if assigned(TXmlNode(Source).FAttributes) then begin
  2542.       CheckCreateAttributesList;
  2543.       FAttributes.Assign(TXmlNode(Source).FAttributes);
  2544.     end;
  2545.     // Nodes
  2546.     for i := 0 to TXmlNode(Source).NodeCount - 1 do begin
  2547.       ANode := NodeNew('');
  2548.       ANode.Assign(TXmlNode(Source).Nodes[i]);
  2549.     end;
  2550.   end else if Source is TNativeXml then begin
  2551.     Assign(TNativeXml(Source).FRootNodes);
  2552.   end else
  2553.     inherited;
  2554. end;
  2555. procedure TXmlNode.AttributeAdd(const AName, AValue: string);
  2556. var
  2557.   Attr: string;
  2558. begin
  2559.   Attr := Format('%s=%s', [AName, QuoteString(EscapeString(AValue))]);
  2560.   CheckCreateAttributesList;
  2561.   FAttributes.Add(Attr);
  2562. end;
  2563. {$IFDEF D4UP}
  2564. procedure TXmlNode.AttributeAdd(const AName: string; AValue: integer);
  2565. begin
  2566.   AttributeAdd(AName, IntToStr(AValue));
  2567. end;
  2568. {$ENDIF}
  2569. procedure TXmlNode.AttributeDelete(Index: integer);
  2570. begin
  2571.   if (Index >= 0) and (Index < AttributeCount) then
  2572.     FAttributes.Delete(Index);
  2573. end;
  2574. procedure TXmlNode.AttributeExchange(Index1, Index2: integer);
  2575. var
  2576.   Temp: string;
  2577. begin
  2578.   if (Index1 <> Index2) and
  2579.      (Index1 >= 0) and (Index1 < FAttributes.Count) and
  2580.      (Index2 >= 0) and (Index2 < FAttributes.Count) then
  2581.   begin
  2582.     Temp := FAttributes[Index1];
  2583.     FAttributes[Index1] := FAttributes[Index2];
  2584.     FAttributes[Index2] := Temp;
  2585.   end;
  2586. end;
  2587. function TXmlNode.AttributeIndexByname(const AName: string): integer;
  2588. // Return the index of the attribute with name AName, or -1 if not found
  2589. var
  2590.   i: integer;
  2591. begin
  2592.   Result := -1;
  2593.   for i := 0 to AttributeCount - 1 do
  2594.     if AnsiCompareText(AttributeName[i], AName) = 0 then begin
  2595.       Result := i;
  2596.       exit;
  2597.     end;
  2598. end;
  2599. procedure TXmlNode.AttributesClear;
  2600. begin
  2601.   FreeAndNil(FAttributes);
  2602. end;
  2603. function TXmlNode.BufferLength: integer;
  2604. var
  2605.   AData: string;
  2606.   APos: integer;
  2607. begin
  2608.   AData := RemoveControlChars(FValue);
  2609.   case BinaryEncoding of
  2610.   xbeBinHex:
  2611.     begin
  2612.       Result := length(AData) div 2;
  2613.       if Result * 2 <> length(AData) then
  2614.         raise EFilerError.Create(sxeErrorCalcStreamLength);
  2615.     end;
  2616.   xbeBase64:
  2617.     begin
  2618.       Result := length(AData) div 4;
  2619.       if Result * 4 <> length(AData) then
  2620.         raise EFilerError.Create(sxeErrorCalcStreamLength);
  2621.       Result := Result * 3;
  2622.       // Check padding chars
  2623.       APos := length(AData);
  2624.       if (APos > 0) and (AData[APos] = cBase64PadChar) then begin
  2625.         dec(APos);
  2626.         dec(Result);
  2627.         if (APos > 0) and (AData[APos] = cBase64PadChar) then
  2628.           dec(Result);
  2629.       end;
  2630.     end;
  2631.   else
  2632.     Result := 0; // avoid compiler warning
  2633.   end;
  2634. end;
  2635. procedure TXmlNode.BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
  2636. // Read data from XML binhex to the buffer
  2637. var
  2638.   AData: string;
  2639. begin
  2640.   AData := RemoveControlChars(FValue);
  2641.   case BinaryEncoding of
  2642.   xbeBinHex:
  2643.     DecodeBinHexBuf(AData, Buffer, Count);
  2644.   xbeBase64:
  2645.     DecodeBase64Buf(AData, Buffer, Count);
  2646.   end;
  2647. end;
  2648. procedure TXmlNode.BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
  2649. // Write data from the buffer to XML in binhex format
  2650. var
  2651.   AData: string;
  2652. begin
  2653.   if Count > 0 then
  2654.     case BinaryEncoding of
  2655.     xbeBinHex:
  2656.       AData := EncodeBinHexBuf(Buffer, Count);
  2657.     xbeBase64:
  2658.       AData := EncodeBase64Buf(Buffer, Count);
  2659.     end;
  2660.   // For comformity with Base64, we must add linebreaks each 76 characters
  2661.   FValue := AddControlChars(AData, GetLineFeed + GetIndent, 76);
  2662. end;
  2663. procedure TXmlNode.CheckCreateAttributesList;
  2664. begin
  2665.   if not assigned(FAttributes) then begin
  2666.     FAttributes := TStringList.Create;
  2667.     if assigned(FDocument) then
  2668.       FAttributes.Sorted := FDocument.SortAttributes;
  2669.   end;
  2670. end;
  2671. procedure TXmlNode.Clear;
  2672. begin
  2673.   // Name + value
  2674.   FName  := '';
  2675.   FValue := '';
  2676.   // Clear attributes and nodes
  2677.   AttributesClear;
  2678.   NodesClear;
  2679. end;
  2680. function TXmlNode.CompareNodeName(const NodeName: string): integer;
  2681. begin
  2682.   // Compare with FullPath or local name based on NodeName's first character
  2683.   if length(NodeName) > 0 then
  2684.     if NodeName[1] = '/' then begin
  2685.       // FullPath
  2686.       Result := AnsiCompareText(FullPath, NodeName);
  2687.       exit;
  2688.     end;
  2689.   // local name
  2690.   Result := AnsiCompareText(Name, NodeName);
  2691. end;
  2692. constructor TXmlNode.Create(ADocument: TNativeXml);
  2693. begin
  2694.   inherited Create;
  2695.   FDocument := ADocument;
  2696. end;
  2697. constructor TXmlNode.CreateName(ADocument: TNativeXml;
  2698.   const AName: string);
  2699. begin
  2700.   Create(ADocument);
  2701.   Name := AName;
  2702. end;
  2703. constructor TXmlNode.CreateNameValue(ADocument: TNativeXml; const AName,
  2704.   AValue: string);
  2705. begin
  2706.   Create(ADocument);
  2707.   Name := AName;
  2708.   ValueAsString := AValue;
  2709. end;
  2710. constructor TXmlNode.CreateType(ADocument: TNativeXml;
  2711.   AType: TXmlElementType);
  2712. begin
  2713.   Create(ADocument);
  2714.   FElementType  := AType;
  2715. end;
  2716. procedure TXmlNode.Delete;
  2717. begin
  2718.   if assigned(Parent) then
  2719.     Parent.NodeRemove(Self);
  2720. end;
  2721. procedure TXmlNode.DeleteEmptyNodes;
  2722. var
  2723.   i: integer;
  2724.   ANode: TXmlNode;
  2725. begin
  2726.   for i := NodeCount - 1 downto 0 do begin
  2727.     ANode := Nodes[i];
  2728.     // Recursive call
  2729.     ANode.DeleteEmptyNodes;
  2730.     // Check if we should delete child node
  2731.     if ANode.IsEmpty then
  2732.       NodeDelete(i);
  2733.   end;
  2734. end;
  2735. destructor TXmlNode.Destroy;
  2736. begin
  2737.   NodesClear;
  2738.   AttributesClear;
  2739.   inherited;
  2740. end;
  2741. function TXmlNode.FindNode(const NodeName: string): TXmlNode;
  2742. // Find the first node which has name NodeName. Contrary to the NodeByName
  2743. // function, this function will search the whole subnode tree, using the
  2744. // DepthFirst method.
  2745. var
  2746.   i: integer;
  2747. begin
  2748.   Result := nil;
  2749.   // Loop through all subnodes
  2750.   for i := 0 to NodeCount - 1 do begin
  2751.     Result := Nodes[i];
  2752.     // If the subnode has name NodeName then we have a result, exit
  2753.     if Result.CompareNodeName(NodeName) = 0 then
  2754.       exit;
  2755.     // If not, we will search the subtree of this node
  2756.     Result := Result.FindNode(NodeName);
  2757.     if assigned(Result) then
  2758.       exit;
  2759.   end;
  2760. end;
  2761. procedure TXmlNode.FindNodes(const NodeName: string; const AList: TList);
  2762. // local
  2763. procedure FindNodesRecursive(ANode: TXmlNode; AList: TList);
  2764. var
  2765.   i: integer;
  2766. begin
  2767.   with ANode do
  2768.     for i := 0 to NodeCount - 1 do begin
  2769.       if Nodes[i].CompareNodeName(NodeName) = 0 then
  2770.         AList.Add(Nodes[i]);
  2771.       FindNodesRecursive(Nodes[i], AList);
  2772.     end;
  2773. end;
  2774. // main
  2775. begin
  2776.   AList.Clear;
  2777.   FindNodesRecursive(Self, AList);
  2778. end;
  2779. function TXmlNode.FloatAllowScientific: boolean;
  2780. begin
  2781.   if assigned(Document) then
  2782.     Result := Document.FloatAllowScientific
  2783.   else
  2784.     Result := cDefaultFloatAllowScientific;
  2785. end;
  2786. function TXmlNode.FloatSignificantDigits: integer;
  2787. begin
  2788.   if assigned(Document) then
  2789.     Result := Document.FloatSignificantDigits
  2790.   else
  2791.     Result := cDefaultFloatSignificantDigits;
  2792. end;
  2793. function TXmlNode.FromAnsiString(const s: string): string;
  2794. begin
  2795.   if Utf8Encoded then
  2796.     Result := sdAnsiToUtf8(s)
  2797.   else
  2798.     Result := s;
  2799. end;