nativexml.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:199k
- { unit NativeXml
- This is a small-footprint implementation to read and write XML documents
- natively from Delpi code.
- You can use this code to read XML documents from files, streams or strings.
- The load routine generates events that can be used to display load progress
- on the fly.
- Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
- Version: see below
- Original date: 01-Apr-2003
- Last Modified: 19-Mar-2007
- Note: any external encoding (ANSI, UTF16, etc) is converted to an internal
- encoding that is ANSI or UTF8. When the loaded document is ANSI based,
- the encoding will be ANSI, in other cases (UTF8, UTF16) the encoding
- will be UTF8.
- Author: Nils Haeck M.Sc.
- Copyright (c) 2003-2006 Simdesign B.V.
- It is NOT allowed under ANY circumstances to publish or copy this code
- without prior written permission of the Author!
- This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
- ANY KIND, either express or implied.
- Please visit http://www.simdesign.nl/xml.html for more information.
- }
- {$DEFINE USEGRAPHICS} // uncomment if you do not want to include the Graphics unit.
- // Delphi and BCB versions
- // Delphi 3
- {$IFDEF VER110}
- {$DEFINE D3UP}
- {$ENDIF}
- // Delphi 4
- {$IFDEF VER120}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$ENDIF}
- // BCB 4
- {$IFDEF VER125}
- {$DEFINE D4UP}
- {$ENDIF}
- // Delphi 5
- {$IFDEF VER130}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$ENDIF}
- //Delphi 6
- {$IFDEF VER140}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$DEFINE D6UP}
- {$ENDIF}
- //Delphi 7
- {$IFDEF VER150}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$DEFINE D6UP}
- {$DEFINE D7UP}
- {$ENDIF}
- //Delphi 8
- {$IFDEF VER160}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$DEFINE D6UP}
- {$DEFINE D7UP}
- {$DEFINE D8UP}
- {$ENDIF}
- // Delphi 2005
- {$IFDEF VER170}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$DEFINE D6UP}
- {$DEFINE D7UP}
- {$DEFINE D8UP}
- {$DEFINE D9UP}
- {$ENDIF}
- // Delphi 2006
- {$IFDEF VER180}
- {$DEFINE D3UP}
- {$DEFINE D4UP}
- {$DEFINE D5UP}
- {$DEFINE D6UP}
- {$DEFINE D7UP}
- {$DEFINE D8UP}
- {$DEFINE D9UP}
- {$DEFINE D10UP}
- {$ENDIF}
- unit NativeXml;
- interface
- uses
- {$IFDEF D9UP}
- Windows,
- {$ENDIF}
- {$IFDEF CLR}
- System.Text,
- {$ENDIF}
- Classes,
- {$IFDEF USEGRAPHICS}
- {$IFDEF LINUX}
- QGraphics,
- {$ELSE}
- Graphics,
- {$ENDIF}
- {$ENDIF}
- SysUtils;
- const
- // Current version of the NativeXml unit
- cNativeXmlVersion = '2.32';
- // Delphi 3 and below stubs
- {$IFNDEF D4UP}
- type
- TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);
- int64 = integer;
- function StringReplace(const S, OldPattern, NewPattern: string;
- Flags: TReplaceFlags): string;
- function StrToInt64Def(const AValue: string; ADefault: int64): int64;
- function StrToInt64(const AValue: string): int64;
- {$ENDIF}
- // Delphi 4 stubs
- {$IFNDEF D5UP}
- type
- widestring = string;
- function AnsiPos(const Substr, S: string): Integer;
- function AnsiQuotedStr(const S: string; Quote: Char): string;
- function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
- procedure FreeAndNil(var Obj);
- {$ENDIF}
- // cross-platform pointer type
- type
- {$IFDEF CLR}
- TPointer = TObject;
- {$ELSE}
- TPointer = Pointer;
- {$ENDIF}
- // Delphi 5 stubs
- {$IFNDEF D6UP}
- type
- TSeekOrigin = Word;
- const
- soBeginning = soFromBeginning;
- soCurrent = soFromCurrent;
- soEnd = soFromEnd;
- {$ENDIF}
- type
- // Note on TNativeXml.Format:
- // - xfReadable (default) to be able to read the xml file with a standard editor.
- // - xfCompact to save the xml fully compliant and at smallest size
- TXmlFormatType = (
- xfReadable, // Save in readable format with CR-LF and indents
- xfCompact // Save without any control chars except LF after declarations
- );
- // TXmlElementType enumerates the different kinds of elements that can be found
- // in the XML document.
- TXmlElementType = (
- xeNormal, // Normal element <name {attr}>[value][sub-elements]</name>
- xeComment, // Comment <!--{comment}-->
- xeCData, // literal data <![CDATA[{data}]]>
- xeDeclaration, // XML declaration <?xml{declaration}?>
- xeStylesheet, // Stylesheet <?xml-stylesheet{stylesheet}?>
- xeDoctype, // DOCTYPE DTD declaration <!DOCTYPE{spec}>
- xeElement, // <!ELEMENT >
- xeAttList, // <!ATTLIST >
- xeEntity, // <!ENTITY >
- xeNotation, // <!NOTATION >
- xeExclam, // Any <!data>
- xeQuestion, // Any <?data?>
- xeCharData, // Character data in a node
- xeUnknown // Any <data>
- );
- // Choose what kind of binary encoding will be used when calling
- // TXmlNode BufferRead and BufferWrite.
- TBinaryEncodingType = (
- xbeBinHex, { With this encoding, each byte is stored as a hexadecimal
- number, e.g. 0 = 00 and 255 = FF. }
- xbeBase64 { With this encoding, each group of 3 bytes are stored as 4
- characters, requiring 64 different characters.}
- );
- // Definition of different methods of string encoding.
- TStringEncodingType = (
- se8Bit, // General 8 bit encoding, encoding must be determined from encoding declaration
- seUCS4BE, // UCS-4 Big Endian
- seUCS4LE, // UCS-4 Little Endian
- seUCS4_2143, // UCS-4 unusual octet order (2143)
- seUCS4_3412, // UCS-4 unusual octet order (3412)
- se16BitBE, // General 16 bit Big Endian, encoding must be determined from encoding declaration
- se16BitLE, // General 16 bit Little Endian, encoding must be determined from encoding declaration
- seUTF8, // UTF-8
- seUTF16BE, // UTF-16 Big Endian
- seUTF16LE, // UTF-16 Little Endian
- seEBCDIC // EBCDIC flavour
- );
- TXmlCompareOption = (
- xcNodeName,
- xcNodeType,
- xcNodeValue,
- xcAttribCount,
- xcAttribNames,
- xcAttribValues,
- xcChildCount,
- xcChildNames,
- xcChildValues,
- xcRecursive
- );
- TXmlCompareOptions = set of TXmlCompareOption;
- const
- xcAll: TXmlCompareOptions = [xcNodeName, xcNodeType, xcNodeValue, xcAttribCount,
- xcAttribNames, xcAttribValues, xcChildCount, xcChildNames, xcChildValues,
- xcRecursive];
- var
- // XML Defaults
- cDefaultEncodingString: string = 'windows-1252';
- cDefaultExternalEncoding: TStringEncodingType = se8bit;
- cDefaultVersionString: string = '1.0';
- cDefaultXmlFormat: TXmlFormatType = xfCompact;
- cDefaultWriteOnDefault: boolean = True;
- cDefaultBinaryEncoding: TBinaryEncodingType = xbeBase64;
- cDefaultUtf8Encoded: boolean = False;
- cDefaultIndentString: string = ' ';
- cDefaultDropCommentsOnParse: boolean = False;
- cDefaultUseFullNodes: boolean = False;
- cDefaultSortAttributes: boolean = False;
- cDefaultFloatAllowScientific: boolean = True;
- cDefaultFloatSignificantDigits: integer = 6;
- type
- TXmlNode = class;
- TNativeXml = class;
- TsdCodecStream = class;
- // An event that is based on the TXmlNode object Node.
- TXmlNodeEvent = procedure(Sender: TObject; Node: TXmlNode) of object;
- // An event that is used to indicate load or save progress.
- TXmlProgressEvent = procedure(Sender: TObject; Size: integer) of object;
- // This event is used in the TNativeXml.OnNodeCompare event, and should
- // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
- TXmlNodeCompareEvent = function(Sender: TObject; Node1, Node2: TXmlNode; Info: TPointer): integer of object;
- // Pass a function of this kind to TXmlNode.SortChildNodes. The function should
- // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
- TXMLNodeCompareFunction = function(Node1, Node2: TXmlNode; Info: TPointer): integer;
- // The TXmlNode represents an element in the XML file. Each TNativeXml holds
- // one Root element. Under ths root element, sub-elements can be nested (there
- // is no limit on how deep). Property ElementType defines what kind of element
- // this node is.
- TXmlNode = class(TPersistent)
- private
- FAttributes: TStringList; // List with attributes
- FDocument: TNativeXml; // Pointer to parent XmlDocument
- FElementType: TXmlElementType; // The type of element
- FName: string; // The element name
- FNodes: TList; // These are the child elements
- FParent: TXmlNode; // Pointer to parent element
- FTag: integer; // A value the developer can use
- FValue: string; // The *escaped* value
- function GetValueAsString: string;
- procedure SetAttributeName(Index: integer; const Value: string);
- procedure SetAttributeValue(Index: integer; const Value: string);
- procedure SetValueAsString(const AValue: string);
- function GetIndent: string;
- function GetLineFeed: string;
- function GetTreeDepth: integer;
- function GetAttributeCount: integer;
- function GetAttributePair(Index: integer): string;
- function GetAttributeName(Index: integer): string;
- function GetAttributeValue(Index: integer): string;
- function GetWriteOnDefault: boolean;
- function GetBinaryEncoding: TBinaryEncodingType;
- function GetCascadedName: string;
- function QualifyAsDirectNode: boolean;
- procedure SetName(const Value: string);
- function GetFullPath: string;
- procedure SetBinaryEncoding(const Value: TBinaryEncodingType);
- function GetBinaryString: string;
- procedure SetBinaryString(const Value: string);
- function UseFullNodes: boolean;
- function GetValueAsWidestring: widestring;
- procedure SetValueAsWidestring(const Value: widestring);
- function GetAttributeByName(const AName: string): string;
- procedure SetAttributeByName(const AName, Value: string);
- function GetValueAsInteger: integer;
- procedure SetValueAsInteger(const Value: integer);
- function GetValueAsFloat: double;
- procedure SetValueAsFloat(const Value: double);
- function GetValueAsDateTime: TDateTime;
- procedure SetValueAsDateTime(const Value: TDateTime);
- function GetValueAsBool: boolean;
- procedure SetValueAsBool(const Value: boolean);
- function GetValueAsInt64: int64;
- procedure SetValueAsInt64(const Value: int64);
- procedure CheckCreateAttributesList;
- function GetAttributeValueAsWidestring(Index: integer): widestring;
- procedure SetAttributeValueAsWidestring(Index: integer;
- const Value: widestring);
- function GetAttributeValueAsInteger(Index: integer): integer;
- procedure SetAttributeValueAsInteger(Index: integer;
- const Value: integer);
- function GetAttributeByNameWide(const AName: string): widestring;
- procedure SetAttributeByNameWide(const AName: string;
- const Value: widestring);
- function GetTotalNodeCount: integer;
- function FloatSignificantDigits: integer;
- function FloatAllowScientific: boolean;
- protected
- function CompareNodeName(const NodeName: string): integer;
- function GetNodes(Index: integer): TXmlNode; virtual;
- function GetNodeCount: integer; virtual;
- procedure ParseTag(const AValue: string; TagStart, TagClose: integer);
- procedure ReadFromStream(S: TStream); virtual;
- procedure ReadFromString(const AValue: string); virtual;
- procedure ResolveEntityReferences;
- function UnescapeString(const AValue: string): string; virtual;
- function Utf8Encoded: boolean;
- function WriteInnerTag: string; virtual;
- procedure WriteToStream(S: TStream); virtual;
- public
- // Create a new TXmlNode object. ADocument must be the TNativeXml that is
- // going to hold this new node.
- constructor Create(ADocument: TNativeXml); virtual;
- // Create a new TXmlNode with name AName. ADocument must be the TNativeXml
- // that is going to hold this new node.
- constructor CreateName(ADocument: TNativeXml; const AName: string); virtual;
- // Create a new TXmlNode with name AName and string value AValue. ADocument
- // must be the TNativeXml that is going to hold this new node.
- constructor CreateNameValue(ADocument: TNativeXml; const AName, AValue: string); virtual;
- // Create a new TXmlNode with XML element type AType. ADocument must be the
- // TNativeXml that is going to hold this new node.
- constructor CreateType(ADocument: TNativeXml; AType: TXmlElementType); virtual;
- // Use Assign to assign another TXmlNode to this node. This means that all
- // properties and subnodes from the Source TXmlNode are copied to the current
- // node. You can also Assign a TNativeXml document to the node, in that case
- // the RootNodeList property of the TNativeXml object will be copied.
- procedure Assign(Source: TPersistent); override;
- // Call Delete to delete this node completely from the parent node list. This
- // call only succeeds if the node has a parent. It has no effect when called for
- // the root node.
- procedure Delete; virtual;
- // Delete all nodes that are empty (this means, which have no subnodes, no
- // attributes, and no value assigned). This procedure works recursively.
- procedure DeleteEmptyNodes;
- // Destroy a TXmlNode object. This will free the child node list automatically.
- // Never call this method directly. All TXmlNodes in the document will be
- // recursively freed when TNativeXml.Free is called.
- destructor Destroy; override;
- {$IFDEF D4UP}
- // Use this method to add an integer attribute to the node.
- procedure AttributeAdd(const AName: string; AValue: integer); overload;
- {$ENDIF}
- // Use this method to add a string attribute with value AValue to the node.
- procedure AttributeAdd(const AName, AValue: string); {$IFDEF D4UP}overload;{$ENDIF}
- // Use this method to delete the attribute at Index in the list. Index must be
- // equal or greater than 0, and smaller than AttributeCount. Using an index
- // outside of that range has no effect.
- procedure AttributeDelete(Index: integer);
- // Switch position of the attributes at Index1 and Index2.
- procedure AttributeExchange(Index1, Index2: integer);
- // Use this method to find the index of an attribute with name AName.
- function AttributeIndexByname(const AName: string): integer;
- // Clear all attributes from the current node.
- procedure AttributesClear; virtual;
- // Use this method to read binary data from the node into Buffer with a length of Count.
- procedure BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual;
- // Use this method to write binary data in Buffer with a length of Count to the
- // current node. The data will appear as text using either BinHex or Base64
- // method) in the final XML document.
- // Notice that NativeXml does only support up to 2Gb bytes of data per file,
- // so do not use this option for huge files. The binary encoding method (converting
- // binary data into text) can be selected using property BinaryEncoding.
- // xbeBase64 is most efficient, but slightly slower. Always use identical methods
- // for reading and writing.
- procedure BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer); virtual;
- // Returns the length of the data in the buffer, once it would be decoded by
- // method xbeBinHex or xbeBase64. If BinaryEncoding is xbeSixBits, this function
- // cannot be used. The length of the unencoded data is determined from the
- // length of the encoded data. For xbeBinHex this is trivial (just half the
- // length), for xbeBase64 this is more difficult (must use the padding characters)
- function BufferLength: integer; virtual;
- // Clear all child nodes and attributes, and the name and value of the current
- // XML node. However, the node is not deleted. Call Delete instead for that.
- procedure Clear; virtual;
- // Find the first node which has name NodeName. Contrary to the NodeByName
- // function, this function will search the whole subnode tree, using the
- // DepthFirst method. It is possible to search for a full path too, e.g.
- // FoundNode := MyNode.FindNode('/Root/SubNode1/SubNode2/ThisNode');
- function FindNode(const NodeName: string): TXmlNode;
- // Find all nodes which have name NodeName. Contrary to the NodesByName
- // function, this function will search the whole subnode tree. If you use
- // a TXmlNodeList for the AList parameter, you don't need to cast the list
- // items to TXmlNode.
- procedure FindNodes(const NodeName: string; const AList: TList);
- // Use FromAnsiString to convert a normal ANSI string to a string for the node
- // (name, value, attributes). If the TNativeXml property UtfEncoded is True,
- // the ANSI characters are encoded into UTF8. Use this function if you work
- // with special codebases (characters in the range $7F-$FF) and want to produce
- // unicode or UTF8 XML documents.
- function FromAnsiString(const s: string): string;
- // Use FromWidestring to convert widestring to a string for the node (name, value,
- // attributes). If the TNativeXml property UtfEncoded is True, all
- // character codes higher than $FF are preserved.
- function FromWidestring(const W: widestring): string;
- // Use HasAttribute to determine if the node has an attribute with name AName.
- function HasAttribute(const AName: string): boolean; virtual;
- // This function returns the index of this node in the parent's node list.
- // If Parent is not assigned, this function returns -1.
- function IndexInParent: integer;
- // This function returns True if the node has no subnodes and no attributes,
- // and if the node Name and value are empty.
- function IsClear: boolean; virtual;
- // This function returns True if the node has no subnodes and no attributes,
- // and if the node value is empty.
- function IsEmpty: boolean; virtual;
- function IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; MismatchNodes: TList {$IFDEF D4UP}= nil{$ENDIF}): boolean;
- // Add the node ANode as a new subelement in the nodelist. The node will be
- // added in position NodeCount (which will be returned).
- function NodeAdd(ANode: TXmlNode): integer; virtual;
- // This function returns a pointer to the first subnode that has an attribute with
- // name AttribName and value AttribValue. If ShouldRecurse = True (default), the
- // function works recursively, using the depthfirst method.
- function NodeByAttributeValue(const NodeName, AttribName, AttribValue: string;
- ShouldRecurse: boolean {$IFDEF D4UP}= True{$ENDIF}): TXmlNode;
- // Return a pointer to the first subnode with this Elementype, or return nil
- // if no subnode with that type is found.
- function NodeByElementType(ElementType: TXmlElementType): TXmlNode;
- // Return a pointer to the first subnode in the nodelist that has name AName.
- // If no subnodes with AName are found, the function returns nil.
- function NodeByName(const AName: string): TXmlNode; virtual;
- // Delete the subnode at Index. The node will also be freed, so do not free the
- // node in the application.
- procedure NodeDelete(Index: integer); virtual;
- // Switch position of the nodes at Index1 and Index2.
- procedure NodeExchange(Index1, Index2: integer);
- // Extract the node ANode from the subnode list. The node will no longer appear
- // in the subnodes list, so the application is responsible for freeing ANode later.
- function NodeExtract(ANode: TXmlNode): TXmlNode; virtual;
- // This function returns a pointer to the first node with AName. If this node
- // is not found, then it creates a new node with AName and returns its pointer.
- function NodeFindOrCreate(const AName: string): TXmlNode; virtual;
- // Find the index of the first subnode with name AName.
- function NodeIndexByName(const AName: string): integer; virtual;
- // Find the index of the first subnode with name AName that appears after or on
- // the index AFrom. This function can be used in a loop to retrieve all nodes
- // with a certain name, without using a helper list. See also NodesByName.
- function NodeIndexByNameFrom(const AName: string; AFrom: integer): integer; virtual;
- // Call NodeIndexOf to get the index for ANode in the Nodes array. The first
- // node in the array has index 0, the second item has index 1, and so on. If
- // a node is not in the list, NodeIndexOf returns -1.
- function NodeIndexOf(ANode: TXmlNode): integer;
- // Insert the node ANode at location Index in the list.
- procedure NodeInsert(Index: integer; ANode: TXmlNode); virtual;
- // Create a new node with AName, add it to the subnode list, and return a
- // pointer to it.
- function NodeNew(const AName: string): TXmlNode; virtual;
- // Create a new node with AName, and insert it into the subnode list at location
- // Index, and return a pointer to it.
- function NodeNewAtIndex(Index: integer; const AName: string): TXmlNode; virtual;
- // Call NodeRemove to remove a specific node from the Nodes array when its index
- // is unknown. The value returned is the index of the item in the Nodes array
- // before it was removed. After an item is removed, all the items that follow
- // it are moved up in index position and the NodeCount is reduced by one.
- function NodeRemove(ANode: TxmlNode): integer;
- // Clear (and free) the complete list of subnodes.
- procedure NodesClear; virtual;
- // Use this procedure to retrieve all nodes that have name AName. Pointers to
- // these nodes are added to the list in AList. AList must be initialized
- // before calling this procedure. If you use a TXmlNodeList you don't need
- // to cast the list items to TXmlNode.
- procedure NodesByName(const AName: string; const AList: TList);
- // Find the attribute with AName, and convert its value to a boolean. If the
- // attribute is not found, or cannot be converted, the default ADefault will
- // be returned.
- function ReadAttributeBool(const AName: string; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}): boolean; virtual;
- // Find the attribute with AName, and convert its value to an integer. If the
- // attribute is not found, or cannot be converted, the default ADefault will
- // be returned.
- function ReadAttributeInteger(const AName: string; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}): integer; virtual;
- // Find the attribute with AName, and convert its value to an int64. If the
- // attribute is not found, or cannot be converted, the default ADefault will
- // be returned.
- function ReadAttributeInt64(const AName: string; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}): int64; virtual;
- // Find the attribute with AName, and convert its value to a float. If the
- // attribute is not found, or cannot be converted, the default ADefault will
- // be returned.
- function ReadAttributeFloat(const AName: string; ADefault: double {$IFDEF D4UP}= 0{$ENDIF}): double;
- function ReadAttributeString(const AName: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}): string; virtual;
- // Read the subnode with AName and convert it to a boolean value. If the
- // subnode is not found, or cannot be converted, the boolean ADefault will
- // be returned.
- function ReadBool(const AName: string; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}): boolean; virtual;
- {$IFDEF USEGRAPHICS}
- // Read the properties Color and Style for the TBrush object ABrush from the
- // subnode with AName.
- procedure ReadBrush(const AName: string; ABrush: TBrush); virtual;
- // Read the subnode with AName and convert its value to TColor. If the
- // subnode is not found, or cannot be converted, ADefault will be returned.
- function ReadColor(const AName: string; ADefault: TColor {$IFDEF D4UP}= clBlack{$ENDIF}): TColor; virtual;
- // Read the properties Name, Color, Size and Style for the TFont object AFont
- // from the subnode with AName.
- procedure ReadFont(const AName: string; AFont: TFont); virtual;
- // Read the properties Color, Mode, Style and Width for the TPen object APen
- // from the subnode with AName.
- procedure ReadPen(const AName: string; APen: TPen); virtual;
- {$ENDIF}
- // Read the subnode with AName and convert its value to TDateTime. If the
- // subnode is not found, or cannot be converted, ADefault will be returned.
- function ReadDateTime(const AName: string; ADefault: TDateTime {$IFDEF D4UP}= 0{$ENDIF}): TDateTime; virtual;
- // Read the subnode with AName and convert its value to a double. If the
- // subnode is not found, or cannot be converted, ADefault will be returned.
- function ReadFloat(const AName: string; ADefault: double {$IFDEF D4UP}= 0.0{$ENDIF}): double; virtual;
- {$IFDEF D4UP}
- // Read the subnode with AName and convert its value to an int64. If the
- // subnode is not found, or cannot be converted, ADefault will be returned.
- function ReadInt64(const AName: string; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}): int64; virtual;
- {$ENDIF}
- // Read the subnode with AName and convert its value to an integer. If the
- // subnode is not found, or cannot be converted, ADefault will be returned.
- function ReadInteger(const AName: string; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}): integer; virtual;
- // Read the subnode with AName and return its string value. If the subnode is
- // not found, ADefault will be returned.
- function ReadString(const AName: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}): string; virtual;
- // Read the subnode with AName and return its widestring value. If the subnode is
- // not found, ADefault will be returned.
- function ReadWidestring(const AName: string; const ADefault: widestring {$IFDEF D4UP}= ''{$ENDIF}): widestring; virtual;
- // Sort the child nodes of this node. Provide a custom node compare function in Compare,
- // or attach an event handler to the parent documents' OnNodeCompare in order to
- // provide custom sorting. If no compare function is given (nil) and OnNodeCompare
- // is not implemented, SortChildNodes will simply sort the nodes by name (ascending,
- // case insensitive). The Info pointer parameter can be used to pass any custom
- // information to the compare function. Default value for Info is nil.
- procedure SortChildNodes(Compare: TXMLNodeCompareFunction {$IFDEF D4UP}= nil{$ENDIF}; Info: TPointer {$IFDEF D4UP}= nil{$ENDIF});
- // Use ToAnsiString to convert any string from the node (name, value, attributes)
- // to a normal ANSI string. If the TNativeXml property UtfEncoded is True,
- // you may loose characters with codes higher than $FF. To prevent this, use
- // widestrings in your application and use ToWidestring instead.
- function ToAnsiString(const s: string): string;
- // Use ToWidestring to convert any string from the node (name, value, attributes)
- // to a widestring. If the TNativeXml property UtfEncoded is True, all
- // character codes higher than $FF are preserved.
- function ToWidestring(const s: string): widestring;
- // Convert the node's value to boolean and return the result. If this conversion
- // fails, or no value is found, then the function returns ADefault.
- function ValueAsBoolDef(ADefault: boolean): boolean; virtual;
- // Convert the node's value to a TDateTime and return the result. If this conversion
- // fails, or no value is found, then the function returns ADefault.
- function ValueAsDateTimeDef(ADefault: TDateTime): TDateTime; virtual;
- // Convert the node's value to a double and return the result. If this conversion
- // fails, or no value is found, then the function returns ADefault.
- function ValueAsFloatDef(ADefault: double): double; virtual;
- // Convert the node's value to int64 and return the result. If this conversion
- // fails, or no value is found, then the function returns ADefault.
- function ValueAsInt64Def(ADefault: int64): int64; virtual;
- // Convert the node's value to integer and return the result. If this conversion
- // fails, or no value is found, then the function returns ADefault.
- function ValueAsIntegerDef(ADefault: integer): integer; virtual;
- // If the attribute with name AName exists, then set its value to the boolean
- // AValue. If it does not exist, then create a new attribute AName with the
- // boolean value converted to either "True" or "False". If ADefault = AValue, and
- // WriteOnDefault = False, no attribute will be added.
- procedure WriteAttributeBool(const AName: string; AValue: boolean; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}); virtual;
- // If the attribute with name AName exists, then set its value to the integer
- // AValue. If it does not exist, then create a new attribute AName with the
- // integer value converted to a quoted string. If ADefault = AValue, and
- // WriteOnDefault = False, no attribute will be added.
- procedure WriteAttributeInteger(const AName: string; AValue: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
- procedure WriteAttributeFloat(const AName: string; AValue: double; ADefault: double {$IFDEF D4UP} = 0{$ENDIF}); virtual;
- // If the attribute with name AName exists, then set its value to the string
- // AValue. If it does not exist, then create a new attribute AName with the
- // value AValue. If ADefault = AValue, and WriteOnDefault = False, no attribute
- // will be added.
- procedure WriteAttributeString(const AName: string; const AValue: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}); virtual;
- // Add or replace the subnode with AName and set its value to represent the boolean
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteBool(const AName: string; AValue: boolean; ADefault: boolean {$IFDEF D4UP}= False{$ENDIF}); virtual;
- {$IFDEF USEGRAPHICS}
- // Write properties Color and Style of the TBrush object ABrush to the subnode
- // with AName. If AName does not exist, it will be created.
- procedure WriteBrush(const AName: string; ABrush: TBrush); virtual;
- // Add or replace the subnode with AName and set its value to represent the TColor
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteColor(const AName: string; AValue: TColor; ADefault: TColor {$IFDEF D4UP}= clBlack{$ENDIF}); virtual;
- // Write properties Name, Color, Size and Style of the TFont object AFont to
- // the subnode with AName. If AName does not exist, it will be created.
- procedure WriteFont(const AName: string; AFont: TFont); virtual;
- // Write properties Color, Mode, Style and Width of the TPen object APen to
- // the subnode with AName. If AName does not exist, it will be created.
- procedure WritePen(const AName: string; APen: TPen); virtual;
- {$ENDIF}
- // Add or replace the subnode with AName and set its value to represent the TDateTime
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- // The XML format used is compliant with W3C's specification of date and time.
- procedure WriteDateTime(const AName: string; AValue: TDateTime; ADefault: TDateTime {$IFDEF D4UP}= 0{$ENDIF}); virtual;
- // Add or replace the subnode with AName and set its value to represent the double
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteFloat(const AName: string; AValue: double; ADefault: double {$IFDEF D4UP}= 0.0{$ENDIF}); virtual;
- // Add or replace the subnode with AName and set its value to represent the hexadecimal representation of
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteHex(const AName: string; AValue: integer; Digits: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
- {$IFDEF D4UP}
- // Add or replace the subnode with AName and set its value to represent the int64
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteInt64(const AName: string; AValue: int64; ADefault: int64 {$IFDEF D4UP}= 0{$ENDIF}); virtual;
- {$ENDIF}
- // Add or replace the subnode with AName and set its value to represent the integer
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteInteger(const AName: string; AValue: integer; ADefault: integer {$IFDEF D4UP}= 0{$ENDIF}); virtual;
- // Add or replace the subnode with AName and set its value to represent the string
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteString(const AName, AValue: string; const ADefault: string {$IFDEF D4UP}= ''{$ENDIF}); virtual;
- // Call WriteToString to save the XML node to a string. This method can be used to store
- // individual nodes instead of the complete XML document.
- function WriteToString: string; virtual;
- // Add or replace the subnode with AName and set its value to represent the widestring
- // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added.
- procedure WriteWidestring(const AName: string; const AValue: widestring; const ADefault: widestring {$IFDEF D4UP}= ''{$ENDIF}); virtual;
- // AttributeByName returns the attribute value for the attribute that has name AName.
- // Set AttributeByName to add an attribute to the attribute list, or replace an
- // existing one.
- property AttributeByName[const AName: string]: string read GetAttributeByName write
- SetAttributeByName;
- // AttributeByNameWide returns the attribute value for the attribute that has name AName
- // as widestring. Set AttributeByNameWide to add an attribute to the attribute list, or replace an
- // existing one.
- property AttributeByNameWide[const AName: string]: widestring read GetAttributeByNameWide write
- SetAttributeByNameWide;
- // Returns the number of attributes in the current node.
- property AttributeCount: integer read GetAttributeCount;
- // Read this property to get the name of the attribute at Index. Note that Index
- // is zero-based: Index goes from 0 to AttributeCount - 1
- property AttributeName[Index: integer]: string read GetAttributeName write SetAttributeName;
- // Read this property to get the Attribute Name and Value pair at index Index.
- // This is a string with Name and Value separated by a TAB character (#9).
- property AttributePair[Index: integer]: string read GetAttributePair;
- // Read this property to get the string value of the attribute at index Index.
- // Write to it to set the string value.
- property AttributeValue[Index: integer]: string read GetAttributeValue write SetAttributeValue;
- // Read this property to get the widestring value of the attribute at index Index.
- // Write to it to set the widestring value.
- property AttributeValueAsWidestring[Index: integer]: widestring read GetAttributeValueAsWidestring write SetAttributeValueAsWidestring;
- // Read this property to get the integer value of the attribute at index Index.
- // If the value cannot be converted, 0 will be returned. Write to it to set the integer value.
- property AttributeValueAsInteger[Index: integer]: integer read GetAttributeValueAsInteger write SetAttributeValueAsInteger;
- // BinaryEncoding reflects the same value as the BinaryEncoding setting of the parent
- // Document.
- property BinaryEncoding: TBinaryEncodingType read GetBinaryEncoding write SetBinaryEncoding;
- // Use BinaryString to add/extract binary data in an easy way to/from the node. Internally the
- // data gets stored as Base64-encoded data. Do not use this method for normal textual
- // information, it is better to use ValueAsString in that case (adds less overhead).
- property BinaryString: string read GetBinaryString write SetBinaryString;
- // This property returns the name and index and all predecessors with underscores
- // to separate, in order to get a unique reference that can be used in filenames.
- property CascadedName: string read GetCascadedName;
- // Pointer to parent NativeXml document, or Nil if none.
- property Document: TNativeXml read FDocument write FDocument;
- // ElementType contains the type of element that this node holds.
- property ElementType: TXmlElementType read FElementType write FElementType;
- // Fullpath will return the complete path of the node from the root, e.g.
- // /Root/SubNode1/SubNode2/ThisNode
- property FullPath: string read GetFullPath;
- // Read Name to get the name of the element, and write Name to set the name.
- // This is the full name and may include a namespace. (Namespace:Name)
- property Name: string read FName write SetName;
- // Parent points to the parent node of the current XML node.
- property Parent: TXmlNode read FParent write FParent;
- // NodeCount is the number of child nodes that this node holds. In order to
- // loop through all child nodes, use a construct like this:
- // <CODE>
- // with MyNode do
- // for i := 0 to NodeCount - 1 do
- // with Nodes[i] do
- // ..processing here
- // </CODE>
- property NodeCount: integer read GetNodeCount;
- // Use Nodes to access the child nodes of the current XML node by index. Note
- // that the list is zero-based, so Index is valid from 0 to NodeCount - 1.
- property Nodes[Index: integer]: TXmlNode read GetNodes; default;
- // Tag is an integer value the developer can use in any way. Tag does not get
- // saved to the XML. Tag is often used to point to a GUI element (and is then
- // cast to a pointer).
- property Tag: integer read FTag write FTag;
- // TotalNodeCount represents the total number of child nodes, and child nodes
- // of child nodes etcetera of this particular node. Use the following to get
- // the total number of nodes in the XML document:
- // <CODE>
- // Total := MyDoc.RootNodes.TotalNodeCount;
- // </CODE>
- property TotalNodeCount: integer read GetTotalNodeCount;
- // Read TreeDepth to find out many nested levels there are for the current XML
- // node. Root has a TreeDepth of zero.
- property TreeDepth: integer read GetTreeDepth;
- // ValueAsBool returns the node's value as boolean, or raises an
- // exception if the value cannot be converted to boolean. Set ValueAsBool
- // to convert a boolean to a string in the node's value field. See also
- // function ValueAsBoolDef.
- property ValueAsBool: boolean read GetValueAsBool write SetValueAsBool;
- // ValueAsDateTime returns the node's value as TDateTime, or raises an
- // exception if the value cannot be converted to TDateTime. Set ValueAsDateTime
- // to convert a TDateTime to a string in the node's value field. See also
- // function ValueAsDateTimeDef.
- property ValueAsDateTime: TDateTime read GetValueAsDateTime write SetValueAsDateTime;
- // ValueAsIn64 returns the node's value as int64, or raises an
- // exception if the value cannot be converted to int64. Set ValueAsInt64
- // to convert an int64 to a string in the node's value field. See also
- // function ValueAsInt64Def.
- property ValueAsInt64: int64 read GetValueAsInt64 write SetValueAsInt64;
- // ValueAsInteger returns the node's value as integer, or raises an
- // exception if the value cannot be converted to integer. Set ValueAsInteger
- // to convert an integer to a string in the node's value field. See also
- // function ValueAsIntegerDef.
- property ValueAsInteger: integer read GetValueAsInteger write SetValueAsInteger;
- // ValueAsFloat returns the node's value as float, or raises an
- // exception if the value cannot be converted to float. Set ValueAsFloat
- // to convert a float to a string in the node's value field. See also
- // function ValueAsFloatDef.
- property ValueAsFloat: double read GetValueAsFloat write SetValueAsFloat;
- // ValueAsString returns the unescaped version of ValueDirect. All neccesary
- // characters in ValueDirect must be escaped (e.g. "&" becomes "&") but
- // ValueAsString returns them in original format. Always use ValueAsString to
- // set the text value of a node, to make sure all neccesary charaters are
- // escaped.
- property ValueAsString: string read GetValueAsString write SetValueAsString;
- // ValueAsWidestring returns the unescaped version of ValueDirect as a widestring.
- // Always use ValueAsWidestring to set the text value of a node, to make sure all
- // neccesary charaters are escaped. Character codes bigger than $FF are preserved
- // if the document is set to Utf8Encoded.
- property ValueAsWidestring: widestring read GetValueAsWidestring write SetValueAsWidestring;
- // ValueDirect is the exact text value as was parsed from the stream. If multiple
- // text elements are encountered, they are added to ValueDirect with a CR to
- // separate them.
- property ValueDirect: string read FValue write FValue;
- // WriteOnDefault reflects the same value as the WriteOnDefault setting of the parent
- // Document.
- property WriteOnDefault: boolean read GetWriteOnDefault;
- end;
- // TXmlNodeList is a utility TList descendant that can be used to work with selection
- // lists. An example:
- // <code>
- // procedure FindAllZips(ANode: TXmlNode);
- // var
- // i: integer;
- // AList: TXmlNodeList;
- // begin
- // AList := TXmlNodeList.Create;
- // try
- // // Get a list of all nodes named 'ZIP'
- // ANode.NodesByName('ZIP', AList);
- // for i := 0 to AList.Count - 1 do
- // // Write the value of the node to output. Since AList[i] will be
- // // of type TXmlNode, we can directly access the Value property.
- // WriteLn(AList[i].Value);
- // finally
- // AList.Free;
- // end;
- // end;
- // </code>
- TXmlNodeList = class(TList)
- private
- function GetItems(Index: Integer): TXmlNode;
- procedure SetItems(Index: Integer; const Value: TXmlNode);
- public
- property Items[Index: Integer]: TXmlNode read GetItems write SetItems; default;
- end;
- // TNativeXml is the XML document holder. Create a TNativeXml and then use
- // methods LoadFromFile, LoadFromStream or ReadFromString to load an XML document
- // into memory. Or start from scratch and use Root.NodeNew to add nodes and
- // eventually SaveToFile and SaveToStream to save the results as an XML document.
- // Use property Xmlformat = xfReadable to ensure that indented (readable) output
- // is produced.
- TNativeXml = class(TPersistent)
- private
- FAbortParsing: boolean; // Signal to abort the parsing process
- FBinaryEncoding: TBinaryEncodingType; // xbeBinHex or xbeBase64
- FCodecStream: TsdCodecStream; // Temporary stream used to read encoded files
- FDropCommentsOnParse: boolean; // If true, comments are dropped (deleted) when parsing
- FExternalEncoding: TStringEncodingType;
- FFloatAllowScientific: boolean;
- FFloatSignificantDigits: integer;
- FParserWarnings: boolean; // Show parser warnings for non-critical errors
- FRootNodes: TXmlNode; // Root nodes in the document (which contains one normal element that is the root)
- FIndentString: string; // The indent string used to indent content (default is two spaces)
- FUseFullNodes: boolean; // If true, nodes are never written in short notation.
- FUtf8Encoded: boolean; // If true, all internal strings are UTF-8 encoded
- FWriteOnDefault: boolean; // Set this option to "False" to only write values <> default value (default = true)
- FXmlFormat: TXmlFormatType; // xfReadable, xfCompact
- FSortAttributes: boolean; // If true, sort the String List that holds the parsed attributes.
- FOnNodeCompare: TXmlNodeCompareEvent; // Compare two nodes
- FOnNodeNew: TXmlNodeEvent; // Called after a node is added
- FOnNodeLoaded: TXmlNodeEvent; // Called after a node is loaded completely
- FOnProgress: TXmlProgressEvent; // Called after a node is loaded/saved, with the current position in the file
- FOnUnicodeLoss: TNotifyEvent; // This event is called when there is a warning for unicode conversion loss when reading unicode
- procedure DoNodeNew(Node: TXmlNode);
- procedure DoNodeLoaded(Node: TXmlNode);
- procedure DoUnicodeLoss(Sender: TObject);
- function GetCommentString: string;
- procedure SetCommentString(const Value: string);
- function GetEntityByName(AName: string): string;
- function GetRoot: TXmlNode;
- function GetEncodingString: string;
- procedure SetEncodingString(const Value: string);
- function GetVersionString: string;
- procedure SetVersionString(const Value: string);
- function GetStyleSheetNode: TXmlNode;
- protected
- procedure CopyFrom(Source: TNativeXml); virtual;
- procedure DoProgress(Size: integer);
- function LineFeed: string; virtual;
- procedure ParseDTD(ANode: TXmlNode; S: TStream); virtual;
- procedure ReadFromStream(S: TStream); virtual;
- procedure WriteToStream(S: TStream); virtual;
- procedure SetDefaults; virtual;
- public
- // Create a new NativeXml document which can then be used to read or write XML files.
- // A document that is created with Create must later be freed using Free.
- // Example:
- // <Code>
- // var
- // ADoc: TNativeXml;
- // begin
- // ADoc := TNativeXml.Create;
- // try
- // ADoc.LoadFromFile('c:\temp\myxml.xml');
- // {do something with the document here}
- // finally
- // ADoc.Free;
- // end;
- // end;
- // </Code>
- constructor Create; virtual;
- // Use CreateName to Create a new Xml document that will automatically
- // contain a root element with name ARootName.
- constructor CreateName(const ARootName: string); virtual;
- // Destroy will free all data in the TNativeXml object. This includes the
- // root node and all subnodes under it. Do not call Destroy directly, call
- // Free instead.
- destructor Destroy; override;
- // When calling Assign with a Source object that is a TNativeXml, will cause
- // it to copy all data from Source.
- procedure Assign(Source: TPersistent); override;
- // Call Clear to remove all data from the object, and restore all defaults.
- procedure Clear; virtual;
- // Function IsEmpty returns true if the root is clear, or in other words, the
- // root contains no value, no name, no subnodes and no attributes.
- function IsEmpty: boolean; virtual;
- // Load an XML document from the TStream object in Stream. The LoadFromStream
- // procedure will raise an exception of type EFilerError when it encounters
- // non-wellformed XML. This method can be used with any TStream descendant.
- // See also LoadFromFile and ReadFromString.
- procedure LoadFromStream(Stream: TStream); virtual;
- // Call procedure LoadFromFile to load an XML document from the filename
- // specified. See Create for an example. The LoadFromFile procedure will raise
- // an exception of type EFilerError when it encounters non-wellformed XML.
- procedure LoadFromFile(const FileName: string); virtual;
- // Call procedure ReadFromString to load an XML document from the string AValue.
- // The ReadFromString procedure will raise an exception of type EFilerError
- // when it encounters non-wellformed XML.
- procedure ReadFromString(const AValue: string); virtual;
- // Call ResolveEntityReferences after the document has been loaded to resolve
- // any present entity references (&Entity;). When an entity is found in the
- // DTD, it will replace the entity reference. Whenever an entity contains
- // XML markup, it will be parsed and become part of the document tree. Since
- // calling ResolveEntityReferences is adding quite some extra overhead, it
- // is not done automatically. If you want to do the entity replacement, a good
- // moment to call ResolveEntityReferences is right after LoadFromFile.
- procedure ResolveEntityReferences;
- // Call SaveToStream to save the XML document to the Stream. Stream
- // can be any TStream descendant. Set XmlFormat to xfReadable if you want
- // the stream to contain indentations to make the XML more human-readable. This
- // is not the default and also not compliant with the XML specification. See
- // SaveToFile for information on how to save in special encoding.
- procedure SaveToStream(Stream: TStream); virtual;
- // Call SaveToFile to save the XML document to a file with FileName. If the
- // filename exists, it will be overwritten without warning. If the file cannot
- // be created, a standard I/O exception will be generated. Set XmlFormat to
- // xfReadable if you want the file to contain indentations to make the XML
- // more human-readable. This is not the default and also not compliant with
- // the XML specification.<p>
- // Saving to special encoding types can be achieved by setting two properties
- // before saving:
- // * ExternalEncoding
- // * EncodingString
- // ExternalEncoding can be se8bit (for plain ascii), seUtf8 (UTF-8), seUtf16LE
- // (for unicode) or seUtf16BE (unicode big endian).<p> Do not forget to also
- // set the EncodingString (e.g. "UTF-8" or "UTF-16") which matches with your
- // ExternalEncoding.
- procedure SaveToFile(const FileName: string); virtual;
- // Call WriteToString to save the XML document to a string. Set XmlFormat to
- // xfReadable if you want the string to contain indentations to make the XML
- // more human-readable. This is not the default and also not compliant with
- // the XML specification.
- function WriteToString: string; virtual;
- // Set AbortParsing to True if you use the OnNodeNew and OnNodeLoaded events in
- // a SAX-like manner, and you want to abort the parsing process halfway. Example:
- // <code>
- // procedure MyForm.NativeXmlNodeLoaded(Sender: TObject; Node: TXmlNode);
- // begin
- // if (Node.Name = 'LastNode') and (Sender is TNativeXml) then
- // TNativeXml(Sender).AbortParsing := True;
- // end;
- // </code>
- property AbortParsing: boolean read FAbortParsing write FAbortParsing;
- // Choose what kind of binary encoding will be used when calling TXmlNode.BufferRead
- // and TXmlNode.BufferWrite. Default value is xbeBase64.
- property BinaryEncoding: TBinaryEncodingType read FBinaryEncoding write FBinaryEncoding;
- // A comment string above the root element <!--{comment}--> can be accessed with
- // this property. Assign a comment to this property to add it to the XML document.
- // Use property RootNodeList to add/insert/extract multiple comments.
- property CommentString: string read GetCommentString write SetCommentString;
- // Set DropCommentsOnParse if you're not interested in any comment nodes in your object
- // model data. All comments encountered during parsing will simply be skipped and
- // not added as a node with ElementType = xeComment (which is default). Note that
- // when you set this option, you cannot later reconstruct an XML file with the comments
- // back in place.
- property DropCommentsOnParse: boolean read FDropCommentsOnParse write FDropCommentsOnParse;
- // Encoding string (e.g. "UTF-8" or "UTF-16"). This encoding string is stored in
- // the header.
- // Example: In order to get this header:
- // <?xml version="1.0" encoding="UTF-16" ?>
- // enter this code:
- // <CODE>MyXmlDocument.EncodingString := 'UTF-16';</CODE>
- // When reading a file, EncodingString will contain the encoding used.
- property EncodingString: string read GetEncodingString write SetEncodingString;
- // Returns the value of the named entity in Name, where name should be stripped
- // of the leading & and trailing ;. These entity values are parsed from the
- // Doctype declaration (if any).
- property EntityByName[AName: string]: string read GetEntityByName;
- // ExternalEncoding defines in which format XML files are saved. Set ExternalEncoding
- // to se8bit to save as plain text files, to seUtf8 to save as UTF8 files (with
- // Byte Order Mark #EF BB FF) and to seUTF16LE to save as unicode (Byte Order
- // Mark #FF FE). When reading an XML file, the value of ExternalEncoding will
- // be set according to the byte order mark and/or encoding declaration found.
- property ExternalEncoding: TStringEncodingType read FExternalEncoding write FExternalEncoding;
- // When converting floating point values to strings (e.g. in WriteFloat),
- // NativeXml will allow to output scientific notation in some cases, if the
- // result is significantly shorter than normal output, but only if the value
- // of FloatAllowScientific is True (default).
- property FloatAllowScientific: boolean read FFloatAllowScientific write FFloatAllowScientific;
- // When converting floating point values to strings (e.g. in WriteFloat),
- // NativeXml will use this number of significant digits. The default is
- // cDefaultFloatSignificantDigits, and set to 6.
- property FloatSignificantDigits: integer read FFloatSignificantDigits write FFloatSignificantDigits;
- // IndentString is the string used for indentations. By default, it is two
- // spaces: ' '. Set IndentString to something else if you need to have
- // specific indentation, or set it to an empty string to avoid indentation.
- property IndentString: string read FIndentString write FIndentString;
- // Root is the topmost element in the XML document. Access Root to read any
- // child elements. When creating a new XML document, you can automatically
- // include a Root node, by creating using CreateName.
- property Root: TXmlNode read GetRoot;
- // RootNodeList can be used to directly access the nodes in the root of the
- // XML document. Usually this list consists of one declaration node followed
- // by a normal node which is the Root. You can use this property to add or
- // delete comments, stylesheets, dtd's etc.
- property RootNodeList: TXmlNode read FRootNodes;
- // Get the stylesheet node used for this XML document. If the node does not
- // exist yet, it will be created (thus if you use this property, and don't
- // set any of the attributes, an empty stylesheet node will be the result).
- property StyleSheetNode: TXmlNode read GetStyleSheetNode;
- // Set UseFullNodes to True before saving the XML document to ensure that all
- // nodes are represented by <Node>...</Node> instead of the short version
- // <Node/>. UseFullNodes is False by default.
- property UseFullNodes: boolean read FUseFullNodes write FUseFullNodes;
- // When Utf8Encoded is True, all strings inside the document represent
- // UTF-8 encoded strings. Use function ToWidestring to convert strings to
- // widestring (without loss) or ToAnsiString to convert to ANSI string
- // (with loss). When Utf8Encoded is False (default), all strings represent
- // normal ANSI strings. Set Utf8Encoded to True before adding info to the XML
- // file to ensure internal strings are all UTF-8. Use methods FromWidestring,
- // sdAnsiToUTF8 or sdUnicodeToUtf8 before setting any strings in that case.
- property Utf8Encoded: boolean read FUtf8Encoded write FUtf8Encoded;
- // After reading, this property contains the XML version (usually "1.0").
- property VersionString: string read GetVersionString write SetVersionString;
- // Set WriteOnDefault to False if you do not want to write default values to
- // the XML document. This option can avoid creating huge documents with
- // redundant info, and will speed up writing.
- property WriteOnDefault: boolean read FWriteOnDefault write FWriteOnDefault;
- // XmlFormat by default is set to xfCompact. This setting is compliant to the spec,
- // and NativeXml will only generate XML files with #$0A as control character.
- // By setting XmlFormat to xfReadable, you can generate easily readable XML
- // files that contain indentation and carriage returns after each element.
- property XmlFormat: TXmlFormatType read FXmlFormat write FXmlFormat;
- // ParserWarnings by default is True. If True, the parser will raise an
- // exception in cases where the XML document is not technically valid. If False,
- // the parser will try to ignore non-critical warnings. Set ParserWarnings
- // to False for some types of XML-based documents such as SOAP messages.
- property ParserWarnings: boolean read FParserWarnings write FParserWarnings;
- // SortAttributes by default is set to False. Attributes will appear in the
- // String list in the same order that they appear in the XML Document. Setting
- // this to true will cause the TStringList that holds the attributes to be sorted
- // This can help speed lookup and allow you to iterate the list looking for
- // specific attributes.
- property SortAttributes: boolean read FSortAttributes write FSortAttributes;
- // This event is called whenever a node's SortChildNodes method is called and
- // no direct compare method is provided. Implement this event if you want to
- // use object-event based methods for comparison of nodes.
- property OnNodeCompare: TXmlNodeCompareEvent read FOnNodeCompare write FOnNodeCompare;
- // This event is called whenever the parser has encountered a new node.
- property OnNodeNew: TXmlNodeEvent read FOnNodeNew write FOnNodeNew;
- // This event is called when the parser has finished parsing the node, and
- // has created its complete contents in memory.
- property OnNodeLoaded: TXmlNodeEvent read FOnNodeLoaded write FOnNodeLoaded;
- // OnProgress is called during loading and saving of the XML document. The
- // Size parameter contains the position in the stream. This event can be used
- // to implement a progress indicator during loading and saving. The event is
- // called after each node that is read or written.
- property OnProgress: TXmlProgressEvent read FOnProgress write FOnProgress;
- // This event is called if there is a warning for unicode conversion loss,
- // when reading from Unicode streams or files.
- property OnUnicodeLoss: TNotifyEvent read FOnUnicodeLoss write FOnUnicodeLoss;
- end;
- // This enumeration defines the conversion stream access mode.
- TsdStreamModeType = (
- umUnknown, // The stream access mode is not yet known
- umRead, // UTF stream opened for reading
- umWrite // UTF stream opened for writing
- );
- // TBigByteArray is an array of bytes like the standard TByteArray (windows
- // unit) but which can contain up to MaxInt bytes. This type helps avoiding
- // range check errors when working with buffers larger than 32768 bytes.
- TBigByteArray = array[0..MaxInt - 1] of byte;
- PBigByteArray = ^TBigByteArray;
- {$IFDEF CLR}
- // not implemented
- TsdBufferedStream = class(TStream)
- private
- FStream: TStream;
- FOwned: Boolean;
- protected
- procedure SetSize(NewSize: Int64); override;
- public
- constructor Create(AStream: TStream; Owned: Boolean = False);
- destructor Destroy; override;
- function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
- function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
- function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
- end;
- TsdBufferedReadStream = TsdBufferedStream;
- TsdBufferedWriteStream = TsdBufferedStream;
- {$ELSE}
- // TsdBufferedReadStream is a buffered stream that takes another TStream
- // and reads only buffer-wise from it, and reads to the stream are first
- // done from the buffer. This stream type can only support reading.
- TsdBufferedReadStream = class(TStream)
- private
- FStream: TStream;
- FBuffer: PBigByteArray;
- FPage: integer;
- FBufPos: integer;
- FBufSize: integer;
- FPosition: longint;
- FOwned: boolean;
- FMustCheck: boolean;
- protected
- procedure CheckPosition;
- public
- // Create the buffered reader stream by passing the source stream in AStream,
- // this source stream must already be initialized. If Owned is set to True,
- // the source stream will be freed by TsdBufferedReadStream.
- constructor Create(AStream: TStream; Owned: boolean{$IFDEF D4UP} = False{$ENDIF});
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- end;
- // TsdBufferedWriteStream is a buffered stream that takes another TStream
- // and writes only buffer-wise to it, and writes to the stream are first
- // done to the buffer. This stream type can only support writing.
- TsdBufferedWriteStream = class(TStream)
- private
- FStream: TStream;
- FBuffer: PBigByteArray;
- FBufPos: integer;
- FPosition: longint;
- FOwned: boolean;
- protected
- procedure Flush;
- public
- // Create the buffered writer stream by passing the destination stream in AStream,
- // this destination stream must already be initialized. If Owned is set to True,
- // the destination stream will be freed by TsdBufferedWriteStream.
- constructor Create(AStream: TStream; Owned: boolean{$IFDEF D4UP} = False{$ENDIF});
- destructor Destroy; override;
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- end;
- {$ENDIF}
- // TsdCodecStream is the base codec class for reading and writing encoded files.
- // See TsdAnsiStream and TsdUtf8Stream for more information.
- TsdCodecStream = class(TStream)
- private
- FBuffer: string; // Buffer that holds temporary utf8 characters
- FBufferPos: integer; // Current character in buffer
- FEncoding: TStringEncodingType; // Type of string encoding used for the external stream
- FMode: TsdStreamModeType; // Access mode of this UTF stream, determined after first read/write
- FPosMin1: integer; // Position for seek(-1)
- FPosMin2: integer; // Position for seek(-2)
- FStream: TStream; // Referenced stream
- FSwapByteOrder: boolean;
- FWarningUnicodeLoss: boolean; // There was a warning for a unicode conversion loss
- FWriteBom: boolean;
- FOnUnicodeLoss: TNotifyEvent; // This event is called if there is a warning for unicode conversion loss
- protected
- function ReadByte: byte; virtual;
- procedure StorePrevPositions; virtual;
- procedure WriteByte(const B: byte); virtual;
- procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); virtual;
- function InternalRead(var Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
- function InternalSeek(Offset: Longint; Origin: TSeekOrigin): Longint;
- function InternalWrite(const Buffer{$IFDEF CLR}: array of Byte{$ENDIF}; Offset, Count: Longint): Longint;
- {$IFDEF CLR}
- procedure SetSize(NewSize: Int64); override;
- {$ENDIF}
- public
- // Call Create to create a new TsdCodectream based on an input or output stream
- // in AStream. After the first Read, the input streamtype will be determined,
- // and the Encoding property will be set accordingly. When using Write to
- // write data to the referenced stream, the Encoding property must be set prior
- // to this, indicating what kind of stream to produce.
- constructor Create(AStream: TStream); virtual;
- // Read Count bytes from the referenced stream, and put them in Buffer. The function
- // returns the actual number of bytes read. The codec stream can only read
- // one byte at the time!
- {$IFDEF CLR}
- function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
- {$ELSE}
- function Read(var Buffer; Count: Longint): Longint; override;
- {$ENDIF}
- // Seek to a new position in the stream, with Origin as a reference. The codec
- // stream can not seek when writing, and when reading can only go back one
- // character, or return a position. Position returned is the position
- // in the referenced stream.
- {$IFDEF CLR}
- function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
- {$ELSE}
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- {$ENDIF}
- // Write Count bytes from Buffer to the referenced stream, The function
- // returns the actual number of bytes written.
- {$IFDEF CLR}
- function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
- {$ELSE}
- function Write(const Buffer; Count: Longint): Longint; override;
- {$ENDIF}
- // Set Encoding when writing to the preferred encoding of the output stream,
- // or read Encoding after reading the output stream to determine encoding type.
- property Encoding: TstringEncodingType read FEncoding write FEncoding;
- // Read this value after loading an XML file. It will be True if there was a
- // warning for a unicode conversion loss.
- property WarningUnicodeLoss: boolean read FWarningUnicodeLoss;
- // This event is called if there is a warning for unicode conversion loss.
- property OnUnicodeLoss: TNotifyEvent read FOnUnicodeLoss write FOnUnicodeLoss;
- end;
- // TsdAnsiStream is a conversion stream that will load ANSI, UTF8 or
- // Unicode files and convert them into ANSI only. The stream can
- // also save ANSI data as UTF8 or Unicode. When there is a conversion
- // problem, the conversion routine gives proper warnings through
- // WarningUnicodeLoss and OnUnicodeLoss.
- TsdAnsiStream = class(TsdCodecStream)
- protected
- function ReadByte: byte; override;
- procedure WriteByte(const B: byte); override;
- procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); override;
- end;
- // TsdUdf8tream is a conversion stream that will load ANSI, UTF8 or
- // Unicode files and convert them into UTF8 only. The stream can
- // also save UTF8 data as Ansi, UTF8 or Unicode.
- TsdUtf8Stream = class(TsdCodecStream)
- private
- protected
- function ReadByte: byte; override;
- procedure WriteByte(const B: byte); override;
- procedure WriteBuf(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: longint); override;
- end;
- // TsdSurplusReader is a simple class that can store a few surplus characters
- // and returns these first before reading from the underlying stream
- TsdSurplusReader = class
- private
- FStream: TStream;
- FSurplus: string;
- public
- constructor Create(AStream: TStream);
- property Surplus: string read FSurplus write FSurplus;
- function ReadChar(var Ch: char): integer;
- function ReadCharSkipBlanks(var Ch: char): boolean;
- end;
- // Simple string builder class that allocates string memory more effectively
- // to avoid repeated re-allocation
- TsdStringBuilder = class
- private
- FData: string;
- FCurrentIdx: integer;
- function GetData(Index: integer): Char;
- procedure Reallocate(RequiredLength: integer);
- public
- constructor Create;
- procedure Clear;
- procedure AddChar(Ch: Char);
- procedure AddString(var S: string);
- function StringCopy(AFirst, ALength: integer): string;
- function Value: string;
- property Length: integer read FCurrentIdx;
- property Data[Index: integer]: Char read GetData; default;
- end;
- // string functions
- // Escape all required characters in string AValue.
- function EscapeString(const AValue: string): string;
- // Replace all escaped characters in string AValue by their original. This includes
- // character references using &#...; and &#x...;
- function UnEscapeStringUTF8(const AValue: string): string;
- // Replace all escaped characters in string AValue by their original. This includes
- // character references using &#...; and &#x...;, however, character codes above
- // 255 are not replaced.
- function UnEscapeStringANSI(const AValue: string): string;
- // Enclose the string AValue in quotes.
- function QuoteString(const AValue: string): string;
- // Remove the quotes from string AValue.
- function UnQuoteString(const AValue: string): string;
- // This function adds control characters Chars repeatedly after each Interval
- // of characters to string Value.
- function AddControlChars(const AValue: string; const Chars: string; Interval: integer): string;
- // This function removes control characters from string AValue (Tab, CR, LF and Space)
- function RemoveControlChars(const AValue: string): string;
- // Convert the string ADate to a TDateTime according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- // If there is a conversion error, an exception will be raised.
- function sdDateTimeFromString(const ADate: string): TDateTime;
- // Convert the string ADate to a TDateTime according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- // If there is a conversion error, the default value ADefault is returned.
- function sdDateTimeFromStringDefault(const ADate: string; ADefault: TDateTime): TDateTime;
- // Convert the TDateTime ADate to a string according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- function sdDateTimeToString(ADate: TDateTime): string;
- // Convert a number to a string, using SignificantDigits to indicate the number of
- // significant digits, and AllowScientific to allow for scientific notation if that
- // results in much shorter notatoin.
- function sdWriteNumber(Value: double; SignificantDigits: integer; AllowScientific: boolean): string;
- // Conversion between Ansi, UTF8 and Unicode
- // Convert a widestring to a UTF8 encoded string
- function sdUnicodeToUtf8(const W: widestring): string;
- // Convert a normal ansi string to a UTF8 encoded string
- function sdAnsiToUtf8(const S: string): string;
- // Convert a UTF8 encoded string to a widestring
- function sdUtf8ToUnicode(const S: string): widestring;
- // Convert a UTF8 encoded string to a normal ansi string
- function sdUtf8ToAnsi(const S: string): string;
- // parse functions
- // Find SubString within string S, only process characters between Start and Close.
- // First occurrance is reported in APos. If something is found, function returns True.
- function FindString(const SubString: string; const S: string; Start, Close: integer; var APos: integer): boolean;
- // Detect if the SubString matches the characters in S from position Start. S may be
- // actually longer than SubString, only length(SubString) characters are checked.
- function MatchString(const SubString: string; const S: string; Start: integer): boolean;
- // Find all Name="Value" pairs in string AValue (from Start to Close - 1), and put
- // the resulting attributes in stringlist Attributes. This stringlist must already
- // be initialized when calling this function.
- procedure ParseAttributes(const AValue: string; Start, Close: integer; Attributes: TStrings);
- // Trim the string AValue between Start and Close - 1 (remove whitespaces at start
- // and end), not by adapting the string but by adjusting the Start and Close indices.
- // If the resulting string still has a length > 0, the function returns True.
- function TrimPos(const AValue: string; var Start, Close: integer): boolean;
- // Encoding/Decoding functions
- // Encode binary data in Source as BASE64. The function returns the BASE64 encoded
- // data as string, without any linebreaks.
- function EncodeBase64(const Source: string): string;
- // Decode BASE64 data in Source into binary data. The function returns the binary
- // data as string. Use a TStringStream to convert this data to a stream. The Source
- // string may contain linebreaks and control characters, these will be stripped.
- function DecodeBase64(const Source: string): string;
- // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
- // data as string, without any linebreaks.
- function EncodeBinHex(const Source: string): string;
- // Decode BINHEX data in Source into binary data. The function returns the binary
- // data as string. Use a TStringStream to convert this data to a stream. The Source
- // string may contain linebreaks and control characters, these will be stripped.
- function DecodeBinHex(const Source: string): string;
- {$IFDEF D4UP}
- resourcestring
- {$ELSE}
- const
- {$ENDIF}
- sxeErrorCalcStreamLength = 'Error while calculating streamlength';
- sxeMissingDataInBinaryStream = 'Missing data in binary stream';
- sxeMissingElementName = 'Missing element name';
- sxeMissingCloseTag = 'Missing close tag in element %s';
- sxeMissingDataAfterGreaterThan = 'Missing data after "<" in element %s';
- sxeMissingLessThanInCloseTag = 'Missing ">" in close tag of element %s';
- sxeIncorrectCloseTag = 'Incorrect close tag in element %s';
- sxeIllegalCharInNodeName = 'Illegal character in node name "%s"';
- sxeMoreThanOneRootElement = 'More than one root element found in xml';
- sxeMoreThanOneDeclaration = 'More than one xml declaration found in xml';
- sxeDeclarationMustBeFirstElem = 'Xml declaration must be first element';
- sxeMoreThanOneDoctype = 'More than one doctype declaration found in root';
- sxeDoctypeAfterRootElement = 'Doctype declaration found after root element';
- sxeNoRootElement = 'No root element found in xml';
- sxeIllegalElementType = 'Illegal element type';
- sxeCDATAInRoot = 'No CDATA allowed in root';
- sxeRootElementNotDefined = 'XML root element not defined.';
- sxeCodecStreamNotAssigned = 'Encoding stream unassigned';
- sxeUnsupportedEncoding = 'Unsupported string encoding';
- sxeCannotReadCodecForWriting = 'Cannot read from a conversion stream opened for writing';
- sxeCannotWriteCodecForReading = 'Cannot write to an UTF stream opened for reading';
- sxeCannotReadMultipeChar = 'Cannot read multiple chars from conversion stream at once';
- sxeCannotPerformSeek = 'Cannot perform seek on codec stream';
- sxeCannotSeekBeforeReadWrite = 'Cannot seek before reading or writing in conversion stream';
- sxeCannotSeek = 'Cannot perform seek in conversion stream';
- sxeCannotWriteToOutputStream = 'Cannot write to output stream';
- sxeXmlNodeNotAssigned = 'XML Node is not assigned';
- sxeCannotConverToBool = 'Cannot convert value to bool';
- sxeCannotConvertToFloat = 'Cannot convert value to float';
- sxeSignificantDigitsOutOfRange = 'Significant digits out of range';
- implementation
- {$IFDEF TRIALXML}
- uses
- Dialogs;
- {$ENDIF}
- type
- // Internal type
- TTagType = record
- FStart: string;
- FClose: string;
- FStyle: TXmlElementType;
- end;
- PByte = ^byte;
- TBomInfo = packed record
- BOM: array[0..3] of byte;
- Len: integer;
- Enc: TStringEncodingType;
- HasBOM: boolean;
- end;
- const
- // Count of different escape characters
- cEscapeCount = 5;
- // These are characters that must be escaped. Note that "&" is first since
- // when another would be replaced first (eg ">" by "<") this could
- // cause the new "&" in "<" to be replaced by "&";
- cEscapes: array[0..cEscapeCount - 1] of string =
- ('&', '<', '>', '''', '"');
- // These are the strings that replace the escape strings - in the same order
- cReplaces: array[0..cEscapeCount - 1] of string =
- ('&', '<', '>', ''', '"');
- cQuoteChars: set of char = ['"', ''''];
- cControlChars: set of char = [#9, #10, #13, #32]; {Tab, LF, CR, Space}
- // Count of different XML tags
- cTagCount = 12;
- cTags: array[0..cTagCount - 1] of TTagType = (
- // The order is important here; the items are searched for in appearing order
- (FStart: '<![CDATA['; FClose: ']]>'; FStyle: xeCData),
- (FStart: '<!DOCTYPE'; FClose: '>'; FStyle: xeDoctype),
- (FStart: '<!ELEMENT'; FClose: '>'; FStyle: xeElement),
- (FStart: '<!ATTLIST'; FClose: '>'; FStyle: xeAttList),
- (FStart: '<!ENTITY'; FClose: '>'; FStyle: xeEntity),
- (FStart: '<!NOTATION'; FClose: '>'; FStyle: xeNotation),
- (FStart: '<?xml-stylesheet'; FClose: '?>'; FStyle: xeStylesheet),
- (FStart: '<?xml'; FClose: '?>'; FStyle: xeDeclaration),
- (FStart: '<!--'; FClose: '-->'; FStyle: xeComment),
- (FStart: '<!'; FClose: '>'; FStyle: xeExclam),
- (FStart: '<?'; FClose: '?>'; FStyle: xeQuestion),
- (FStart: '<'; FClose: '>'; FStyle: xeNormal) );
- // direct tags are derived from Normal tags by checking for the />
- // These constant are used when generating hexchars from buffer data
- cHexChar: array[0..15] of char = '0123456789ABCDEF';
- cHexCharLoCase: array[0..15] of char = '0123456789abcdef';
- // These characters are used when generating BASE64 chars from buffer data
- cBase64Char: array[0..63] of char =
- 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
- cBase64PadChar: char = '=';
- // The amount of bytes to allocate with each increase of the value buffer
- cNodeValueBuf = 2048;
- // byte order marks for strings
- // Unicode text files should contain $FFFE as first character to identify such a file clearly. Depending on the system
- // where the file was created on this appears either in big endian or little endian style.
- const cBomInfoCount = 15;
- const cBomInfo: array[0..cBomInfoCount - 1] of TBomInfo =
- ( (BOM: ($00,$00,$FE,$FF); Len: 4; Enc: seUCS4BE; HasBOM: true),
- (BOM: ($FF,$FE,$00,$00); Len: 4; Enc: seUCS4LE; HasBOM: true),
- (BOM: ($00,$00,$FF,$FE); Len: 4; Enc: seUCS4_2143; HasBOM: true),
- (BOM: ($FE,$FF,$00,$00); Len: 4; Enc: seUCS4_3412; HasBOM: true),
- (BOM: ($FE,$FF,$00,$00); Len: 2; Enc: seUTF16BE; HasBOM: true),
- (BOM: ($FF,$FE,$00,$00); Len: 2; Enc: seUTF16LE; HasBOM: true),
- (BOM: ($EF,$BB,$BF,$00); Len: 3; Enc: seUTF8; HasBOM: true),
- (BOM: ($00,$00,$00,$3C); Len: 4; Enc: seUCS4BE; HasBOM: false),
- (BOM: ($3C,$00,$00,$00); Len: 4; Enc: seUCS4LE; HasBOM: false),
- (BOM: ($00,$00,$3C,$00); Len: 4; Enc: seUCS4_2143; HasBOM: false),
- (BOM: ($00,$3C,$00,$00); Len: 4; Enc: seUCS4_3412; HasBOM: false),
- (BOM: ($00,$3C,$00,$3F); Len: 4; Enc: seUTF16BE; HasBOM: false),
- (BOM: ($3C,$00,$3F,$00); Len: 4; Enc: seUTF16LE; HasBOM: false),
- (BOM: ($3C,$3F,$78,$6D); Len: 4; Enc: se8Bit; HasBOM: false),
- (BOM: ($4C,$6F,$A7,$94); Len: 4; Enc: seEBCDIC; HasBOM: false)
- );
- // .NET compatible stub for TBytes (array of byte) type
- {$IFNDEF CLR}
- type
- TBytes = TBigByteArray;
- {$ENDIF}
- // Delphi 3 and below stubs
- {$IFNDEF D4UP}
- function StringReplace(const S, OldPattern, NewPattern: string;
- Flags: TReplaceFlags): string;
- var
- SearchStr, Patt, NewStr: string;
- Offset: Integer;
- begin
- if rfIgnoreCase in Flags then
- begin
- SearchStr := UpperCase(S);
- Patt := UpperCase(OldPattern);
- end else
- begin
- SearchStr := S;
- Patt := OldPattern;
- end;
- NewStr := S;
- Result := '';
- while SearchStr <> '' do
- begin
- Offset := Pos(Patt, SearchStr);
- if Offset = 0 then
- begin
- Result := Result + NewStr;
- Break;
- end;
- Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
- NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
- if not (rfReplaceAll in Flags) then
- begin
- Result := Result + NewStr;
- Break;
- end;
- SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
- end;
- end;
- function StrToInt64Def(const AValue: string; ADefault: int64): int64;
- begin
- Result := StrToIntDef(AValue, ADefault);
- end;
- function StrToInt64(const AValue: string): int64;
- begin
- Result := StrToInt(AValue);
- end;
- {$ENDIF}
- // Delphi 4 stubs
- {$IFNDEF D5UP}
- function AnsiPos(const Substr, S: string): Integer;
- begin
- Result := Pos(Substr, S);
- end;
- function AnsiQuotedStr(const S: string; Quote: Char): string;
- var
- P, Src, Dest: PChar;
- AddCount: Integer;
- begin
- AddCount := 0;
- P := StrScan(PChar(S), Quote);
- while P <> nil do begin
- Inc(P);
- Inc(AddCount);
- P := StrScan(P, Quote);
- end;
- if AddCount = 0 then begin
- Result := Quote + S + Quote;
- Exit;
- end;
- SetLength(Result, Length(S) + AddCount + 2);
- Dest := Pointer(Result);
- Dest^ := Quote;
- Inc(Dest);
- Src := Pointer(S);
- P := StrScan(Src, Quote);
- repeat
- Inc(P);
- Move(Src^, Dest^, P - Src);
- Inc(Dest, P - Src);
- Dest^ := Quote;
- Inc(Dest);
- Src := P;
- P := StrScan(Src, Quote);
- until P = nil;
- P := StrEnd(Src);
- Move(Src^, Dest^, P - Src);
- Inc(Dest, P - Src);
- Dest^ := Quote;
- end;
- function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
- var
- P, Dest: PChar;
- DropCount: Integer;
- begin
- Result := '';
- if (Src = nil) or (Src^ <> Quote) then Exit;
- Inc(Src);
- DropCount := 1;
- P := Src;
- Src := StrScan(Src, Quote);
- while Src <> nil do begin
- Inc(Src);
- if Src^ <> Quote then Break;
- Inc(Src);
- Inc(DropCount);
- Src := StrScan(Src, Quote);
- end;
- if Src = nil then Src := StrEnd(P);
- if ((Src - P) <= 1) then Exit;
- if DropCount = 1 then
- SetString(Result, P, Src - P - 1)
- else begin
- SetLength(Result, Src - P - DropCount);
- Dest := PChar(Result);
- Src := StrScan(P, Quote);
- while Src <> nil do begin
- Inc(Src);
- if Src^ <> Quote then Break;
- Move(P^, Dest^, Src - P);
- Inc(Dest, Src - P);
- Inc(Src);
- P := Src;
- Src := StrScan(Src, Quote);
- end;
- if Src = nil then Src := StrEnd(P);
- Move(P^, Dest^, Src - P - 1);
- end;
- end;
- procedure FreeAndNil(var Obj);
- var
- P: TObject;
- begin
- P := TObject(Obj);
- TObject(Obj) := nil;
- P.Free;
- end;
- {$ENDIF}
- // .NET-compatible TStream.Write
- function StreamWrite(Stream: TStream; const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Offset, Count: Longint): Longint;
- begin
- {$IFDEF CLR}
- Result := Stream.Write(Buffer, Offset, Count);
- {$ELSE}
- Result := Stream.Write(TBytes(Buffer)[Offset], Count);
- {$ENDIF}
- end;
- {$IFNDEF CLR}
- // Delphi's implementation of TStringStream is severely flawed, it does a SetLength
- // on each write, which slows down everything to a crawl. This implementation over-
- // comes this issue.
- type
- TsdStringStream = class(TMemoryStream)
- public
- constructor Create(const S: string);
- function DataString: string;
- end;
- constructor TsdStringStream.Create(const S: string);
- begin
- inherited Create;
- SetSize(length(S));
- if Size > 0 then begin
- Write(S[1], Size);
- Position := 0;
- end;
- end;
- function TsdStringStream.DataString: string;
- begin
- SetLength(Result, Size);
- if Size > 0 then begin
- Position := 0;
- Read(Result[1], length(Result));
- end;
- end;
- {$ELSE}
- // In .NET we use the standard TStringStream
- type
- TsdStringStream = TStringStream;
- {$ENDIF}
- // Utility functions
- function Min(A, B: integer): integer;
- begin
- if A < B then Result := A else Result := B;
- end;
- function Max(A, B: integer): integer;
- begin
- if A > B then Result := A else Result := B;
- end;
- function EscapeString(const AValue: string): string;
- var
- i: integer;
- begin
- Result := AValue;
- for i := 0 to cEscapeCount - 1 do
- Result := StringReplace(Result, cEscapes[i], cReplaces[i], [rfReplaceAll]);
- end;
- function UnEscapeStringUTF8(const AValue: string): string;
- var
- SearchStr, Reference, Replace: string;
- i, Offset, Code: Integer;
- W: word;
- begin
- SearchStr := AValue;
- Result := '';
- while SearchStr <> '' do begin
- // find '&'
- Offset := AnsiPos('&', SearchStr);
- if Offset = 0 then begin
- // Nothing found
- Result := Result + SearchStr;
- Break;
- end;
- Result := Result + Copy(SearchStr, 1, Offset - 1);
- SearchStr := Copy(SearchStr, Offset, MaxInt);
- // find next ';'
- Offset := AnsiPos(';', SearchStr);
- if Offset = 0 then begin
- // Error: encountered a '&' but not a ';'.. we will ignore, just return
- // the unmodified value
- Result := Result + SearchStr;
- Break;
- end;
- // Reference
- Reference := copy(SearchStr, 1, Offset);
- SearchStr := Copy(SearchStr, Offset + 1, MaxInt);
- Replace := Reference;
- // See if it is a character reference
- if copy(Reference, 1, 2) = '&#' then begin
- Reference := copy(Reference, 3, length(Reference) - 3);
- if length(Reference) > 0 then begin
- if lowercase(Reference[1]) = 'x' then
- // Hex notation
- Reference[1] := '$';
- Code := StrToIntDef(Reference, -1);
- if (Code >= 0) and (Code < $FFFF) then begin
- W := Code;
- {$IFDEF D5UP}
- Replace := sdUnicodeToUtf8(WideChar(W));
- {$ELSE}
- Replace := char(W and $FF);
- {$ENDIF}
- end;
- end;
- end else begin
- // Look up default escapes
- for i := 0 to cEscapeCount - 1 do
- if Reference = cReplaces[i] then begin
- // Replace
- Replace := cEscapes[i];
- Break;
- end;
- end;
- // New result
- Result := Result + Replace;
- end;
- end;
- function UnEscapeStringANSI(const AValue: string): string;
- var
- SearchStr, Reference, Replace: string;
- i, Offset, Code: Integer;
- B: byte;
- begin
- SearchStr := AValue;
- Result := '';
- while SearchStr <> '' do begin
- // find '&'
- Offset := AnsiPos('&', SearchStr);
- if Offset = 0 then begin
- // Nothing found
- Result := Result + SearchStr;
- Break;
- end;
- Result := Result + Copy(SearchStr, 1, Offset - 1);
- SearchStr := Copy(SearchStr, Offset, MaxInt);
- // find next ';'
- Offset := AnsiPos(';', SearchStr);
- if Offset = 0 then begin
- // Error: encountered a '&' but not a ';'.. we will ignore, just return
- // the unmodified value
- Result := Result + SearchStr;
- Break;
- end;
- // Reference
- Reference := copy(SearchStr, 1, Offset);
- SearchStr := Copy(SearchStr, Offset + 1, MaxInt);
- Replace := Reference;
- // See if it is a character reference
- if copy(Reference, 1, 2) = '&#' then begin
- Reference := copy(Reference, 3, length(Reference) - 3);
- if length(Reference) > 0 then begin
- if lowercase(Reference[1]) = 'x' then
- // Hex notation
- Reference[1] := '$';
- Code := StrToIntDef(Reference, -1);
- if (Code >= 0) and (Code < $FF) then begin
- B := Code;
- Replace := char(B);
- end;
- end;
- end else begin
- // Look up default escapes
- for i := 0 to cEscapeCount - 1 do
- if Reference = cReplaces[i] then begin
- // Replace
- Replace := cEscapes[i];
- Break;
- end;
- end;
- // New result
- Result := Result + Replace;
- end;
- end;
- function QuoteString(const AValue: string): string;
- var
- AQuoteChar: char;
- begin
- AQuoteChar := '"';
- if Pos('"', AValue) > 0 then
- AQuoteChar := '''';
- {$IFDEF CLR}
- Result := QuotedStr(AValue, AQuoteChar);
- {$ELSE}
- Result := AnsiQuotedStr(AValue, AQuoteChar);
- {$ENDIF}
- end;
- function UnQuoteString(const AValue: string): string;
- {$IFNDEF CLR}
- var
- P: PChar;
- {$ENDIF}
- begin
- if Length(AValue) < 2 then begin
- Result := AValue;
- exit;
- end;
- if AValue[1] in cQuoteChars then begin
- {$IFDEF CLR}
- Result := DequotedStr(AValue, AValue[1]);
- {$ELSE}
- P := PChar(AValue);
- Result := AnsiExtractQuotedStr(P, AValue[1]);
- {$ENDIF}
- end else
- Result := AValue;
- end;
- function AddControlChars(const AValue: string; const Chars: string; Interval: integer): string;
- // Insert Chars in AValue at each Interval chars
- var
- i, j, ALength: integer;
- // local
- procedure InsertControlChars;
- var
- k: integer;
- begin
- for k := 1 to Length(Chars) do begin
- Result[j] := Chars[k];
- inc(j);
- end;
- end;
- // main
- begin
- if (Length(Chars) = 0) or (Interval <= 0) then begin
- Result := AValue;
- exit;
- end;
- // Calculate length based on original length and total extra length for control chars
- ALength := Length(AValue) + ((Length(AValue) - 1) div Interval + 3) * Length(Chars);
- SetLength(Result, ALength);
- // Copy and insert
- j := 1;
- for i := 1 to Length(AValue) do begin
- if (i mod Interval) = 1 then begin
- // Insert control chars
- InsertControlChars;
- end;
- Result[j] := AValue[i];
- inc(j);
- end;
- InsertControlChars;
- // Adjust length
- dec(j);
- if ALength > j then
- SetLength(Result, j);
- end;
- function RemoveControlChars(const AValue: string): string;
- // Remove control characters from string in AValue
- var
- i, j: integer;
- begin
- Setlength(Result, Length(AValue));
- i := 1;
- j := 1;
- while i <= Length(AValue) do
- if AValue[i] in cControlChars then
- inc(i)
- else begin
- Result[j] := AValue[i];
- inc(i);
- inc(j);
- end;
- // Adjust length
- if i <> j then
- SetLength(Result, j - 1);
- end;
- function FindString(const SubString: string; const S: string; Start, Close: integer; var APos: integer): boolean;
- // Check if the Substring matches the string S in any position in interval Start to Close - 1
- // and returns found positon in APos. Result = True if anything is found.
- // Note: this funtion is case-insensitive
- var
- CharIndex: integer;
- begin
- Result := False;
- APos := 0;
- for CharIndex := Start to Close - Length(SubString) do
- if MatchString(SubString, S, CharIndex) then begin
- APos := CharIndex;
- Result := True;
- exit;
- end;
- end;
- function MatchString(const SubString: string; const S: string; Start: integer): boolean;
- // Check if the Substring matches the string S at position Start.
- // Note: this funtion is case-insensitive
- var
- CharIndex: integer;
- begin
- Result := False;
- // Check range just in case
- if (Length(S) - Start + 1) < Length(Substring) then exit;
- CharIndex := 0;
- while CharIndex < Length(SubString) do
- if Upcase(SubString[CharIndex + 1]) = Upcase(S[Start + CharIndex]) then
- inc(CharIndex)
- else
- exit;
- // All chars were the same, so we succeeded
- Result := True;
- end;
- procedure ParseAttributes(const AValue: string; Start, Close: integer; Attributes: TStrings);
- // Convert the attributes string AValue in [Start, Close - 1] to the attributes stringlist
- var
- i: integer;
- InQuotes: boolean;
- AQuoteChar: char;
- begin
- InQuotes := False;
- AQuoteChar := '"';
- if not assigned(Attributes) then exit;
- if not TrimPos(AValue, Start, Close) then exit;
- // Clear first
- Attributes.Clear;
- // Loop through characters
- for i := Start to Close - 1 do begin
- // In quotes?
- if InQuotes then begin
- if AValue[i] = AQuoteChar then
- InQuotes := False;
- end else begin
- if AValue[i] in cQuoteChars then begin
- InQuotes := True;
- AQuoteChar := AValue[i];
- end;
- end;
- // Add attribute strings on each controlchar break
- if not InQuotes then
- if AValue[i] in cControlChars then begin
- if i > Start then
- Attributes.Add(copy(AValue, Start, i - Start));
- Start := i + 1;
- end;
- end;
- // Add last attribute string
- if Start < Close then
- Attributes.Add(copy(AValue, Start, Close - Start));
- // First-char "=" signs should append to previous
- for i := Attributes.Count - 1 downto 1 do
- if Attributes[i][1] = '=' then begin
- Attributes[i - 1] := Attributes[i - 1] + Attributes[i];
- Attributes.Delete(i);
- end;
- // First-char quotes should append to previous
- for i := Attributes.Count - 1 downto 1 do
- if (Attributes[i][1] in cQuoteChars) and (Pos('=', Attributes[i - 1]) > 0) then begin
- Attributes[i - 1] := Attributes[i - 1] + Attributes[i];
- Attributes.Delete(i);
- end;
- end;
- function TrimPos(const AValue: string; var Start, Close: integer): boolean;
- // Trim the string in AValue in [Start, Close - 1] by adjusting Start and Close variables
- begin
- // Checks
- Start := Max(1, Start);
- Close := Min(Length(AValue) + 1, Close);
- if Close <= Start then begin
- Result := False;
- exit;
- end;
- // Trim left
- while
- (Start < Close) and
- (AValue[Start] in cControlChars) do
- inc(Start);
- // Trim right
- while
- (Start < Close) and
- (AValue[Close - 1] in cControlChars) do
- dec(Close);
- // Do we have a string left?
- Result := Close > Start;
- end;
- procedure WriteStringToStream(S: TStream; const AString: string);
- begin
- if Length(AString) > 0 then
- {$IFDEF CLR}
- S.Write(BytesOf(AString), Length(AString));
- {$ELSE}
- S.Write(AString[1], Length(AString));
- {$ENDIF}
- end;
- function ReadOpenTag(AReader: TsdSurplusReader): integer;
- // Try to read the type of open tag from S
- var
- AIndex, i: integer;
- Found: boolean;
- Ch: char;
- Candidates: array[0..cTagCount - 1] of boolean;
- Surplus: string;
- begin
- Surplus := '';
- Result := cTagCount - 1;
- for i := 0 to cTagCount - 1 do Candidates[i] := True;
- AIndex := 1;
- repeat
- Found := False;
- inc(AIndex);
- if AReader.ReadChar(Ch) = 0 then
- exit;
- Surplus := Surplus + Ch;
- for i := cTagCount - 1 downto 0 do
- if Candidates[i] and (length(cTags[i].FStart) >= AIndex) then begin
- if cTags[i].FStart[AIndex] = Ch then begin
- Found := True;
- if length(cTags[i].FStart) = AIndex then
- Result := i;
- end else
- Candidates[i] := False;
- end;
- until Found = False;
- // The surplus string that we already read (everything after the tag)
- AReader.Surplus := copy(Surplus, length(cTags[Result].FStart), length(Surplus));
- end;
- function ReadStringFromStreamUntil(AReader: TsdSurplusReader; const ASearch: string;
- var AValue: string; SkipQuotes: boolean): boolean;
- var
- AIndex, ValueIndex, SearchIndex: integer;
- LastSearchChar, Ch: char;
- InQuotes: boolean;
- QuoteChar: Char;
- SB: TsdStringBuilder;
- begin
- Result := False;
- InQuotes := False;
- // Get last searchstring character
- AIndex := length(ASearch);
- if AIndex = 0 then exit;
- LastSearchChar := ASearch[AIndex];
- SB := TsdStringBuilder.Create;
- try
- QuoteChar := #0;
- repeat
- // Add characters to the value to be returned
- if AReader.ReadChar(Ch) = 0 then exit;
- SB.AddChar(Ch);
- // Do we skip quotes?
- if SkipQuotes then begin
- if InQuotes then begin
- if (Ch = QuoteChar) then
- InQuotes := false;
- end else begin
- if Ch in cQuoteChars then begin
- InQuotes := true;
- QuoteChar := Ch;
- end;
- end;
- end;
- // In quotes? If so, we don't check the end condition
- if not InQuotes then begin
- // Is the last char the same as the last char of the search string?
- if Ch = LastSearchChar then begin
- // Check to see if the whole search string is present
- ValueIndex := SB.Length - 1;
- SearchIndex := length(ASearch) - 1;
- if ValueIndex < SearchIndex then continue;
- Result := True;
- while (SearchIndex > 0)and Result do begin
- Result := SB[ValueIndex] = ASearch[SearchIndex];
- dec(ValueIndex);
- dec(SearchIndex);
- end;
- end;
- end;
- until Result;
- // Use only the part before the search string
- AValue := SB.StringCopy(1, SB.Length - length(ASearch));
- finally
- SB.Free;
- end;
- end;
- function ReadStringFromStreamWithQuotes(S: TStream; const Terminator: string;
- var AValue: string): boolean;
- var
- Ch, QuoteChar: char;
- InQuotes: boolean;
- SB: TsdStringBuilder;
- begin
- SB := TsdStringBuilder.Create;
- try
- QuoteChar := #0;
- Result := False;
- InQuotes := False;
- repeat
- if S.Read(Ch, 1) = 0 then exit;
- if not InQuotes then begin
- if (Ch = '"') or (Ch = '''') then begin
- InQuotes := True;
- QuoteChar := Ch;
- end;
- end else begin
- if Ch = QuoteChar then
- InQuotes := False;
- end;
- if not InQuotes and (Ch = Terminator) then
- break;
- SB.AddChar(Ch);
- until False;
- AValue := SB.Value;
- Result := True;
- finally
- SB.Free;
- end;
- end;
- function sdDateTimeFromString(const ADate: string): TDateTime;
- // Convert the string ADate to a TDateTime according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- var
- AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word;
- begin
- AYear := StrToInt(copy(ADate, 1, 4));
- AMonth := StrToInt(copy(ADate, 6, 2));
- ADay := StrToInt(copy(ADate, 9, 2));
- if Length(ADate) > 16 then begin // Suggestion JH
- AHour := StrToInt(copy(ADate, 12, 2));
- AMin := StrToInt(copy(ADate, 15, 2));
- ASec := StrToIntDef(copy(ADate, 18, 2), 0); // They might be omitted, so default to 0
- AMSec := StrToIntDef(copy(ADate, 21, 3), 0); // They might be omitted, so default to 0
- end else begin
- AHour := 0;
- AMin := 0;
- ASec := 0;
- AMSec := 0;
- end;
- Result :=
- EncodeDate(AYear, AMonth, ADay) +
- EncodeTime(AHour, AMin, ASec, AMSec);
- end;
- function sdDateTimeFromStringDefault(const ADate: string; ADefault: TDateTime): TDateTime;
- // Convert the string ADate to a TDateTime according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- // If there is a conversion error, the default value ADefault is returned.
- begin
- try
- Result := sdDateTimeFromString(ADate);
- except
- Result := ADefault;
- end;
- end;
- function sdDateTimeToString(ADate: TDateTime): string;
- // Convert the TDateTime ADate to a string according to the W3C date/time specification
- // as found here: http://www.w3.org/TR/NOTE-datetime
- var
- AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word;
- begin
- DecodeDate(ADate, AYear, AMonth, ADay);
- DecodeTime(ADate, AHour, AMin, ASec, AMSec);
- if frac(ADate) = 0 then begin
- Result := Format('%.4d-%.2d-%.2d', [AYear, AMonth, ADay]);
- end else begin
- Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d.%.3dZ',
- [AYear, AMonth, ADay, AHour, AMin, ASec, AMSec]);
- end;
- end;
- function sdWriteNumber(Value: double; SignificantDigits: integer; AllowScientific: boolean): string;
- const
- Limits: array[1..9] of integer =
- (10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000);
- var
- Limit, Limitd, PointPos, IntVal, ScPower: integer;
- Body: string;
- begin
- if (SignificantDigits < 1) or (SignificantDigits > 9) then
- raise Exception.Create(sxeSignificantDigitsOutOfRange);
- // Zero
- if Value = 0 then begin
- Result := '0';
- exit;
- end;
- // Sign
- if Value < 0 then begin
- Result := '-';
- Value := -Value;
- end else
- Result := '';
- // Determine point position
- Limit := Limits[SignificantDigits];
- Limitd := Limit div 10;
- PointPos := SignificantDigits;
- while Value < Limitd do begin
- Value := Value * 10;
- dec(PointPos);
- end;
- while Value >= Limit do begin
- Value := Value * 0.1;
- inc(PointPos);
- end;
- // Round
- IntVal := round(Value);
- // Strip off any zeros, these reduce significance count
- while (IntVal mod 10 = 0) and (PointPos < SignificantDigits) do begin
- dec(SignificantDigits);
- IntVal := IntVal div 10;
- end;
- // Check for scientific notation
- ScPower := 0;
- if AllowScientific and ((PointPos < -1) or (PointPos > SignificantDigits + 2)) then begin
- ScPower := PointPos - 1;
- dec(PointPos, ScPower);
- end;
- // Body
- Body := IntToStr(IntVal);
- while PointPos > SignificantDigits do begin
- Body := Body + '0';
- inc(SignificantDigits);
- end;
- while PointPos < 0 do begin
- Body := '0' + Body;
- inc(PointPos);
- end;
- if PointPos = 0 then
- Body := '.' + Body
- else if PointPos < SignificantDigits then
- Body := copy(Body, 1, PointPos) + '.' + copy(Body, PointPos + 1, SignificantDigits);
- // Final result
- if ScPower = 0 then
- Result := Result + Body
- else
- Result := Result + Body + 'E' + IntToStr(ScPower);
- end;
- {$IFDEF CLR}
- function sdUnicodeToUtf8(const W: widestring): string;
- begin
- Result := Encoding.UTF8.GetBytes(W);
- end;
- function sdUtf8ToUnicode(const S: string): widestring;
- begin
- Result := Encoding.UTF8.GetString(BytesOf(S));
- end;
- function EncodeBase64Buf(const Buffer: TBytes; Count: Integer): string;
- begin
- Result := Convert.ToBase64String(Buffer, 0, Count);
- end;
- function EncodeBase64(const Source: string): string;
- begin
- Result := Convert.ToBase64String(BytesOf(Source));
- end;
- procedure DecodeBase64Buf(const Source: string; var Buffer: TBytes; Count: Integer);
- var
- ADecoded: TBytes;
- begin
- ADecoded := Convert.FromBase64String(Source);
- if Count > Length(ADecoded) then
- raise EFilerError.Create(sxeMissingDataInBinaryStream);
- SetLength(ADecoded, Count);
- Buffer := ADecoded;
- end;
- function DecodeBase64(const Source: string): string;
- begin
- Result := AnsiString(Convert.FromBase64String(Source));
- end;
- {$ELSE}
- function PtrUnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
- var
- i, count: Cardinal;
- c: Cardinal;
- begin
- Result := 0;
- if not assigned(Source) or not assigned(Dest) then exit;
- count := 0;
- i := 0;
- while (i < SourceChars) and (count < MaxDestBytes) do begin
- c := Cardinal(Source[i]);
- Inc(i);
- if c <= $7F then begin
- Dest[count] := Char(c);
- Inc(count);
- end else
- if c > $7FF then begin
- if count + 3 > MaxDestBytes then
- break;
- Dest[count] := Char($E0 or (c shr 12));
- Dest[count+1] := Char($80 or ((c shr 6) and $3F));
- Dest[count+2] := Char($80 or (c and $3F));
- Inc(count,3);
- end else begin // $7F < Source[i] <= $7FF
- if count + 2 > MaxDestBytes then
- break;
- Dest[count] := Char($C0 or (c shr 6));
- Dest[count+1] := Char($80 or (c and $3F));
- Inc(count,2);
- end;
- end;
- if count >= MaxDestBytes then
- count := MaxDestBytes-1;
- Dest[count] := #0;
- Result := count + 1; // convert zero based index to byte count
- end;
- function PtrUtf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar;
- SourceBytes: Cardinal): Cardinal;
- var
- i, count: Cardinal;
- c: Byte;
- wc: Cardinal;
- begin
- if not assigned(Dest) or not assigned(Source) then begin
- Result := 0;
- Exit;
- end;
- Result := Cardinal(-1);
- count := 0;
- i := 0;
- while (i < SourceBytes) and (count < MaxDestChars) do begin
- wc := Cardinal(Source[i]);
- Inc(i);
- if (wc and $80) <> 0 then begin
- if i >= SourceBytes then
- // incomplete multibyte char
- Exit;
- wc := wc and $3F;
- if (wc and $20) <> 0 then begin
- c := Byte(Source[i]);
- Inc(i);
- if (c and $C0) <> $80 then
- // malformed trail byte or out of range char
- Exit;
- if i >= SourceBytes then
- // incomplete multibyte char
- Exit;
- wc := (wc shl 6) or (c and $3F);
- end;
- c := Byte(Source[i]);
- Inc(i);
- if (c and $C0) <> $80 then
- // malformed trail byte
- Exit;
- Dest[count] := WideChar((wc shl 6) or (c and $3F));
- end else
- Dest[count] := WideChar(wc);
- Inc(count);
- end;
- if count >= MaxDestChars then
- count := MaxDestChars-1;
- Dest[count] := #0;
- Result := count + 1;
- end;
- function sdUnicodeToUtf8(const W: widestring): string;
- var
- L: integer;
- Temp: string;
- begin
- Result := '';
- if W = '' then Exit;
- SetLength(Temp, Length(W) * 3); // SetLength includes space for null terminator
- L := PtrUnicodeToUtf8(PChar(Temp), Length(Temp) + 1, PWideChar(W), Length(W));
- if L > 0 then
- SetLength(Temp, L - 1)
- else
- Temp := '';
- Result := Temp;
- end;
- function sdUtf8ToUnicode(const S: string): widestring;
- var
- L: Integer;
- Temp: WideString;
- begin
- Result := '';
- if S = '' then Exit;
- SetLength(Temp, Length(S));
- L := PtrUtf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S));
- if L > 0 then
- SetLength(Temp, L-1)
- else
- Temp := '';
- Result := Temp;
- end;
- function EncodeBase64Buf(const Buffer; Count: Integer): string;
- var
- i, j: integer;
- ACore: integer;
- ALong: cardinal;
- S: PByte;
- begin
- // Make sure ASize is always a multiple of 3, and this multiple
- // gets saved as 4 characters
- ACore := (Count + 2) div 3;
- // Set the length of the string that stores encoded characters
- SetLength(Result, ACore * 4);
- S := @Buffer;
- // Do the loop ACore times
- for i := 0 to ACore - 1 do begin
- ALong := 0;
- for j := 0 to 2 do begin
- ALong := ALong shl 8 + S^;
- inc(S);
- end;
- for j := 0 to 3 do begin
- Result[i * 4 + 4 - j] := cBase64Char[ALong and $3F];
- ALong := ALong shr 6;
- end;
- end;
- // For comformity to Base64, we must pad the data instead of zero out
- // if the size is not an exact multiple of 3
- case ACore * 3 - Count of
- 0:;// nothing to do
- 1: // pad one byte
- Result[ACore * 4] := cBase64PadChar;
- 2: // pad two bytes
- begin
- Result[ACore * 4 ] := cBase64PadChar;
- Result[ACore * 4 - 1] := cBase64PadChar;
- end;
- end;//case
- end;
- function EncodeBase64(const Source: string): string;
- // Encode binary data in Source as BASE64. The function returns the BASE64 encoded
- // data as string, without any linebreaks.
- begin
- if length(Source) > 0 then
- Result := EncodeBase64Buf(Source[1], length(Source))
- else
- Result := '';
- end;
- procedure DecodeBase64Buf(var Source: string; var Buffer; Count: Integer);
- var
- i, j: integer;
- APos, ACore: integer;
- ALong: cardinal;
- D: PByte;
- Map: array[Char] of byte;
- begin
- // Core * 4 is the number of chars to read - check length
- ACore := Length(Source) div 4;
- if Count > ACore * 3 then
- raise EFilerError.Create(sxeMissingDataInBinaryStream);
- // Prepare map
- for i := 0 to 63 do
- Map[cBase64Char[i]] := i;
- D := @Buffer;
- // Check for final padding, and replace with "zeros". There can be
- // at max two pad chars ('=')
- APos := length(Source);
- if (APos > 0) and (Source[APos] = cBase64PadChar) then begin
- Source[APos] := cBase64Char[0];
- dec(APos);
- if (APos > 0) and (Source[APos] = cBase64PadChar) then
- Source[APos] := cBase64Char[0];
- end;
- // Do this ACore times
- for i := 0 to ACore - 1 do begin
- ALong := 0;
- // Unroll the characters
- for j := 0 to 3 do
- ALong := ALong shl 6 + Map[Source[i * 4 + j + 1]];
- // and unroll the bytes
- for j := 2 downto 0 do begin
- // Check overshoot
- if integer(D) - integer(@Buffer) >= Count then
- exit;
- D^ := ALong shr (j * 8) and $FF;
- inc(D);
- end;
- end;
- end;
- function DecodeBase64(const Source: string): string;
- // Decode BASE64 data in Source into binary data. The function returns the binary
- // data as string. Use a TStringStream to convert this data to a stream.
- var
- AData: string;
- ASize, APos: integer;
- begin
- AData := RemoveControlChars(Source);
- // Determine length of data
- ASize := length(AData) div 4;
- if ASize * 4 <> length(AData) then
- raise EFilerError.Create(sxeErrorCalcStreamLength);
- ASize := ASize * 3;
- // Check padding chars
- APos := length(AData);
- if (APos > 0) and (AData[APos] = cBase64PadChar) then begin
- dec(APos);
- dec(ASize);
- if (APos > 0) and (AData[APos] = cBase64PadChar) then
- dec(ASize);
- end;
- Setlength(Result, ASize);
- // Decode
- if ASize > 0 then
- DecodeBase64Buf(AData, Result[1], ASize);
- end;
- {$ENDIF}
- function sdAnsiToUtf8(const S: string): string;
- begin
- Result := sdUnicodeToUtf8(S);
- end;
- function sdUtf8ToAnsi(const S: string): string;
- begin
- Result := sdUtf8ToUnicode(S);
- end;
- function EncodeBinHexBuf(const Source; Count: Integer): string;
- // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
- // data as string, without any linebreaks.
- var
- {$IFDEF CLR}
- Text: TBytes;
- {$ELSE}
- Text: string;
- {$ENDIF}
- begin
- SetLength(Text, Count * 2);
- {$IFDEF CLR}
- BinToHex(TBytes(Source), 0, Text, 0, Count);
- {$ELSE}
- {$IFDEF D4UP}
- BinToHex(PChar(@Source), PChar(Text), Count);
- {$ELSE}
- raise Exception.Create(sxeUnsupportedEncoding);
- {$ENDIF}
- {$ENDIF}
- Result := Text;
- end;
- function EncodeBinHex(const Source: string): string;
- // Encode binary data in Source as BINHEX. The function returns the BINHEX encoded
- // data as string, without any linebreaks.
- var
- {$IFDEF CLR}
- Text: TBytes;
- {$ELSE}
- Text: string;
- {$ENDIF}
- begin
- SetLength(Text, Length(Source) * 2);
- {$IFDEF CLR}
- BinToHex(BytesOf(Source), 0, Text, 0, Length(Source));
- {$ELSE}
- {$IFDEF D4UP}
- BinToHex(PChar(Source), PChar(Text), Length(Source));
- {$ELSE}
- raise Exception.Create(sxeUnsupportedEncoding);
- {$ENDIF}
- {$ENDIF}
- Result := Text;
- end;
- procedure DecodeBinHexBuf(const Source: string; var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
- // Decode BINHEX data in Source into binary data.
- begin
- if Length(Source) div 2 < Count then
- raise EFilerError.Create(sxeMissingDataInBinaryStream);
- {$IFDEF CLR}
- HexToBin(BytesOf(Source), 0, Buffer, 0, Count);
- {$ELSE}
- {$IFDEF D4UP}
- HexToBin(PChar(Source), PChar(@Buffer), Count);
- {$ELSE}
- raise Exception.Create(sxeUnsupportedEncoding);
- {$ENDIF}
- {$ENDIF}
- end;
- function DecodeBinHex(const Source: string): string;
- // Decode BINHEX data in Source into binary data. The function returns the binary
- // data as string. Use a TStringStream to convert this data to a stream.
- var
- AData: string;
- ASize: integer;
- {$IFDEF CLR}
- Buffer: TBytes;
- {$ELSE}
- Buffer: string;
- {$ENDIF}
- begin
- AData := RemoveControlChars(Source);
- // Determine length of data
- ASize := length(AData) div 2;
- if ASize * 2 <> length(AData) then
- raise EFilerError.Create(sxeErrorCalcStreamLength);
- SetLength(Buffer, ASize);
- {$IFDEF CLR}
- HexToBin(BytesOf(AData), 0, Buffer, 0, ASize);
- {$ELSE}
- {$IFDEF D4UP}
- HexToBin(PChar(AData), PChar(Buffer), ASize);
- {$ELSE}
- raise Exception.Create(sxeUnsupportedEncoding);
- {$ENDIF}
- {$ENDIF}
- Result := Buffer;
- end;
- function sdStringToBool(const AValue: string): boolean;
- var
- Ch: Char;
- begin
- if Length(AValue) > 0 then begin
- Ch := UpCase(AValue[1]);
- if Ch in ['T', 'Y'] then begin
- Result := True;
- exit;
- end;
- if Ch in ['F', 'N'] then begin
- Result := False;
- exit;
- end;
- end;
- raise Exception.Create(sxeCannotConverToBool);
- end;
- function sdStringFromBool(ABool: boolean): string;
- const
- cBoolValues: array[boolean] of string = ('False', 'True');
- begin
- Result := cBoolValues[ABool];
- end;
- { TXmlNode }
- procedure TXmlNode.Assign(Source: TPersistent);
- var
- i: integer;
- ANode: TXmlNode;
- begin
- if Source is TXmlNode then begin
- // Clear first
- Clear;
- // Properties
- FElementType := TXmlNode(Source).FElementType;
- FName := TXmlNode(Source).FName;
- FTag := TXmlNode(Source).FTag;
- FValue := TXmlNode(Source).FValue;
- // Attributes
- if assigned(TXmlNode(Source).FAttributes) then begin
- CheckCreateAttributesList;
- FAttributes.Assign(TXmlNode(Source).FAttributes);
- end;
- // Nodes
- for i := 0 to TXmlNode(Source).NodeCount - 1 do begin
- ANode := NodeNew('');
- ANode.Assign(TXmlNode(Source).Nodes[i]);
- end;
- end else if Source is TNativeXml then begin
- Assign(TNativeXml(Source).FRootNodes);
- end else
- inherited;
- end;
- procedure TXmlNode.AttributeAdd(const AName, AValue: string);
- var
- Attr: string;
- begin
- Attr := Format('%s=%s', [AName, QuoteString(EscapeString(AValue))]);
- CheckCreateAttributesList;
- FAttributes.Add(Attr);
- end;
- {$IFDEF D4UP}
- procedure TXmlNode.AttributeAdd(const AName: string; AValue: integer);
- begin
- AttributeAdd(AName, IntToStr(AValue));
- end;
- {$ENDIF}
- procedure TXmlNode.AttributeDelete(Index: integer);
- begin
- if (Index >= 0) and (Index < AttributeCount) then
- FAttributes.Delete(Index);
- end;
- procedure TXmlNode.AttributeExchange(Index1, Index2: integer);
- var
- Temp: string;
- begin
- if (Index1 <> Index2) and
- (Index1 >= 0) and (Index1 < FAttributes.Count) and
- (Index2 >= 0) and (Index2 < FAttributes.Count) then
- begin
- Temp := FAttributes[Index1];
- FAttributes[Index1] := FAttributes[Index2];
- FAttributes[Index2] := Temp;
- end;
- end;
- function TXmlNode.AttributeIndexByname(const AName: string): integer;
- // Return the index of the attribute with name AName, or -1 if not found
- var
- i: integer;
- begin
- Result := -1;
- for i := 0 to AttributeCount - 1 do
- if AnsiCompareText(AttributeName[i], AName) = 0 then begin
- Result := i;
- exit;
- end;
- end;
- procedure TXmlNode.AttributesClear;
- begin
- FreeAndNil(FAttributes);
- end;
- function TXmlNode.BufferLength: integer;
- var
- AData: string;
- APos: integer;
- begin
- AData := RemoveControlChars(FValue);
- case BinaryEncoding of
- xbeBinHex:
- begin
- Result := length(AData) div 2;
- if Result * 2 <> length(AData) then
- raise EFilerError.Create(sxeErrorCalcStreamLength);
- end;
- xbeBase64:
- begin
- Result := length(AData) div 4;
- if Result * 4 <> length(AData) then
- raise EFilerError.Create(sxeErrorCalcStreamLength);
- Result := Result * 3;
- // Check padding chars
- APos := length(AData);
- if (APos > 0) and (AData[APos] = cBase64PadChar) then begin
- dec(APos);
- dec(Result);
- if (APos > 0) and (AData[APos] = cBase64PadChar) then
- dec(Result);
- end;
- end;
- else
- Result := 0; // avoid compiler warning
- end;
- end;
- procedure TXmlNode.BufferRead(var Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
- // Read data from XML binhex to the buffer
- var
- AData: string;
- begin
- AData := RemoveControlChars(FValue);
- case BinaryEncoding of
- xbeBinHex:
- DecodeBinHexBuf(AData, Buffer, Count);
- xbeBase64:
- DecodeBase64Buf(AData, Buffer, Count);
- end;
- end;
- procedure TXmlNode.BufferWrite(const Buffer{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer);
- // Write data from the buffer to XML in binhex format
- var
- AData: string;
- begin
- if Count > 0 then
- case BinaryEncoding of
- xbeBinHex:
- AData := EncodeBinHexBuf(Buffer, Count);
- xbeBase64:
- AData := EncodeBase64Buf(Buffer, Count);
- end;
- // For comformity with Base64, we must add linebreaks each 76 characters
- FValue := AddControlChars(AData, GetLineFeed + GetIndent, 76);
- end;
- procedure TXmlNode.CheckCreateAttributesList;
- begin
- if not assigned(FAttributes) then begin
- FAttributes := TStringList.Create;
- if assigned(FDocument) then
- FAttributes.Sorted := FDocument.SortAttributes;
- end;
- end;
- procedure TXmlNode.Clear;
- begin
- // Name + value
- FName := '';
- FValue := '';
- // Clear attributes and nodes
- AttributesClear;
- NodesClear;
- end;
- function TXmlNode.CompareNodeName(const NodeName: string): integer;
- begin
- // Compare with FullPath or local name based on NodeName's first character
- if length(NodeName) > 0 then
- if NodeName[1] = '/' then begin
- // FullPath
- Result := AnsiCompareText(FullPath, NodeName);
- exit;
- end;
- // local name
- Result := AnsiCompareText(Name, NodeName);
- end;
- constructor TXmlNode.Create(ADocument: TNativeXml);
- begin
- inherited Create;
- FDocument := ADocument;
- end;
- constructor TXmlNode.CreateName(ADocument: TNativeXml;
- const AName: string);
- begin
- Create(ADocument);
- Name := AName;
- end;
- constructor TXmlNode.CreateNameValue(ADocument: TNativeXml; const AName,
- AValue: string);
- begin
- Create(ADocument);
- Name := AName;
- ValueAsString := AValue;
- end;
- constructor TXmlNode.CreateType(ADocument: TNativeXml;
- AType: TXmlElementType);
- begin
- Create(ADocument);
- FElementType := AType;
- end;
- procedure TXmlNode.Delete;
- begin
- if assigned(Parent) then
- Parent.NodeRemove(Self);
- end;
- procedure TXmlNode.DeleteEmptyNodes;
- var
- i: integer;
- ANode: TXmlNode;
- begin
- for i := NodeCount - 1 downto 0 do begin
- ANode := Nodes[i];
- // Recursive call
- ANode.DeleteEmptyNodes;
- // Check if we should delete child node
- if ANode.IsEmpty then
- NodeDelete(i);
- end;
- end;
- destructor TXmlNode.Destroy;
- begin
- NodesClear;
- AttributesClear;
- inherited;
- end;
- function TXmlNode.FindNode(const NodeName: string): TXmlNode;
- // Find the first node which has name NodeName. Contrary to the NodeByName
- // function, this function will search the whole subnode tree, using the
- // DepthFirst method.
- var
- i: integer;
- begin
- Result := nil;
- // Loop through all subnodes
- for i := 0 to NodeCount - 1 do begin
- Result := Nodes[i];
- // If the subnode has name NodeName then we have a result, exit
- if Result.CompareNodeName(NodeName) = 0 then
- exit;
- // If not, we will search the subtree of this node
- Result := Result.FindNode(NodeName);
- if assigned(Result) then
- exit;
- end;
- end;
- procedure TXmlNode.FindNodes(const NodeName: string; const AList: TList);
- // local
- procedure FindNodesRecursive(ANode: TXmlNode; AList: TList);
- var
- i: integer;
- begin
- with ANode do
- for i := 0 to NodeCount - 1 do begin
- if Nodes[i].CompareNodeName(NodeName) = 0 then
- AList.Add(Nodes[i]);
- FindNodesRecursive(Nodes[i], AList);
- end;
- end;
- // main
- begin
- AList.Clear;
- FindNodesRecursive(Self, AList);
- end;
- function TXmlNode.FloatAllowScientific: boolean;
- begin
- if assigned(Document) then
- Result := Document.FloatAllowScientific
- else
- Result := cDefaultFloatAllowScientific;
- end;
- function TXmlNode.FloatSignificantDigits: integer;
- begin
- if assigned(Document) then
- Result := Document.FloatSignificantDigits
- else
- Result := cDefaultFloatSignificantDigits;
- end;
- function TXmlNode.FromAnsiString(const s: string): string;
- begin
- if Utf8Encoded then
- Result := sdAnsiToUtf8(s)
- else
- Result := s;
- end;