ADDED ZPreview/src/Delphi/Common/L_VersionInfoW.pas Index: ZPreview/src/Delphi/Common/L_VersionInfoW.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/L_VersionInfoW.pas @@ -0,0 +1,149 @@ +unit L_VersionInfoW; + +interface + +uses + Windows, SysUtils; + +type + TFileVersionInfo = class + private + { Private declarations } + FFilename : WideString; + FHasVersionInfo : boolean; + + FCompanyName : WideString; + FFileDescription : WideString; + FFileVersion : WideString; + FInternalname : WideString; + FLegalCopyright : WideString; + FLegalTradeMarks : WideString; + FOriginalFilename : WideString; + FProductName : WideString; + FProductVersion : WideString; + FComments : WideString; + FMajorVersion : Word; + FMinorVersion : Word; + FRevision : Word; + FBuild : Word; + + procedure SetFileName(AFileName: WideString); + protected + { Protected declarations } + public + { Public declarations } + constructor Create(AFileName: WideString); + destructor Destroy; override; + + property FileName : WideString read FFileName write SetFileName; + property HasVersionInfo : boolean read FHasVersionInfo; + published + { Published declarations } + property CompanyName : WideString read FCompanyName; + property FileDescription : WideString read FFileDescription; + property FileVersion : WideString read FFileVersion; + property Internalname : WideString read FInternalname; + property LegalCopyright : WideString read FLegalCopyright; + property LegalTradeMarks : WideString read FLegalTradeMarks; + property OriginalFilename : WideString read FOriginalFilename; + property ProductName : WideString read FProductName; + property ProductVersion : WideString read FProductVersion; + property Comments : WideString read FComments; + property MajorVersion : Word read FMajorVersion; + property MinorVersion : Word read FMinorVersion; + property Revision : Word read FRevision; + property Build : Word read FBuild; + end; + +implementation + +type + TLangAndCP = record + wLanguage : word; + wCodePage : word; + end; + PLangAndCP = ^TLangAndCP; + +constructor TFileVersionInfo.Create(AFileName: WideString); +begin + inherited Create; + SetFileName(AFileName); +end; + +destructor TFileVersionInfo.Destroy; +begin + inherited Destroy; +end; + +procedure TFileVersionInfo.SetFileName(AFileName: WideString); +var + Dummy : cardinal; + BufferSize: integer; + Buffer : Pointer; + Lang : PLangAndCP; + SubBlock : WideString; + InfoBlock : VS_FIXEDFILEINFO; + InfoPtr : Pointer; + function QueryValue(AName: WideString): WideString; + var + Value : PWChar; + begin + SubBlock := WideFormat('\\StringFileInfo\\%.4x%.4x\\%s', [Lang.wLanguage, Lang.wCodePage, AName]); + VerQueryValueW(Buffer, PWChar(SubBlock), Pointer(Value), Dummy); + Result := WideString(Value); + end; +begin + FFilename := AFileName; + + BufferSize := GetFileVersionInfoSizeW(PWChar(AFileName), Dummy); + FHasVersionInfo := (Buffersize > 0); + if FHasVersionInfo then begin + Buffer := AllocMem(BufferSize); + try + GetFileVersionInfoW(PWChar(AFileName),0,BufferSize,Buffer); + + SubBlock := '\\VarFileInfo\\Translation'; + VerQueryValueW(Buffer, PWChar(SubBlock), Pointer(Lang), Dummy); + + FCompanyName := QueryValue('CompanyName'); + FFileDescription := QueryValue('FileDescription'); + FFileVersion := QueryValue('FileVersion'); + FInternalName := QueryValue('InternalName'); + FLegalCopyright := QueryValue('LegalCopyright'); + FLegalTradeMarks := QueryValue('LegalTradeMarks'); + FOriginalFilename := QueryValue('OriginalFilename'); + FProductName := QueryValue('ProductName'); + FProductVersion := QueryValue('ProductVersion'); + FComments := QueryValue('Comments'); + + VerQueryValue(Buffer, '\', InfoPtr, Dummy); + Move(InfoPtr^, InfoBlock, SizeOf(VS_FIXEDFILEINFO)); + FMajorVersion := InfoBlock.dwFileVersionMS shr 16; + FMinorVersion := InfoBlock.dwFileVersionMS and 65535; + FRevision := InfoBlock.dwFileVersionLS shr 16; + FBuild := InfoBlock.dwFileVersionLS and 65535; + finally + FreeMem(Buffer,BufferSize); + end; + end + else begin + FCompanyname := ''; + FFileDescription := ''; + FFileVersion := ''; + FInternalname := ''; + FLegalCopyright := ''; + FLegalTradeMarks := ''; + FOriginalFilename := ''; + FProductName := ''; + FProductVersion := ''; + FComments := ''; + FMajorVersion := 0; + FMinorVersion := 0; + FRevision := 0; + FBuild := 0; + end; +end; + + +end. + ADDED ZPreview/src/Delphi/Common/NativeXml/NOTICE.txt Index: ZPreview/src/Delphi/Common/NativeXml/NOTICE.txt ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NOTICE.txt @@ -0,0 +1,3 @@ +SimDesign NativeXml +Copyright 2003-2010 SimDesign BV +This product includes software developed at SimDesign BV (http://www.simdesign.nl). ADDED ZPreview/src/Delphi/Common/NativeXml/NativeXml.pas Index: ZPreview/src/Delphi/Common/NativeXml/NativeXml.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NativeXml.pas @@ -0,0 +1,7210 @@ +unit NativeXml; + +interface + +{$i simdesign.inc} +uses + Graphics, + Classes, + Contnrs, + SysUtils, + sdStreams, + sdStringTable, + sdDebug, + NativeXmlCodepages, +{$IFDEF MSWINDOWS} + Windows, WinInet; +{$ELSE} + NativeXmlUtilsForLinux; +{$ENDIF} + +const + + // Current version of the NativeXml unit + cNativeXmlVersion = 'v3.32'; + cNativeXmlDate = '18feb2015'; + +type + // An event that is used to indicate load or save progress. + TXmlProgressEvent = procedure(Sender: TObject; Position: int64) of object; + + // TsdElementType enumerates the different kinds of elements that can be found + // in the XML document. + TsdElementType = ( + xeElement, // Normal element [value][sub-elements] + xeAttribute, // Attribute ( name='value' or name="value") + xeComment, // Comment + xeCData, // literal data + xeCondSection, // conditional section + xeDeclaration, // XML declaration + xeStylesheet, // Stylesheet + xeDocType, // DOCTYPE DTD declaration + xeDtdElement, // + xeDtdAttList, // + xeDtdEntity, // + xeDtdNotation, // + xeInstruction, // processing instruction + xeCharData, // Character data in a node + xeWhiteSpace, // chardata with only whitespace + xeQuotedText, // "bla" or 'bla' + xeUnknown, // Any + xeEndTag, // + xeError // some error + ); + + TsdElementTypes = set of TsdElementType; + + // Definition of different methods of string encoding. + TsdStringEncoding = ( + seAnsi, // Ansi encoding, e.g. "Windows-1252" or other codepage (1 byte per character) + seUTF8, // UTF-8 (1, 2, 3 or 4 bytes per character) + seUTF16BE, // UTF-16 Big Endian (2 or 4 bytes per character) + seUTF16LE, // UTF-16 Little Endian (2 or 4 bytes per character) + seUTF32BE, // ucs-4 Big Endian (4 bytes per character) + seUTF32LE, // ucs-4 Little Endian (4 bytes per character) + seUCS4_2143, // UCS-4 unusual octet order - 2143 (4 bytes per character) + seUCS4_3412, // UCS-4 unusual octet order - 3412 (4 bytes per character) + seEBCDIC // Extended Binary Coded Decimal Interchange Code (1 byte per character) + ); + + // Choose what kind of binary encoding will be used when calling + // TXmlNode BufferRead and BufferWrite. + TsdBinaryEncoding = ( + xbeBase64, { With this encoding, each group of 3 bytes are stored as 4 + characters, requiring 64 different characters. - DEFAULT} + xbeBinHex { With this encoding, each byte is stored as a hexadecimal + number, e.g. 0 = 00 and 255 = FF. } + ); + + // Node closing style: + // ncDefault defaults to what is parsed per element + // ncFull looks like and + // ncClose looks like + // ncUnknown defaults to what is parsed per element + TsdNodeClosingStyle = ( + ncDefault, + ncFull, + ncClose + ); + + // End-Of-Line style + TsdEolStyle = ( + esLinux, // write End-Of-Line as just LF (#$0A) + esWindows // write End-Of-Line as CR + LF (#$0D + #$0A) + ); + + // Note on TNativeXml.XmlFormat: + // - xfCompact (default) to save the xml fully compliant and at smallest size + // - xfReadable writes additional nonsignificant whitespace so the client can + // easily read the xml file with a standard editor. + // - xfPreserve aims to preserve whitespace data just as it is parsed + TsdXmlFormatType = ( + xfCompact, // Save without any control chars except LF after declaration + xfReadable, // Save in readable format with indents and end-of-lines + xfPreserve // Preserve whitespace whenever possible + ); + + // record with info from a Byte order Mark (BOM) + TsdBomInfo = packed record + BOM: array[0..3] of byte; // 4 bytes possibly containing the BOM + Len: integer; // byte length of the BOM + Encoding: TsdStringEncoding; // which string encoding does the file have? + HasBOM: boolean; // does a file have a BOM? + end; + + TXmlCompareOption = ( + xcNodeName, + xcNodeType, + xcNodeValue, + xcAttribCount, + xcAttribNames, + xcAttribValues, + xcChildCount, + xcChildNames, + xcChildValues, + xcRecursive + ); + + TXmlCompareOptions = set of TXmlCompareOption; + + // codepage information (name and codepage record) + TCodepageInfo = packed record + Name: Utf8String; + Codepage: integer; + end; + + // default charset names for TsdStringEncoding +const + + cStringEncodingCharsetNames: array[TsdStringEncoding] of Utf8String = + ('ansi', + 'utf-8', + 'unicodeFFFE', + 'utf-16', + 'utf-32BE', + 'utf-32', + 'ucs4_2143', + 'ucs4_3412', + 'ebcdic'); + + // default codecs for TsdStringEncoding if no codepage is given + cStringEncodingCodePages: array[TsdStringEncoding] of integer = + ( 0 {ansi can be any codepage}, + 65001 {utf-8}, + 1201 {unicodeFFFE}, + 1200 {utf-16}, + 12001 {utf-32BE}, + 12000 {utf-32}, + 0 {no codepage for UCS4_2143}, + 0 {no codepage for UCS4_3412}, + 0 {ebcdic can be any codepage}); + + // all xml compare options + xcAll: TXmlCompareOptions = [xcNodeName, xcNodeType, xcNodeValue, xcAttribCount, + xcAttribNames, xcAttribValues, xcChildCount, xcChildNames, xcChildValues, + xcRecursive]; + + // "signature" that defines the binary XML file/stream + cBinaryXmlCookie: array[0..3] of AnsiChar = '$BXM'; + +// Delphi unicode compatibility +{$ifndef UNICODE} +type + UnicodeString = WideString; + RawByteString = AnsiString; +{$endif UNICODE} + +type + // XML buffered parser. It buffers the source stream into + // a memory buffer of limited size and reads from the stream chunk-wise. + // This way, it can do string comparisons in memory, directly on the buffer. + TsdXmlParser = class(TsdDebugPersistent) + protected + FBomInfo: TsdBomInfo; + FSource: TStream; + FChunkSize: integer; + FRawBuffer: array of byte; // raw data buffer + FUtf8Buffer: array of AnsiChar; // utf8 data buffer + FEncoding: TsdStringEncoding; + FCodePage: integer; + FRawFirstIdx: integer; + FRawLastIdx: integer; + FUtf8FirstIdx: integer; + FUtf8CurrentIdx: integer; + FUtf8LastIdx: integer; + FUtf8BasePosition: int64; + FBaseLineNumber: int64; + FEndOfStream: boolean; + FNormaliseEOLEnabled: boolean; + FOnDebugOut: TsdDebugEvent; + function LoCase(Ch: AnsiChar): AnsiChar; + procedure IncCurrentIdxCheck(var BytesAvail: integer); + function ReadString(AIndex, ACount: integer): Utf8String; + function ReadNextChunk: integer; + procedure EncodeChunk; + function GetPosition: int64; + function GetLineNumber: int64; + procedure SetCodePage(const Value: integer); + public + constructor Create(ASource: TStream; AChunkSize: integer); virtual; + destructor Destroy; override; + property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut; + property Owner: TsdDebugComponent read FOwner write FOwner; + // Call flush once in a while, to check if data can be flushed out. Flushing + // means that the part before the current pointer is removed and the bytes + // following are moved to 0 position. It is only actually done when enough + // chunks are read, and the flushing happens chunk-wise. + procedure Flush(Force: boolean = False); + // Is the stream from binary xml? + function IsBinaryXml: boolean; + // Make at least one byte available from current position + function MakeDataAvailable: integer; + // Get the next character from the stream + function NextChar: AnsiChar; + // collapse all EOL to #$0A + procedure NormaliseEOL; + // Check if the stream at this position contains string S. If so, the stream + // will be positioned after, if not, it will remain where it is. + function CheckString(const S: Utf8String): boolean; + // Move one position back in the stream + procedure MoveBack; + // Read a string from the stream until Terminator is found. The string returned + // will be the part before Terminator, the stream is positioned after Terminator + function ReadStringUntil(const Terminator: Utf8String): Utf8String; + // Read a quoted string from the stream, return the unquoted string + function ReadQuotedString(AQuote: AnsiChar): Utf8String; + // Read a string from the stream until character AChar is encountered. + // var EOS will be True if the stream reached the end. + function ReadStringUntilChar(AChar: AnsiChar): Utf8String; + // The encoding detected in the source stream (valid after ReadBOM or after + // the declaration). + property Encoding: TsdStringEncoding read FEncoding write FEncoding; + // CodePage used in text processing + property CodePage: integer read FCodePage write SetCodePage; + // Position in the stream in bytes from the start. + property Position: int64 read GetPosition; + // Line number in the stream. Lines are detected by analysing the stream + // for occurances of #13 (CR). The line number is *calculated* when this + // property is read, so it should not be read very regularly. + property LineNumber: int64 read GetLineNumber; + // Is the end of the stream detected? + property EndOfStream: boolean read FEndOfStream; + + // Special parser procedures to parse XML content. + + // Read the next character, skip any blanks inbetween. Blanks are: + // #$09, #$0A, #$0D, #$20 + function NextCharSkipBlanks(var Blanks: Utf8String): AnsiChar; + // Read BOM (Byte Order Mark) from the start of the file in order to detect which + // encoding is used. + procedure ReadBOM; + // Read an new tag from the stream (from the position afer "<") + function ReadOpenTag: TsdElementType; + // Read a string from the stream until a blank char, or a "/" or a ">" is + // encountered. + function ReadStringUntilBlankOrEndTag: Utf8String; + // Info from Byte Order Mark (BOM) + property BomInfo: TsdBomInfo read FBomInfo; + end; + + // specialized buffered writer that obeys encoding and codepage + TsdXmlWriter = class(TsdBufferWriter) + private + FOwner: TsdDebugComponent; + FRawBuffer: array of byte; + FRawBufferSize: integer; + procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); + public + FEncoding: TsdStringEncoding; + FCodePage: integer; + // overridden Write for all supported encodings (ansi, utf8, utf16le, utf16be) + function Write(const Buffer; Count: Longint): Longint; override; + constructor Create(AOwner: TsdDebugComponent; ASource: TStream; AChunkSize: integer); + destructor Destroy; override; + end; + + // Forward declaration TsdAttribute (needed by TXmlNode) + TsdAttribute = class; + + // TXmlNode metaclass + TsdNodeClass = class of TXmlNode; + + // Forward declaration of TNativeXml + TNativeXml = class; + + // Forward declaration of TXmlNode + TXmlNode = class; + + // 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): integer; + + // TXmlNode is the ancestor for all nodes in the xml document. See TsdElement + // for the elements, TsdAttribute for the attributes. + TXmlNode = class(TsdDebugPersistent) + private + // inherited from TDebugPersistent: FOwner: TDebugComponent + FParent: TXmlNode; + function GetAttributeByName(const AName: Utf8String): TsdAttribute; + function GetAttributeValueByName(const AName: Utf8String): Utf8String; + function GetAttributeValueByNameWide(const AName: Utf8String): UnicodeString; + procedure SetAttributeValueByName(const AName, Value: Utf8String); + procedure SetAttributeValueByNameWide(const AName: Utf8String; const Value: UnicodeString); + function GetBinaryString: RawByteString; + procedure SetBinaryString(const Value: RawByteString); + function GetValueUnicode: UnicodeString; + procedure SetValueUnicode(const Value: UnicodeString); + function GetAttributes(Index: integer): TsdAttribute; + function GetAttributeName(Index: integer): Utf8String; + function GetAttributeValue(Index: integer): Utf8String; + procedure SetAttributeName(Index: integer; const Value: Utf8String); + procedure SetAttributeValue(Index: integer; const Value: Utf8String); + function GetAttributeValueAsInteger(Index: integer): integer; + procedure SetAttributeValueAsInteger(Index: integer; const Value: integer); + function GetWriteOnDefault: boolean; + procedure SetWriteOnDefault(const Value: boolean); + function GetName: Utf8String; virtual; + function GetNameUnicode: UnicodeString; virtual; + function GetValue: Utf8String; virtual; + procedure SetName(const Value: Utf8String); virtual; + procedure SetNameUnicode(const Value: UnicodeString); virtual; + procedure SetValue(const Value: Utf8String); virtual; + procedure DoProgress(Position: int64); + function GetParentNode(ADepth: integer): TXmlNode; + function GetEolStyle: TsdEolStyle; + function GetPreserveWhiteSpace: boolean; + function GetSkipNormalisation: boolean; + function GetXmlFormat: TsdXmlFormatType; + procedure DoNodeNew(ANode: TXmlNode); + procedure DoNodeLoaded(ANode: TXmlNode); + function GetContent: Utf8String; virtual; + function GetDirectNodeCount: integer; virtual; + function GetContainerCount: integer; virtual; + function GetContainers(Index: integer): TXmlNode; virtual; + function GetDocument: TNativeXml; + protected + FTag: pointer; + FSourcePos: int64; + // string table lookup methods + function GetString(AID: integer): Utf8String; + function AddString(const S: Utf8String): integer; + function GetNodeCount: integer; virtual; + function GetAttributeCount: integer; virtual; + function GetNodes(Index: integer): TXmlNode; virtual; + class function EscapeString(const S: Utf8String): Utf8String; + class function ReplaceString(const S: Utf8String): Utf8String; + function GetIndent: Utf8String; virtual; + function GetEndOfLine: Utf8String; virtual; + function GetSeparator: Utf8String; virtual; + function NodeIndexByName(const AName: Utf8String): integer; virtual; + procedure WriteValue(const AName, AValue: Utf8String); virtual; + procedure WriteContent(S: TStream); virtual; + // copy the data and subnodes from ANode; this node is cleared first + procedure CopyFrom(ANode: TXmlNode); virtual; + function CompareNodeName(const NodeName: Utf8String): integer; + function GetFullPath: Utf8String; + property WriteOnDefault: boolean read GetWriteOnDefault write SetWriteOnDefault; + function GetParentNodeName(ADepth: integer): Utf8String; + public + // for compat: assign to source XmlNode + procedure Assign(Source: TPersistent); override; + // Create a new node object. AOwner must be the TNativeXml that is + // going to hold this new node. Make sure to use the correct class when + // creating, e.g. TsdElement.Create(Owner) for an element. + constructor Create(AOwner: TNativeXml); virtual; + // Create a new TXmlNode with name AName. AOwner must be the TNativeXml + // that is going to hold this new node. + constructor CreateName(AOwner: TNativeXml; const AName: Utf8String); virtual; + // Create a new TXmlNode with name AName and UTF8String value AValue. AOwner + // must be the TNativeXml that is going to hold this new node. + constructor CreateNameValue(AOwner: TNativeXml; const AName, AValue: Utf8String); virtual; + // Convert the Utf8String S to a UnicodeString + class function Utf8ToWide(const S: Utf8String): UnicodeString; + // Convert the UnicodeString W to an Utf8String + class function WideToUtf8(const W: UnicodeString): Utf8String; + // parse this node with parser P, result is the endnode and should be identical + function ParseStream(Parser: TsdXmlParser): TXmlNode; virtual; + // write this node to stream S + procedure WriteStream(S: TStream); virtual; + // The element type + function ElementType: TsdElementType; virtual; + // name of the element type + function ElementTypeName: Utf8String; virtual; + // write the node to a Utf8String + function WriteToString: Utf8String; + // Pointer to the owner document NativeXml + property Document: TNativeXml read GetDocument; + // Tag is a pointer 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. + property Tag: pointer read FTag write FTag; + // SourcePos (int64) points to the position in the source file where the + // nodes text begins. + property SourcePos: int64 read FSourcePos write FSourcePos; + // Parent points to the parent node of the current XML node. + property Parent: TXmlNode read FParent; + // 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; + // clear the node + procedure Clear; virtual; + // recursively delete empty nodes + procedure DeleteEmptyNodes; virtual; + // 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; + // This function returns True if the node has no subnodes and no attributes, + // and if the node value is empty. + function IsEmpty: boolean; + // Test whether ANode is equal to another node based on compare options. If + // MismatchNodes is provided, a list of mismatching subnodes is filled. + function IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; + MismatchNodes: TList = nil): boolean; + // Use this method to add an attribute with name AName and string value AValue + // to the node. AName and AValue must be UTF8 encoded. + procedure AttributeAdd(const AName, AValue: Utf8String); overload; + // Use this method to add the attribute AAttribute. AAttribute must be owned by + // the xml document beforehand. + procedure AttributeAdd(AAttribute: TsdAttribute); overload; + // Add an open array of TsdAttribute objects. Attributes must be owned by + // the xml document beforehand. + procedure AttributesAdd(Attributes: array of TsdAttribute); + // Clear all attributes from the current node. + procedure AttributesClear; virtual; + // 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); + // Use this method to find the index of an attribute with name AName. + function AttributeIndexByName(const AName: Utf8String): integer; virtual; + // Add the node ANode to the nodelist. It will be added at the end, unless + // it is an attribute, in that case it will be added at the end of the current + // list of attributes. NodeAdd will set the parent of ANode to itself. + 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: Utf8String; + ShouldRecurse: boolean = True): TXmlNode; overload; + function NodeByAttributeValue(const NodeName, AttribName: Utf8String; + const AttribValue: UnicodeString; ShouldRecurse: boolean = True): TXmlNode; overload; + // Return a reference 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: Utf8String): TXmlNode; + // 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 TsdNodeList you don't need + // to cast the list items to TXmlNode. + procedure NodesByName(const AName: Utf8String; const AList: TList); + // Add an open array of TXmlNode objects. Nodes must be owned by the xml document + // beforehand. + procedure NodesAdd(Nodes: array of TXmlNode); + // 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; + // Extract the subnode at Index. The node will not be freed. + function NodeExtract(ANode: TXmlNode): TXmlNode; virtual; + // Remove the subnode. The node will also be freed, so do not free the + // node in the application. + procedure NodeRemove(ANode: TXmlNode); virtual; + // Call NodeIndexOf to get the index for ANode in the Nodes list. The first + // node in the list 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; virtual; + // Insert the node ANode at location Index in the list. Make sure to honour + // the fact that attributes are also nodes, and should always be first in + // the list. You can find the number of attributes with AttributeCount. + procedure NodeInsert(Index: integer; ANode: TXmlNode); virtual; + // Switch position of the nodes at Index1 and Index2. + procedure NodeExchange(Index1, Index2: integer); 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: Utf8String): TXmlNode; virtual; + // Create a new node with AName, add it to the subnode list, and return a + // pointer to it. + function NodeNew(const AName: Utf8String): 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: Utf8String): TXmlNode; virtual; + // Clear (and free) the complete list of subnodes. + procedure NodesClear; 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: Utf8String): TXmlNode; virtual; + // Find all nodes which have name NodeName. Contrary to the NodesByName + // function, this function will search the whole subnode tree. If you use + // a TsdNodeList for the AList parameter, you don't need to cast the list + // items to TXmlNode. + procedure FindNodes(const NodeName: Utf8String; const AList: TList); virtual; + // Iterates the next sibling of Node + function NextSibling(ANode: TXmlNode): TXmlNode; virtual; + // Return the first subnode with AType, or nil if none + function FirstNodeByType(AType: TsdElementType): TXmlNode; virtual; + // Read TreeDepth to find out many nested levels there are for the current XML + // node. Root has a TreeDepth of zero. + function TreeDepth: integer; + // The name of the node. For elements this is the element name. The string + // is encoded as UTF8. + property Name: Utf8String read GetName write SetName; + // The name of the node. For elements this is the element name. The string + // is encoded as UTF8. + property NameUnicode: UnicodeString read GetNameUnicode write SetNameUnicode; + // The value of the node. For elements this is the element value (based on + // first chardata fragment), for attributes this is the attribute value. The + // string is encoded as UTF8. Use ToWide(Node.Value) or Node.ValueUnicode + // to get a UnicodeString compatible with "unicode" windows methods. + property Value: Utf8String read GetValue write SetValue; + // ValueUnicode returns the value of the node as a UnicodeString. + property ValueUnicode: UnicodeString read GetValueUnicode write SetValueUnicode; + // List of attributes present in this element. Use AttributeCount to iterate. + property Attributes[Index: integer]: TsdAttribute read GetAttributes; + // Get or set the name of the attribute at Index (as UTF8). + property AttributeName[Index: integer]: Utf8String read GetAttributeName write SetAttributeName; + // Get or set the value of the attribute at Index (as UTF8). + property AttributeValue[Index: integer]: Utf8String read GetAttributeValue write SetAttributeValue; + // 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; + // Get a reference to an attribute node by its name. If there is no attribute + // with that name, nil will be returned. + property AttributeByName[const AName: Utf8String]: TsdAttribute read GetAttributeByName; + // Get the value of an attribute with name AName. If no attribute is present, + // an empty string is returned. When setting this value, an attribute is + // created if it does not yet exist. + property AttributeValueByName[const AName: Utf8String]: Utf8String read + GetAttributeValueByName write SetAttributeValueByName; + property AttributeValueByNameWide[const AName: Utf8String]: UnicodeString read + GetAttributeValueByNameWide write SetAttributeValueByNameWide; + // Use HasAttribute to determine if the node has an attribute with name AName. + function HasAttribute(const AName: Utf8String): boolean; virtual; + // List of subnodes, by index. Iterate through the list using NodeCount + // and this property. The attributes are listed first, then followed by + // all other node types, in the order as found in the XML document. + property Nodes[Index: integer]: TXmlNode read GetNodes; default; + // Get number of subnodes present in this node (this includes attributes, + // cdata, char-data, sub-elements, etcetera). + property NodeCount: integer read GetNodeCount; + // Get the number of attributes in this node + property AttributeCount: integer read GetAttributeCount; + // content of the node (raw source without the pre- and post matter) + property Content: Utf8String read GetContent; + // Fullpath will return the complete path of the node from the root, e.g. + // /Root/SubNode1/SubNode2/ThisNode + property FullPath: Utf8String read GetFullPath; + // direct node count (aka the attributes and optional whitespace inbetween) + property DirectNodeCount: integer read GetDirectNodeCount; + // (child) container count + property Containers[Index: integer]: TXmlNode read GetContainers; + property ContainerCount: integer read GetContainerCount; + + // Get/Set ValueAsXYZ functions + + // 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 GetValueAsBoolDef(ADefault: boolean): boolean; 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 GetValueAsFloatDef(ADefault: double): double; 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 GetValueAsDateTimeDef(ADefault: TDateTime): TDateTime; 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 GetValueAsIntegerDef(ADefault: integer): integer; 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 GetValueAsInt64Def(ADefault: int64): int64; virtual; + // Convert the node's value to boolean and return the result. + function GetValueAsBool: boolean; virtual; + // Convert the node's value to a double and return the result. + function GetValueAsFloat: double; virtual; + // Convert the node's value to a TDateTime and return the result. + function GetValueAsDateTime: TDateTime; virtual; + // Convert the node's value to integer and return the result. + function GetValueAsInteger: integer; virtual; + // Convert the node's value to int64 and return the result. + function GetValueAsInt64: int64; virtual; + // Store AValue as boolean + procedure SetValueAsBool(const AValue: boolean); virtual; + // Store AValue as float + procedure SetValueAsFloat(const AValue: double); virtual; + // Store AValue as Date + procedure SetValueAsDate(const AValue: TDateTime); virtual; + // Store AValue as Time + procedure SetValueAsTime(const AValue: TDateTime); virtual; + // Store AValue as DateTime + procedure SetValueAsDateTime(const AValue: TDateTime); virtual; + // Store AValue as Integer + procedure SetValueAsInteger(const AValue: integer); virtual; + // Store AValue as Int64 + procedure SetValueAsInt64(const AValue: int64); virtual; + + // ValueAsXYZ properties + + // Read and store existent value as boolean + property ValueAsBool: boolean read GetValueAsBool write SetValueAsBool; + // Read and store existent value as float + property ValueAsFloat: double read GetValueAsFloat write SetValueAsFloat; + // Store existent value as Date + property ValueAsDate: TDateTime write SetValueAsDate; + // Store existent value as Time + property ValueAsTime: TDateTime write SetValueAsTime; + // Read and store existent value as DateTime + property ValueAsDateTime: TDateTime read GetValueAsDateTime write SetValueAsDateTime; + // Read and store existent value as Integer + property ValueAsInteger: integer read GetValueAsInteger write SetValueAsInteger; + // Read and store existent value as Int64 + property ValueAsInt64: int64 read GetValueAsInt64 write SetValueAsInt64; + + // ReadXYZ functions + + // 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: Utf8String; ADefault: boolean = False): 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: Utf8String; ADefault: integer = 0): integer; virtual; + function ReadAttributeInt64(const AName: Utf8String; ADefault: int64 = 0): int64; virtual; // added by hdk + // 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: Utf8String; ADefault: double = 0): double; virtual; + // Find the attribute with AName. If the attribute is not found, ADefault will + // be returned. + function ReadAttributeString(const AName: Utf8String; ADefault: Utf8String = ''): Utf8String; virtual; + function ReadAttributeUnicodeString(const AName: Utf8String; ADefault: UnicodeString = ''): UnicodeString; virtual; // added by hdk + function ReadAttributeAnsiString(const AName: Utf8String; ADefault: AnsiString = ''): AnsiString; virtual; // added by hdk + // 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 ReadAttributeDateTime(const AName: Utf8String; ADefault: TDateTime = 0): TDateTime; virtual; // added by hdk + + function ReadBool(const AName: Utf8String; ADefault: boolean = False): boolean; virtual; + // Read the properties Color, Mode, Style and Width for the TPen object APen + // from the subnode with AName. + procedure ReadPen(const AName: Utf8String; APen: TPen); virtual; + // Read the properties Color and Style for the TBrush object ABrush from the + // subnode with AName. + procedure ReadBrush(const AName: Utf8String; 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: Utf8String; ADefault: TColor = clBlack): TColor; virtual; + // 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: Utf8String; ADefault: TDateTime = 0): 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: Utf8String; ADefault: double = 0.0): double; virtual; + // 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: Utf8String; ADefault: integer = 0): integer; virtual; + function ReadInt64(const AName: Utf8String; ADefault: int64 = 0): int64; virtual; // added by hdk + // Read the subnode with AName and return its UTF8String value. If the subnode is + // not found, ADefault will be returned. + function ReadString(const AName: Utf8String; const ADefault: Utf8String = ''): Utf8String; virtual; + // Read the subnode with AName and return its UnicodeString value. If the subnode is + // not found, ADefault will be returned. + function ReadUnicodeString(const AName: Utf8String; const ADefault: UnicodeString = ''): UnicodeString; virtual; + function ReadAnsiString(const AName: Utf8String; const ADefault: AnsiString = ''): AnsiString; virtual; // added by hdk + + // WriteXYZ functions + + // 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: Utf8String; AValue: integer; ADefault: integer = 0); virtual; + procedure WriteAttributeInt64(const AName: UTF8String; AValue: int64; ADefault: int64 = 0); virtual; // added by hdk + // If the attribute with name AName exists, then set its value to the float + // AValue. If it does not exist, then create a new attribute AName with the + // float value converted to a quoted string. If ADefault = AValue, and + // WriteOnDefault = False, no attribute will be added. + procedure WriteAttributeFloat(const AName: Utf8String; AValue: double; ADefault: double = 0); 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 + // string value with quotes. If ADefault = AValue, and + // WriteOnDefault = False, no attribute will be added. + procedure WriteAttributeString(const AName: Utf8String; AValue: Utf8String; ADefault: Utf8String = ''); virtual; + procedure WriteAttributeUnicodeString(const AName: Utf8String; const AValue: UnicodeString; const ADefault: UnicodeString = ''); virtual; + procedure WriteAttributeAnsiString(const AName: Utf8String; const AValue: AnsiString; const ADefault: AnsiString = ''); virtual; // added by hdk + // If the attribute with name AName exists, then set its value to the TDateTime + // AValue. If it does not exist, then create a new attribute AName with the + // TDateTime value converted to a quoted string. If ADefault = AValue, and + // WriteOnDefault = False, no attribute will be added. + procedure WriteAttributeDateTime(const AName: Utf8String; AValue: TDateTime; ADefault: TDateTime = 0); virtual; // changed by hdk + // 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 a quoted string. If ADefault = AValue, and + // WriteOnDefault = False, no attribute will be added. + procedure WriteAttributeBool(const AName: Utf8String; AValue: boolean; ADefault: boolean = False); 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: Utf8String; AValue: boolean; ADefault: boolean = False); 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: Utf8String; APen: TPen); virtual; + // 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: Utf8String; 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: Utf8String; AValue: TColor; ADefault: TColor = clBlack); virtual; + // 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: Utf8String; AValue: TDateTime; ADefault: TDateTime = 0); 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: Utf8String; AValue: double; ADefault: double = 0.0); 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: Utf8String; AValue, Digits: integer; ADefault: integer = 0); virtual; + // 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: Utf8String; AValue: integer; ADefault: integer = 0); virtual; + // 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: Utf8String; AValue: int64; ADefault: int64 = 0); virtual; + // Add or replace the subnode with AName and set its value to represent the UTF8String + // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. + procedure WriteString(const AName, AValue: Utf8String; const ADefault: Utf8String = ''); virtual; + // Add or replace the subnode with AName and set its value to represent the UnicodeString + // AValue. If AValue = ADefault, and WriteOnDefault = False, no subnode will be added. + procedure WriteUnicodeString(const AName: Utf8String; const AValue: UnicodeString; const ADefault: UnicodeString = ''); virtual; + procedure WriteAnsiString(const AName: Utf8String; const AValue: AnsiString; const ADefault: AnsiString = ''); virtual; // added by hdk + + // Returns the length of the data in the buffer, once it would be decoded by + // the Base64 method. The length of the unencoded data is determined from the + // length of the encoded data. Base64 must use the padding characters. + function BufferLength: integer; virtual; + // Use this method to read binary data from the node into Buffer with a length of Count. + procedure BufferRead(var Buffer; Count: Integer; BinaryEncoding: TsdBinaryEncoding = xbeBase64); 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 Base64 method in the final XML document. + procedure BufferWrite(const Buffer; Count: Integer); virtual; + // 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: RawByteString read GetBinaryString write SetBinaryString; + // return the index of the node in its parent + function IndexInParent: integer; + // sort the child nodes based on a compare function. If Compare = nil, just + // alphabetical compare is used. + procedure SortChildNodes(Compare: TXmlNodeCompareFunction); + end; + + // List of nodes + TsdNodeList = class(TObjectList) + private + function GetItems(Index: integer): TXmlNode; + function GetNextSiblingOf(ANode: TXmlNode): TXmlNode; + function GetLastSiblingOf(ANode: TXmlNode): TXmlNode; + public + // TsdNodeList has a different default than TObjectList + // since 'AOwnsObjects' should usually be false in client code + constructor Create(AOwnsObjects: boolean = false); virtual; + // ByType returns the first item in the list that has element type AType. + // If no item is found, the function returns nil. + function ByType(AType: TsdElementType): TXmlNode; + function FindFirst: TXmlNode; + function FindNext(ANode: TXmlNode): TXmlNode; + property Items[Index: integer]: TXmlNode read GetItems; default; + end; + + TsdXmlNodeEvent = procedure(Sender: TObject; ANode: TXmlNode) of object; + + // Node representing a xml char-data fragment + TsdCharData = class(TXmlNode) + private + function GetName: Utf8String; override; + function GetValue: Utf8String; override; + procedure SetName(const Value: Utf8String); override; + procedure SetValue(const Value: Utf8String); override; + protected + FCoreValueID: integer; + function GetCoreValue: Utf8String; virtual; + procedure SetCoreValue(const Value: Utf8String); virtual; + procedure CopyFrom(ANode: TXmlNode); override; + public + destructor Destroy; override; + function GetValueUsingReferences(Nodes: array of TXmlNode): Utf8String; + function ElementType: TsdElementType; override; + function HasNonStandardReferences: boolean; + procedure WriteStream(S: TStream); override; + end; + + // Node representing whitespace chardata + TsdWhiteSpace = class(TsdCharData) + public + function ElementType: TsdElementType; override; + end; + + // Node representing quoted text ('bla' or "bla") + TsdQuotedText = class(TsdCharData) + private + FQuoteChar: AnsiChar; + function GetName: Utf8String; override; + protected + procedure CopyFrom(ANode: TXmlNode); override; + public + constructor Create(AOwner: TNativeXml); override; + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + end; + + // Node representing an xml attribute. + TsdAttribute = class(TXmlNode) + private + FNameID: integer; + FCoreValue: TsdQuotedText; + function GetName: Utf8String; override; + procedure SetName(const Value: Utf8String); override; + function GetValue: Utf8String; override; + procedure SetValue(const Value: Utf8String); override; + protected + procedure CopyFrom(ANode: TXmlNode); override; + public + constructor Create(AOwner: TNativeXml); override; + destructor Destroy; override; + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + end; + + // TsdContainerNode is the base class for all element types that can have + // sub-nodes. + TsdContainerNode = class(TXmlNode) + private + FNodes: TsdNodeList; + FDirectNodeCount: integer; + FValueIndex: integer; + protected + function ParseAttributeList(Parser: TsdXmlParser): AnsiChar; virtual; + function ParseQuotedTextList(Parser: TsdXmlParser): AnsiChar; virtual; + procedure WriteAttributeList(S: TStream; Count: integer); virtual; + function GetNodeCount: integer; override; + function GetNodes(Index: integer): TXmlNode; override; + function HasSubContainers: boolean; virtual; + procedure CopyFrom(ANode: TXmlNode); override; + property NodeList: TsdNodeList read FNodes; + // count of the attributes + function GetDirectNodeCount: integer; override; + function GetContainers(Index: integer): TXmlNode; override; + function GetContainerCount: integer; override; + public + constructor Create(AOwner: TNativeXml); override; + destructor Destroy; override; + procedure Clear; override; + function NodeAdd(ANode: TXmlNode): integer; override; + procedure NodeDelete(Index: integer); override; + function NodeExtract(ANode: TXmlNode): TXmlNode; override; + function NodeIndexOf(ANode: TXmlNode): integer; override; + procedure NodeInsert(Index: integer; ANode: TXmlNode); override; + procedure NodeExchange(Index1, Index2: integer); override; + procedure NodesClear; override; + function FirstNodeByType(AType: TsdElementType): TXmlNode; override; + end; + + // Node representing an xml element. + TsdElement = class(TsdContainerNode) + private + FNameID: integer; + FNodeClosingStyle: TsdNodeClosingStyle; + protected + function GetName: Utf8String; override; + function GetNodeClosingStyle: TsdNodeClosingStyle; virtual; + function GetValue: Utf8String; override; + procedure SetName(const Value: Utf8String); override; + procedure SetNodeClosingStyle(const Value: TsdNodeClosingStyle); virtual; + procedure SetValue(const Value: Utf8String); override; + procedure ParseIntermediateData(Parser: TsdXmlParser); virtual; + // parse the element list; the result (endtag) should be this element + function ParseElementList(Parser: TsdXmlParser; const SupportedTags: TsdElementTypes): TXmlNode; virtual; + procedure CopyFrom(ANode: TXmlNode); override; + public + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + property NodeClosingStyle: TsdNodeClosingStyle read GetNodeClosingStyle write SetNodeClosingStyle; + end; + + // Node representing an xml declaration, e.g. + TsdDeclaration = class(TsdContainerNode) + private + function GetEncoding: Utf8String; + function GetVersion: Utf8String; + procedure SetEncoding(const Value: Utf8String); + procedure SetVersion(const Value: Utf8String); + protected + function GetName: Utf8String; override; + public + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + property Version: Utf8String read GetVersion write SetVersion; + // encoding aka charset + property Encoding: Utf8String read GetEncoding write SetEncoding; + end; + + // Node representing an xml comment. Get/set Value for the comment. + TsdComment = class(TsdCharData) + protected + function GetName: Utf8String; override; + public + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + end; + + // Node representing a CData element. Get/Set value for the data in CDATA. + TsdCData = class(TsdComment) + protected + function GetName: Utf8String; override; + function GetValue: Utf8String; override; + procedure SetValue(const Value: Utf8String); override; + public + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + end; + + // Conditional Section + TsdConditionalSection = class(TsdComment) + end; + + // DocType declaration element. It can have sub-nodes with dtd elements, + // entities, notations, etc. + TsdDocType = class(TsdElement) + private + FExternalId: TsdCharData; + FSystemLiteral: TsdQuotedText; + FPubIDLiteral: TsdQuotedText; + protected + procedure ParseIntermediateData(Parser: TsdXmlParser); override; + procedure CopyFrom(ANode: TXmlNode); override; + public + constructor Create(AOwner: TNativeXml); override; + destructor Destroy; override; + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + // External ID: either SYSTEM or PUBLIC + property ExternalId: TsdCharData read FExternalId; + // The system literal without quotes + property SystemLiteral: TsdQuotedText read FSystemLiteral; + // The PubID literal without quotes + property PubIDLiteral: TsdQuotedText read FPubIDLiteral; + end; + + // DTD Element declaration + TsdDtdElement = class(TsdElement) + private + protected + function GetValue: Utf8String; override; + procedure WriteContent(S: TStream); override; + public + function ElementType: TsdElementType; override; + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + end; + + // DTD AttList declaration + TsdDtdAttList = class(TsdDtdElement) + public + function ElementType: TsdElementType; override; + end; + + // DTD Entity declaration + TsdDtdEntity = class(TsdDtdElement) + public + function ElementType: TsdElementType; override; + end; + + // DTD Notation declaration + TsdDtdNotation = class(TsdDtdElement) + public + function ElementType: TsdElementType; override; + end; + + // (processing) instruction + TsdInstruction = class(TsdCharData) + protected + function GetName: Utf8String; override; + public + function ElementType: TsdElementType; override; + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + end; + + // TsdStyleSheet + TsdStyleSheet = class(TsdInstruction) + protected + function GetName: Utf8String; override; + public + function ParseStream(Parser: TsdXmlParser): TXmlNode; override; + procedure WriteStream(S: TStream); override; + function ElementType: TsdElementType; override; + end; + + // TNativeXml is a very fast XML reader (on typical hardware storage + // 15 Mb per second), because it loads external data in chunks and buffers it in + // memory. Use Create to create a new instance, use LoadFromFile/LoadFromStream to + // load the XML document from a file or stream, and use SaveToFile and SaveToStream to + // save the XML document. + TNativeXml = class(TsdDebugComponent) + private + FOnDebugOut: TsdDebugEvent; + //FOnDebugOut: TsdDebugEvent; + procedure SetPreserveWhiteSpace(Value: boolean); + procedure SetExternalEncoding(const Value: TsdStringEncoding); + protected + FRootNodes: TsdNodeList; + FStringTable: TsdStringTable; + // + FAbortParsing: boolean; + FDirectCloseTag: Utf8String; + FDropCommentsOnParse: boolean; + FEolStyle: TsdEolStyle; + FFloatAllowScientific: boolean; + FFloatSignificantDigits: integer; + FExternalBomInfo: TsdBomInfo; + FExternalCodePage: integer; + FExternalEncoding: TsdStringEncoding; + FFixStructuralErrors: boolean; + FIndentString: Utf8String; + FNodeClosingStyle: TsdNodeClosingStyle; + FParserWarnings: boolean; + FPreserveWhitespace: boolean; + FSkipNormalisation: boolean; + FXmlFormat: TsdXmlFormatType; + FUseLocalBias: boolean; + FWriteOnDefault: boolean; + FSplitSecondDigits: integer; + // events + FOnNodeNew: TsdXmlNodeEvent; + FOnNodeLoaded: TsdXmlNodeEvent; + FOnProgress: TXmlProgressEvent; + procedure DoNodeNew(ANode: TXmlNode); + procedure DoNodeLoaded(ANode: TXmlNode); + // GetParserPosition gives the parser's current position in the stream when + // loading. + function GetParserPosition(Parser: TsdXmlParser): int64; + function GetCommentString: Utf8String; + procedure SetCommentString(const Value: Utf8String); + function GetStyleSheet: TsdStyleSheet; + function GetCharset: Utf8String; + procedure SetCharset(const Value: Utf8String); + function GetRoot: TsdElement; + function GetRootNodeCount: integer; + function GetRootNodeClass: TsdNodeClass; virtual; + function GetRootContainers(Index: integer): TsdContainerNode; virtual; + function GetRootContainerCount: integer; virtual; + function GetVersionString: Utf8String; + procedure SetVersionString(const Value: Utf8String); + // GetParserLineNumber gives the parser's current line number in the stream + // when loading. + function GetParserLineNumber(Parser: TsdXmlParser): int64; + procedure MoveSubNodes(AList: TsdNodeList; FromNode, ToNode: TXmlNode); + procedure DoProgress(Position: int64); + function LineFeed: Utf8String; + // ParseStream is called from any of the XmlNode descendants + // and is the core method to get the xml data from external data to + // the document object model. + procedure ParseStream(Parser: TsdXmlParser); + // WriteStream is called from any of the XmlNode descendants + // and is the core method to write the xml data to the stream + procedure WriteStream(S: TStream); + public + + // constructors + + // Create an xml document with options for declaration and root element. + constructor CreateEx(HasDeclaration, HasRootElement: boolean; AOwner: TComponent); + // Use CreateName to Create a new Xml document that will automatically + // contain a root element with name ARootName. This constructor also adds + // the default declaration + constructor CreateName(const ARootName: Utf8String; AOwner: TComponent = nil); + // constructor with just the root element with an empty name + constructor Create(AOwner: TComponent); override; + // Destroys a TNativeXml instance + destructor Destroy; override; + + // general methods + + // canonicalize XML (C14N process): after canonicalization of the document, + // it will be.. encoded in utf-8 only, xml declaration removed, entities + // expanded to their character equivalent, CDATA sections replaced by character + // equivalent, special < > and " entities encoded, attributes + // normalized as if by validating parser, empty elements opened with start + // and end tags, namespace declarations and attributes sorted. + // The function returns the number of entities expanded. + function Canonicalize: integer; + // Clear all the nodes in the xml document + procedure Clear; virtual; + // class method: Decode base64-encoded data (Utf8String) to binary data (RawByteString) + class function DecodeBase64(const Source: Utf8String; OnDebug: TsdDebugEvent): RawByteString; + // class method: encode binary data (RawByteString) to Utf8String, adding a + // control character (default #$0A) each 76 characters + class function EncodeBase64(const Source: RawByteString; const ControlChars: Utf8String = #$0A): Utf8String; + // Find first TXmlNode instance in the document, or nil if none found (aka document is empty) + function FindFirst: TXmlNode; + // Find next TXmlNode instance in the document, based on previous TXmlNode instance ANode + function FindNext(ANode: TXmlNode): TXmlNode; + // fire AEvent for each node in the document + procedure ForEach(Sender: TObject; AEvent: TsdXmlNodeEvent); + // IndentString is the string used for indentations. By default, it is a + // tab (#$09). Set IndentString to something else if you need to have + // specific indentation, or set it to an empty string to avoid indentation. + property IndentString: Utf8String read FIndentString write FIndentString; + // Insert a doctype right after the encoding. + function InsertDocType(const AName: Utf8String): TsdDocType; + // 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; + // load from binary xml file (bxm). The advisory file extension is *.BXM + // load the xml from a URL, and return the loaded size in bytes + function LoadFromURL(const URL: Utf8String): int64; 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 when it encounters non-wellformed XML. + procedure LoadFromFile(const AFileName: string); virtual; + // Load an XML document from the stream AStream. The LoadFromStream + // procedure will raise an exception when it encounters non-wellformed XML. + // This method can be used with any TStream descendant. The stream is read + // chunk-wise (using 64K chunks). See also LoadFromFile and ReadFromString. + procedure LoadFromStream(AStream: TStream); virtual; + // Use New to make a new xml document + procedure New; virtual; + // parse substitute content from ANode (usually a TsdCharData). ANode will be + // removed and the substitute content gets parsed and becomes part of the object model. + function ParseSubstituteContentFromNode(ANode: TXmlNode; const ASubstitute: Utf8String): TXmlNode; + // Call procedure ReadFromString to load an XML document from the UTF8String AValue. + // The ReadFromString procedure will raise an exception of type EFilerError + // when it encounters non-wellformed XML. + procedure ReadFromString(const AValue: Utf8String); 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. + procedure SaveToFile(const AFileName: string); virtual; + // 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; + // Skip EOL normalisation (can be faster, but not compatible with xml spec). + // Default value is FALSE. + property SkipNormalisation: boolean read FSkipNormalisation write FSkipNormalisation; + // Call WriteToString to write the entire XML document stream including + // optional BOM to a generic string. + function WriteToString: string; virtual; + // Call WriteToLocalString to write the XML document to a Utf8String. + function WriteToLocalString: Utf8String; virtual; + // Call WriteToLocalUnicodeString to write the XML document to a UnicodeString. + function WriteToLocalUnicodeString: UnicodeString; virtual; + // 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 element, by creating using CreateName. + property Root: TsdElement read GetRoot; + // RootNodes 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 an element node which is the Root. You can use this property to add or + // delete comments, stylesheets, dtd's etc. + property RootNodes: TsdNodeList read FRootNodes; + // Payload rootnode class (TsdElement by default, but apps may create + // a class that descends from TsdElement) + property RootNodeClass: TsdNodeClass read GetRootNodeClass; + // item count of the RootNodeList, ie usually max 3: the declaration, the DTD, + // the Root (TsdElement or RootNodeClass descendant). + property RootNodeCount: integer read GetRootNodeCount; + // root containers + property RootContainers[Index: integer]: TsdContainerNode read GetRootContainers; + // number of root containers (as opposed to all root nodes) + property RootContainerCount: integer read GetRootContainerCount; + // A comment string above the root element can be accessed with + // this property. Assign a comment to this property to add it to the XML document. + // Use property RootNodes to add/insert/extract multiple comments. + property CommentString: Utf8String 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; + // After reading, this property contains the XML version (usually "1.0"). + property VersionString: Utf8String read GetVersionString write SetVersionString; + // Charset (e.g. 'UTF-8', 'UTF-16' or any other multibyte/ansi codepage description. + // This charset description is stored in the declaration node. + // Example: In order to get this header: + // + // enter this code: + // MyXmlDocument.Charset := 'UTF-16'; + // When reading a file, Charset will contain the encoding used. + property Charset: Utf8String read GetCharset write SetCharset; + // StringTable holds all the content (strings) in the xml tree + property StringTable: TsdStringTable read FStringTable; + // Get the stylesheet 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 StyleSheet: TsdStyleSheet read GetStyleSheet; + // External encoding is valid after loading, and indicates the encoding + // detected in the external xml document. Internally, all string values are always + // encoded in UTF8, so if the external stream is Ansi with codepage or UTF16, a conversion + // is done. When writing to a file/stream, a BOM is generated for the two-byte + // character encodings (UTF16LE and UUTF16BE). UTF8 uses *no BOM* according to + // the XML specification. + // Any conversion is done from UTF8 to external encodings if necessary. You can + // *set* ExternalEncoding too but only for welldefined encodings (seUTF8, seUTF16LE, + // seUTF16BE). If you want to use an ansi encoding, then set ExternalCodepage. + property ExternalEncoding: TsdStringEncoding read FExternalEncoding write SetExternalEncoding; + // the codepage used in the external xml document + property ExternalCodepage: integer read FExternalCodepage write FExternalCodepage; + // if ncUnknown (default), parsed setting will be preserved per element + // if ncFull, single tags will be left full (eg '') + // if ncClose , single tags will be closed (eg '') + property NodeClosingStyle: TsdNodeClosingStyle read FNodeClosingStyle write FNodeClosingStyle; + // 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 + // after the declaration. + // By setting XmlFormat to xfReadable, you can generate readable XML + // files that contain indentation and end-of-lines after each element. + property XmlFormat: TsdXmlFormatType read FXmlFormat write FXmlFormat; + // EolStyle by default is set to esWindows. + // esLinux writes just a LF (#$0A) as end-of-line + // esWindows writes a CRLF (#$0D#$0A) as end-of-line + property EolStyle: TsdEolStyle read FEolStyle write FEolStyle; + // OnProgress event + property OnProgress: TXmlProgressEvent read FOnProgress write FOnProgress; + // Set PreserveWhiteSpace to True to preserve all whitespace present in the + // file when reading. The blocks of whitespace are stored as CharData nodes. + property PreserveWhiteSpace: boolean read FPreserveWhiteSpace write SetPreserveWhiteSpace; + // 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. + property AbortParsing: boolean read FAbortParsing write FAbortParsing; + // when true, NativeXmlEx will try to fix certain structural errors that usually + // come from single tags in HTML (default = False) + property FixStructuralErrors: boolean read FFixStructuralErrors write FFixStructuralErrors; + // 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; + // 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; + // When converting date/time values to strings, NativeXml will use this + // number of digits after the seconds. The default is cDefaultSplitSecondDigits, + // and set to 0. With this default, no tens/hundreds/thousands after the second are used + property SplitSecondDigits: integer read FSplitSecondDigits write FSplitSecondDigits; + // When converting date/time values to strings, NativeXml will use a local bias + // towards UTC if this option is True. Default is False. + property UseLocalBias: boolean read FUseLocalBias write FUseLocalBias; + // Connect to OnNodeNew to get informed of new nodes being added while loading. + property OnNodeNew: TsdXmlNodeEvent read FOnNodeNew write FOnNodeNew; + // Connect to OnNodeLoaded to get informed of nodes being finished loading. + property OnNodeLoaded: TsdXmlNodeEvent read FOnNodeLoaded write FOnNodeLoaded; + // Connect to OnDebugOut to get debug information in the client application + property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut; + end; + +const + + cNodeClass: array[TsdElementType] of TsdNodeClass = + (TsdElement, TsdAttribute, TsdComment, TsdCData, TsdConditionalSection, + TsdDeclaration, TsdStyleSheet, TsdDocType, TsdDtdElement, TsdDtdAttList, + TsdDtdEntity, TsdDtdNotation, TsdInstruction, TsdCharData, TsdWhiteSpace, + TsdQuotedText, nil, nil, nil); + +const + // chunk sizes: external stream is loaded/saved in these chunks of memory data + // valid values are $4 - unbounded till memory size + // sane values are $20 - $1000 + cParserChunkSize = $100; + cWriterChunkSize = $100; + +{ + NativeXmlUtils: + Types, constants and utility functions of NativeXml +} +const + + // Count of different escape characters + cEscapeCount = 5; + + // These are phrases 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 "&"; + cXmlEscapePhrases: array[0..cEscapeCount - 1] of Utf8String = + ('&', + '<', + '>', + '''', + '"'); + + // These are the phrases that replace the escape phrases - in the same order + // As a result, these phrases are visible in the core xml source + cXmlReplacePhrases: array[0..cEscapeCount - 1] of Utf8String = + ('&', + '<', + '>', + ''', + '"'); + + // special characters used for whitespace / blanks + cXmlBlankChars: set of AnsiChar = + [#$09, #$0A, #$0D, #$20]; + + cXmlBlankCharsOrEndTag: set of AnsiChar = + [#$09, #$0A, #$0D, #$20, '[', '/', '>']; + + cXmlQuoteChars: set of AnsiChar = + ['''', '"']; + + // codepage IBM852, used for GUI implementations + CP_852: integer = 852; + + // Windows-1250 codepage, used for GUI implementations + CP_1250: integer = 1250; + + // Windows-1252 codepage, used for GUI implementations + CP_1252: integer = 1252; + + // UTF8 codepage (outcommented to avoid clash in BCB - it is already defined + // in windows) + //CP_UTF8: integer = 65001; + + // UTF16 codepage + CP_UTF16: integer = 1200; + + // ISO 8859-1 codepage, used for GUI implementations + CP_ISO8859_1: integer = 28591; + + // These characters are used when generating BASE64 AnsiChars from buffer data + cBase64Char: array[0..63] of AnsiChar = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + cBase64PadChar: AnsiChar = '='; + + cBomInfoListCount = 15; + // array with Byte Order Mark (BOM) info + cBomInfoList: array[0..cBomInfoListCount - 1] of TsdBomInfo = + ( (BOM: ($3C,$3F,$78,$6D); Len: 4; Encoding: seAnsi; HasBOM: false), // 0 + (BOM: ($EF,$BB,$BF,$00); Len: 3; Encoding: seUTF8; HasBOM: true), + (BOM: ($00,$00,$FE,$FF); Len: 4; Encoding: seUTF32BE; HasBOM: true), + (BOM: ($FF,$FE,$00,$00); Len: 4; Encoding: seUTF32LE; HasBOM: true), + (BOM: ($00,$00,$FF,$FE); Len: 4; Encoding: seUCS4_2143; HasBOM: true), + (BOM: ($FE,$FF,$00,$00); Len: 4; Encoding: seUCS4_3412; HasBOM: true), + (BOM: ($FE,$FF,$00,$00); Len: 2; Encoding: seUTF16BE; HasBOM: true), // 6 + (BOM: ($FF,$FE,$00,$00); Len: 2; Encoding: seUTF16LE; HasBOM: true), // 7 + (BOM: ($00,$00,$00,$3C); Len: 4; Encoding: seUTF32BE; HasBOM: false), + (BOM: ($3C,$00,$00,$00); Len: 4; Encoding: seUTF32LE; HasBOM: false), + (BOM: ($00,$00,$3C,$00); Len: 4; Encoding: seUCS4_2143; HasBOM: false), + (BOM: ($00,$3C,$00,$00); Len: 4; Encoding: seUCS4_3412; HasBOM: false), + (BOM: ($00,$3C,$00,$3F); Len: 4; Encoding: seUTF16BE; HasBOM: false), + (BOM: ($3C,$00,$3F,$00); Len: 4; Encoding: seUTF16LE; HasBOM: false), + (BOM: ($4C,$6F,$A7,$94); Len: 4; Encoding: seEBCDIC; HasBOM: false) + ); + cBomInfoIdxUTF16BE = 6; + cBomInfoIdxUTF16LE = 7; + + cElementTypeNames: array[TsdElementType] of Utf8String = + ('Element', 'Attribute', 'Comment', 'CData', 'ConditionalSection', + 'Declaration', 'Stylesheet', 'DocType', 'DtdElement', 'DtdAttList', 'DtdEntity', + 'DtdNotation', 'Instruction', 'CharData', 'WhiteSpace', 'QuotedText', 'Unknown', + 'EndTag', 'Error'); + // binary xml version + // v1: stylesheet based on chardata + // v2: stylesheet based on containernode + cBinaryXmlVersion: cardinal = 2; + +resourcestring + + sPrematureEnd = 'stream terminated prematurely at pos %d'; + sInvalidStream = 'invalid stream'; + sUnknownEncoding = 'unknown encoding'; + sUnsupportedEncoding = 'unsupported encoding (%s)'; + sDefaultCharUsed = 'default char used for codepage substitution'; + sNotSupported = 'feature is not supported yet'; + sIllegalTag = 'illegal tag ("%s") at pos %d'; + sUnsupportedTag = 'unsupported tag ("%s") at pos %d'; + sIllegalEndTag = 'illegal end tag ("%s") at line %d (streampos %d)'; + sQuoteCharExpected = 'quote char expected at pos %d'; + sCannotAddNode = 'cannot add node to this type of element'; + sCannotSetName = 'cannot set name on this type of element'; + sCannotSetValue = 'cannot set value on this type of element'; + sCannotManipulate = 'cannot manipulate nodes in this type of element'; + sBeginEndMismatch = 'begin and end tag mismatch: "%s" and "%s" at line %d (pos %d)'; + sLevelMismatch = 'level mismatch between subnode "%s" and endnode "%s" at line %d (pos %d)'; + sRootElementNotDefined = 'XML root element not defined.'; + sNonDefaultChardata = 'non-default chardata at line %d (pos %d)'; + sSignificantDigitsOutOfRange = 'significant digits out of range'; + sMissingDataInBinaryStream = 'missing data in binary stream'; + sErrorCalcStreamLength = 'error while calculating streamlength'; + sXmlNodeNotAssigned = 'XML node is not assigned'; + sXmlOwnerNotAssigned = 'XML owner is not assigned'; + sUnknownBinaryEncodingBinhex = 'unknown encoding: xbeBinHex (deprecated)'; + + +var + + // XML Defaults + cDefaultDirectCloseTag: Utf8String = '/>'; + cDefaultDropCommentsOnParse: boolean = False; + cDefaultFloatAllowScientific: boolean = True; + cDefaultFloatSignificantDigits: integer = 6; + cDefaultEncodingString: Utf8String = 'UTF-8'; + cDefaultEolStyle: TsdEolStyle = esWindows; + cDefaultExternalEncoding: TsdStringEncoding = seUTF8; + cDefaultFixStructuralErrors: boolean = False; + cDefaultIndentString: Utf8String = #$09; // tab + cDefaultNodeClosingStyle: TsdNodeClosingStyle = ncClose; + cDefaultPreserveWhiteSpace: boolean = False; + cDefaultSortAttributes: boolean = False; + cDefaultVersionString: Utf8String = '1.0'; + cDefaultXmlFormat: TsdXmlFormatType = xfCompact; + cDefaultUseLocalBias: boolean = False; + cDefaultWriteOnDefault: boolean = True; + + // helpful XML addtions + cReadableDirectCloseTag: Utf8String = ' />'; + // see GetXmlFormatSettings in initialization section + cXmlFormatSettings: TFormatSettings; + +{ Utility functions } + +// Convert UnicodeString to Utf8String +function sdWideToUtf8(const W: UnicodeString): Utf8String; + +// Convert UTF8 string to UnicodeString +function sdUtf8ToWide(const U: Utf8String): UnicodeString; + +// Convert Ansi to Utf8 string +function sdAnsiToUtf8(const A: AnsiString; ACodePage: integer): Utf8String; + +// Convert Utf8 to Ansi string +function sdUtf8ToAnsi(const U: Utf8String; ACodePage: integer): AnsiString; + +function sdTrim(const S: Utf8String): Utf8String; overload; +function sdTrim(const S: Utf8String; var IsTrimmed: boolean): Utf8String; overload; + +function sdNormaliseEol(const S: Utf8String): Utf8String; + +function sdUnNormaliseEol(const S: Utf8String; EolStyle: TsdEolStyle): Utf8String; + +function sdEscapeString(const AValue: Utf8String): Utf8String; + +// replace escaped phrases and references written in the core xml source +// with replacement characters +function sdReplaceString(const AValue: Utf8String; var HasNonStandardReferences: boolean; References: array of TXmlNode): Utf8String; overload; +function sdReplaceString(const AValue: Utf8String; var HasNonStandardReferences: boolean): Utf8String; overload; +function sdReplaceString(const AValue: Utf8String): Utf8String; overload; + +function sdCommaToDot(const AValue: Utf8String): Utf8String; + +procedure sdWriteToStream(S: TStream; const Value: Utf8String); + +// Based on the charset, find the codepage. If no charset is +// matched, the function returns ADefaultCodepage (default UTF-8, 65001) +function sdCharsetToCodePage(ACharset: Utf8String; ADefaultCodepage: integer = 65001): integer; +// Based on the charset, find the TsdStringEncoding. If no charset is +// matched, the function returns a encoding of seUTF8 +function sdCharsetToStringEncoding(ACharset: Utf8String): TsdStringEncoding; + +// find the encoding string corresponding to windows codepage +function sdCodepageToCharset(ACodepage: integer): Utf8String; + +function Utf8CompareText(const S1, S2: Utf8String): integer; + +// type conversions + +// get the timezone bias +function GetTimeZoneBias: Integer; + +// 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; UseDate: boolean = True; UseTime: boolean = True; + SplitSecondDigits: integer = 0; UseLocalBias: boolean = False): Utf8String; + +function sdBoolToString(Value: boolean): Utf8String; + +// Convert a number to a Utf8String, using SignificantDigits to indicate the number of +// significant digits, and AllowScientific to allow for scientific notation if that +// results in much shorter notation. +function sdFloatToString(Value: double; SignificantDigits: integer; AllowScientific: boolean): Utf8String; + +function sdIntToString(Value: integer): Utf8String; + +function sdInt64ToString(Value: int64): Utf8String; + +// Convert the Utf8String 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 sdStringToDateTime(const ADate: Utf8String; UseLocalBias: Boolean = False): TDateTime; + +// Convert the UTF8String 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 sdStringToDateTimeDef(const ADate: Utf8String; ADefault: TDateTime; + UseLocalBias: Boolean = False): TDateTime; + +// Encode binary data in Source as BASE64. The function returns the BASE64 encoded +// data as UTF8String, without any linebreaks. +function EncodeBase64(const Source: RawByteString): Utf8String; +function EncodeBase64Buf(const Buffer; Count: Integer): Utf8String; + +// Decode BASE64 data in Source into binary data. The function returns the binary +// data as Utf8String. The Source Utf8String may contain linebreaks and control characters, +// these will be stripped. +function DecodeBase64(const Source: Utf8String): RawByteString; +procedure DecodeBase64Buf(var Source: Utf8String; var Buffer; Count: Integer); + +// Decode BINHEX data in Source into RawByteStrng with binary data (for compatibility with old NativeXml) +function DecodeBinHex(const Source: Utf8String): RawByteString; +procedure DecodeBinhexBuf(var Source: Utf8String; var Buffer; Count: Integer); + +// This function removes control characters from Utf8String AValue (Tab, CR, LF and Space) +function sdRemoveControlChars(const AValue: Utf8String): Utf8String; + +// This function adds control characters Chars repeatedly after each Interval +// of characters to UTF8String Value. Default interval is 76 (seems to be used in many +// applications) +function sdAddControlChars(const AValue: Utf8String; const ControlChars: Utf8String; Interval: integer = 76): Utf8String; + + +// Convert Ansi to Utf8 using buffers +// please note: Utf8Buf can use 3x more size than AnsiBuf in extreme cases. +// Result is the Utf8Buf bytecount +function sdAnsiToUtf8Buffer(const AnsiBuf; var Utf8Buf; ACodePage, AnsiCount: integer): integer; + +// Convert Utf8 to Ansi using buffers +function sdUtf8ToAnsiBuffer(const Utf8Buf; var AnsiBuf; ACodePage, Utf8Count: integer; + var DefaultCharUsed: boolean): integer; + +// determine the character length of the first Utf8 character in the buffer +function sdUtf8CharacterLength(const Buffer): integer; + +// Convert a "WideString" (UTF16 LE) buffer to UTF8. This routine will process +// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes). +// Therefore, the Utf8Buf must be at least 1.5 the size of the WideBuf. +// The function returns the number of *bytes* written. +function sdWideToUtf8Buffer(const WideBuf; var Utf8Buf; WideCount: integer): integer; + +// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process +// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes). +// Therefore, the block at Dst must be at least 2 times the size of Count, since +// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The +// function returns the number of *wide chars* written. Note that the Src block must +// have an exact number of UTF8 characters in it, if Count doesn't match then +// the last character will be converted anyway (going past the block boundary!) +function sdUtf8ToWideBuffer(const Utf8Buf; var WideBuf; ByteCount: integer): integer; + +implementation + +uses + NativeXmlNodes; + +type + TAnsiCharArray = array[0..32767] of AnsiChar; + + +{ TXmlNode } + +procedure TXmlNode.AttributeAdd(const AName, AValue: Utf8String); +var + A: TsdAttribute; +begin + A := TsdAttribute.Create(TNativeXml(FOwner)); + A.Name := AName; + A.Value := AValue; + NodeAdd(A); +end; + +procedure TXmlNode.AttributeAdd(AAttribute: TsdAttribute); +begin + if (AAttribute = nil) or (AAttribute.FOwner <> FOwner) then + begin + DoDebugOut(Self, wsFail, sXmlOwnerNotAssigned); + exit; + end; + NodeAdd(AAttribute); +end; + +procedure TXmlNode.AttributesAdd(Attributes: array of TsdAttribute); +var + x: integer; +begin + for x := Low(Attributes) to High(Attributes) do + AttributeAdd(Attributes[x]); +end; + +function TXmlNode.GetAttributeCount: integer; +var + i: integer; +begin + Result := 0; + for i := 0 to GetNodeCount - 1 do + if GetNodes(i) is TsdAttribute then + inc(Result); +end; + +constructor TXmlNode.Create(AOwner: TNativeXml); +begin + inherited Create; + FOwner := AOwner; + if not assigned(FOwner) then + raise Exception.Create(sXmlOwnerNotAssigned); +end; + +constructor TXmlNode.CreateName(AOwner: TNativeXml; const AName: Utf8String); +begin + Create(AOwner); + Name := AName; +end; + +constructor TXmlNode.CreateNameValue(AOwner: TNativeXml; const AName, AValue: Utf8String); +begin + Create(AOwner); + Name := AName; + Value := AValue; +end; + +function TXmlNode.ElementType: TsdElementType; +begin + Result := xeUnknown; +end; + +function TXmlNode.ElementTypeName: Utf8String; +begin + Result := cElementTypeNames[ElementType]; +end; + +class function TXmlNode.EscapeString(const S: Utf8String): Utf8String; +begin + Result := sdEscapeString(S); +end; + +function TXmlNode.FirstNodeByType(AType: TsdElementType): TXmlNode; +begin + Result := nil; +end; + +class function TXmlNode.WideToUtf8(const W: UnicodeString): Utf8String; +begin + Result := sdWideToUtf8(W); +end; + +function TXmlNode.GetAttributeByName(const AName: Utf8String): TsdAttribute; +var + i: integer; + A: TsdAttribute; +begin + for i := 0 to GetAttributeCount - 1 do + begin + A := GetAttributes(i); + if Utf8CompareText(A.Name, AName) = 0 then + begin + Result := A; + exit; + end; + end; + Result := nil; +end; + +function TXmlNode.GetAttributeName(Index: integer): Utf8String; +var + A: TsdAttribute; +begin + A := GetAttributes(Index); + if assigned(A) then + Result := A.Name + else + Result := ''; +end; + +function TXmlNode.GetAttributes(Index: integer): TsdAttribute; +var + i, Idx: integer; +begin + Idx := 0; + Result := nil; + for i := 0 to GetNodeCount - 1 do + begin + if GetNodes(i) is TsdAttribute then + begin + if Idx = Index then + begin + Result := TsdAttribute(GetNodes(i)); + exit; + end; + inc(Idx); + end; + end; +end; + +function TXmlNode.GetAttributeValue(Index: integer): Utf8String; +var + A: TsdAttribute; +begin + A := GetAttributes(Index); + if assigned(A) then + Result := A.Value + else + Result := ''; +end; + +function TXmlNode.GetAttributeValueAsInteger(Index: integer): integer; +begin + Result := StrToIntDef(GetAttributeValue(Index), 0); +end; + +function TXmlNode.GetAttributeValueByName(const AName: Utf8String): Utf8String; +var + A: TsdAttribute; +begin + A := GetAttributeByName(AName); + if assigned(A) then + Result := A.Value + else + Result := ''; +end; + +function TXmlNode.GetIndent: Utf8String; +var + i: integer; +begin + Result := ''; + if assigned(FOwner) then + begin + case GetXmlFormat of + xfCompact: Result := ''; + xfReadable: + for i := 0 to TreeDepth - 1 do + Result := Result + TNativeXml(FOwner).IndentString; + end; //case + end; +end; + +function TXmlNode.GetEndOfLine: Utf8String; +begin + Result := ''; + if GetXmlFormat = xfReadable then + begin + case GetEolStyle of + esLinux: Result := #$0A; + esWindows: Result := #$0D#$0A; + end; //case + end; +end; + +function TXmlNode.GetSeparator: Utf8String; +begin + Result := #$0A; + if GetEolStyle = esWindows then + Result := #$0D#$0A; +end; + +function TXmlNode.GetName: Utf8String; +begin + Result := ''; +end; + +function TXmlNode.GetNameUnicode: UnicodeString; +begin + Result := sdUtf8ToWide(GetName); +end; + +function TXmlNode.GetNodes(Index: integer): TXmlNode; +begin + Result := nil; +end; + +function TXmlNode.GetParentNode(ADepth: integer): TXmlNode; +var + i: integer; +begin + Result := Self; + for i := 0 to ADepth do + begin + Result := Result.FParent; + if not assigned(Result) then + exit; + end; +end; + +function TXmlNode.GetParentNodeName(ADepth: integer): Utf8String; +var + Node: TXmlNode; +begin + // parent node name + Node := GetParentNode(ADepth); + if assigned(Node) then + Result := Node.GetName + else + Result := ''; +end; + +function TXmlNode.GetValue: Utf8String; +begin + Result := ''; +end; + +function TXmlNode.GetValueUnicode: UnicodeString; +begin + Result := sdUtf8ToWide(GetValue); +end; + +function TXmlNode.IsClear: boolean; +begin + Result := IsEmpty and (length(Name) = 0); +end; + +function TXmlNode.IsEmpty: boolean; +begin + Result := (GetNodeCount = 0) and (length(Value) = 0) +end; + +function TXmlNode.IsEqualTo(ANode: TXmlNode; Options: TXmlCompareOptions; MismatchNodes: TList): boolean; +{ TXmlCompareOption = ( + xcNodeName, + xcNodeType, + xcNodeValue, + xcAttribCount, + xcAttribNames, + xcAttribValues, + xcChildCount, + xcChildNames, + xcChildValues, + xcRecursive + );} +var + ThisSubNode, ThatSubNode: TXmlNode; + NodeResult, ChildResult: boolean; + // local + procedure AddMismatchNode(ANode: TXmlNode); + begin + if assigned(MismatchNodes) then + MismatchNodes.Add(ANode); + end; + // local + function NodeCompareOptions: boolean; + begin + // We assume there are differences + Result := False; + + // node name + if xcNodeName in Options then + if Utf8CompareText(Name, ANode.Name) <> 0 then + exit; + + // node type + if xcNodeType in Options then + if ElementType <> ANode.ElementType then + exit; + + // node value + if xcNodeValue in Options then + if Utf8CompareText(Value, ANode.Value) <> 0 then + exit; + + // attribute count + if xcAttribCount in Options then + if AttributeCount <> ANode.AttributeCount then + exit; + + // child container count + if xcChildCount in Options then + if ContainerCount <> ANode.ContainerCount then + exit; + + // If we arrive here, it means no differences were found, return True + Result := True; + end; + // local + function ChildCompareOptions: boolean; + var + i: integer; + begin + Result := True; + + // child and attribute node names and values + if Options * [xcChildNames, xcChildValues, xcAttribNames, xcAttribValues] <> [] then + begin + // iterate nodes + for i := 0 to NodeCount - 1 do + begin + ThisSubNode := Nodes[i]; + if (ThisSubNode is TsdAttribute) or (ThisSubNode is TsdElement) then + begin + ThatSubNode := ANode.NodeByName(ThisSubNode.Name); + if not assigned(ThatSubNode) then + begin + // No we dont have it + if (xcChildNames in Options) or (xcAttribNames in Options) then + begin + AddMismatchNode(ThisSubNode); + Result := False; + end; + end else + begin + // Do child and attribute value check + if (xcChildValues in Options) or (xcAttribValues in Options) then + begin + if Utf8CompareText(ThisSubNode.Value, ThatSubNode.Value) <> 0 then + begin + AddMismatchNode(ThisSubNode); + Result := False; + end; + end; + // Do recursive check + if xcRecursive in Options then + if not ThisSubNode.IsEqualTo(ThatSubNode, Options, MismatchNodes) then + Result := False; + end; + end; + end; + end; + end; +// main +begin + Result := False; + if not assigned(ANode) then + exit; + + // node compare options + NodeResult := NodeCompareOptions; + if NodeResult = False then + AddMismatchNode(Self); + + // child compare options + ChildResult := ChildCompareOptions; + + // final result + Result := NodeResult and ChildResult; +end; + +function TXmlNode.NodeAdd(ANode: TXmlNode): integer; +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotAddNode); +end; + +function TXmlNode.NodeByName(const AName: Utf8String): TXmlNode; +var + i: integer; +begin + for i := 0 to GetNodeCount - 1 do + if Utf8CompareText(GetNodes(i).Name, AName) = 0 then + begin + Result := GetNodes(i); + exit; + end; + Result := nil; +end; + +function TXmlNode.GetNodeCount: integer; +begin + // functionality is in descendant TsdContainerNode + Result := 0; +end; + +procedure TXmlNode.NodeDelete(Index: integer); +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotManipulate); +end; + +procedure TXmlNode.NodesClear; +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotManipulate); +end; + +procedure TXmlNode.NodeRemove(ANode: TXmlNode); +var + Idx: integer; +begin + Idx := NodeIndexOf(ANode); + if Idx >= 0 then + NodeDelete(Idx); +end; + +function TXmlNode.NodeExtract(ANode: TXmlNode): TXmlNode; +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotManipulate); +end; + +procedure TXmlNode.NodeExchange(Index1, Index2: integer); +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotManipulate); +end; + +function TXmlNode.NodeIndexOf(ANode: TXmlNode): integer; +begin + // functionality is in descendant TsdContainerNode + Result := -1; +end; + +procedure TXmlNode.NodeInsert(Index: integer; ANode: TXmlNode); +begin + // functionality is in descendant TsdContainerNode + raise Exception.Create(sCannotAddNode); +end; + +function TXmlNode.NodeNew(const AName: Utf8String): TXmlNode; +// Add a new child node and return its pointer +var + NodeClass: TsdNodeClass; +begin + NodeClass := cNodeClass[ElementType]; + if not assigned(NodeClass) then + begin + Result := nil; + exit; + end; + + // Create new node + Result := NodeClass.Create(TNativeXml(FOwner)); + if assigned(Result) then + begin + Result.Name := AName; + NodeAdd(Result); + end; +end; + +function TXmlNode.NodeNewAtIndex(Index: integer; const AName: Utf8String): TXmlNode; +// Create a new node with AName, and insert it into the subnode list at location +// Index, and return a pointer to it. +var + NodeClass: TsdNodeClass; +begin + NodeClass := cNodeClass[ElementType]; + if not assigned(NodeClass) then + begin + Result := nil; + exit; + end; + + // Create new node + Result := NodeClass.Create(TNativeXml(FOwner)); + if assigned(Result) then + begin + Result.Name := AName; + NodeInsert(Index, Result); + end; +end; + +function TXmlNode.ParseStream(Parser: TsdXmlParser): TXmlNode; +// Result = EndNode +begin + // functionality in descendants + Result := Self; +end; + +procedure TXmlNode.SetAttributeName(Index: integer; const Value: Utf8String); +var + A: TsdAttribute; +begin + A := GetAttributes(Index); + if not assigned(A) then + exit; + A.Name := Value; +end; + +procedure TXmlNode.SetAttributeValue(Index: integer; const Value: Utf8String); +var + A: TsdAttribute; +begin + A := GetAttributes(Index); + if not assigned(A) then + exit; + A.Value := Value; +end; + +procedure TXmlNode.SetAttributeValueAsInteger(Index: integer; const Value: integer); +begin + SetAttributeValue(Index, IntToStr(Value)); +end; + +procedure TXmlNode.SetAttributeValueByName(const AName, Value: Utf8String); +var + A: TsdAttribute; +begin + A := GetAttributeByName(AName); + if not assigned(A) then + begin + A := TsdAttribute.Create(TNativeXml(FOwner)); + A.Name := AName; + NodeAdd(A); + end; + A.Value := Value; +end; + +procedure TXmlNode.SetName(const Value: Utf8String); +begin + // functionality in descendants + raise Exception.Create(sCannotSetName); +end; + +procedure TXmlNode.SetNameUnicode(const Value: UnicodeString); +begin + SetName(sdWideToUtf8(Value)); +end; + +procedure TXmlNode.SetValue(const Value: Utf8String); +begin + // functionality in descendants + raise Exception.Create(sCannotSetValue); +end; + +procedure TXmlNode.SetValueUnicode(const Value: UnicodeString); +begin + SetValue(sdWideToUtf8(Value)); +end; + +function TXmlNode.GetString(AID: integer): Utf8String; +var + Table: TsdStringTable; +begin + Result := ''; + if assigned(FOwner) then + begin + Table := TNativeXml(FOwner).FStringTable; + if assigned(Table) then + Result := Table.GetString(AID); + end; +end; + +function TXmlNode.AddString(const S: Utf8String): integer; +var + Table: TsdStringTable; +begin + Result := 0; + if assigned(FOwner) then + begin + Table := TNativeXml(FOwner).FStringTable; + if assigned(Table) then + Result := Table.AddString(S) + end; +end; + +class function TXmlNode.Utf8ToWide(const S: Utf8String): UnicodeString; +begin + Result := sdUtf8ToWide(S); +end; + +function TXmlNode.TreeDepth: integer; +begin + if assigned(FParent) then + Result := FParent.TreeDepth + 1 + else + Result := 0; +end; + +class function TXmlNode.ReplaceString(const S: Utf8String): Utf8String; +begin + Result := sdReplaceString(S); +end; + +procedure TXmlNode.WriteStream(S: TStream); +begin +// functionality is in descendants +end; + +function TXmlNode.ReadAttributeBool(const AName: Utf8String; ADefault: boolean = False): boolean; +begin + Result := StrToBoolDef(AttributeValueByName[AName], ADefault); +end; + +function TXmlNode.ReadAttributeInteger(const AName: Utf8String; ADefault: integer = 0): integer; +begin + Result := StrToIntDef(AttributeValueByName[AName], ADefault); +end; + +function TXmlNode.ReadAttributeInt64(const AName: Utf8String; ADefault: int64): int64; // added by hdk +begin + Result := StrToInt64Def(AttributeValueByName[AName], ADefault); +end; + +function TXmlNode.ReadAttributeFloat(const AName: Utf8String; ADefault: double = 0): double; +begin + Result := StrToFloatDef(AttributeValueByName[AName], ADefault, cXmlFormatSettings); // changed by hdk +end; + +function TXmlNode.ReadAttributeString(const AName: Utf8String; ADefault: Utf8String = ''): Utf8String; +begin + Result := AttributeValueByName[AName]; + if Length(Result) = 0 then + Result := ADefault; +end; + +function TXmlNode.ReadAttributeUnicodeString(const AName: Utf8String; ADefault: UnicodeString): UnicodeString; // added by hdk +begin + Result := sdUtf8ToWide(AttributeValueByName[AName]); + if Length(Result) = 0 then + Result := ADefault; +end; + +function TXmlNode.ReadAttributeAnsiString(const AName: Utf8String; ADefault: AnsiString): AnsiString; // added by hdk +begin + Result := sdUtf8ToAnsi(AttributeValueByName[AName], CP_ACP); + if Length(Result) = 0 then + Result := ADefault; +end; + +function TXmlNode.ReadAttributeDateTime(const AName: Utf8String; ADefault: TDateTime): TDateTime; // added by hdk +begin + Result := sdStringToDateTimeDef(AttributeValueByName[AName], ADefault, TNativeXml(FOwner).FUseLocalBias); +end; + +function TXmlNode.ReadBool(const AName: Utf8String; ADefault: boolean = False): boolean; +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.GetValueAsBoolDef(ADefault); +end; + +procedure TXmlNode.ReadPen(const AName: UTF8String; APen: TPen); +var + Child: TXmlNode; +begin + Child := NodeByName(AName); + if assigned(Child) then with Child do + begin + // Read values + APen.Color := ReadColor('Color', clBlack); + APen.Mode := TPenMode(ReadInteger('Mode', integer(pmCopy))); + APen.Style := TPenStyle(ReadInteger('Style', integer(psSolid))); + APen.Width := ReadInteger('Width', 1); + end else + begin + // Defaults + APen.Color := clBlack; + APen.Mode := pmCopy; + APen.Style := psSolid; + APen.Width := 1; + end; +end; + +procedure TXmlNode.ReadBrush(const AName: Utf8String; ABrush: TBrush); +var + Child: TXmlNode; +begin + Child := NodeByName(AName); + if assigned(Child) then with Child do + begin + // Read values + ABrush.Color := ReadColor('Color', clWhite); + ABrush.Style := TBrushStyle(ReadInteger('Style', integer(bsSolid))); + end else + begin + // Defaults + ABrush.Bitmap := nil; + ABrush.Color := clWhite; + ABrush.Style := bsSolid; + end; +end; + +function TXmlNode.ReadColor(const AName: Utf8String; ADefault: TColor = 0): TColor; +begin + Result := ReadInteger(AName, integer(ADefault)); +end; + +function TXmlNode.ReadDateTime(const AName: Utf8String; ADefault: TDateTime): TDateTime; +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.GetValueAsDateTimeDef(ADefault); +end; + +function TXmlNode.ReadFloat(const AName: UTF8String; ADefault: double): double; +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.GetValueAsFloatDef(ADefault); +end; + +function TXmlNode.ReadInteger(const AName: Utf8String; ADefault: integer): integer; +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.GetValueAsIntegerDef(ADefault); +end; + +function TXmlNode.ReadInt64(const AName: Utf8String; ADefault: int64): int64; // added by hdk +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.GetValueAsInt64Def(ADefault); +end; + +function TXmlNode.ReadString(const AName: Utf8String; const ADefault: Utf8String = ''): Utf8String; +var + Child: TXmlNode; +begin + Result := ADefault; + Child := NodeByName(AName); + if assigned(Child) then + Result := Child.Value; +end; + +function TXmlNode.ReadUnicodeString(const AName: UTF8String; const ADefault: UnicodeString): UnicodeString; +begin + Result := sdUtf8ToWide(ReadString(AName, sdWideToUtf8(ADefault))); +end; + +function TXmlNode.ReadAnsiString(const AName: Utf8String; const ADefault: AnsiString): AnsiString; // added by hdk +begin + Result := sdUtf8ToAnsi(ReadString(AName, sdAnsiToUtf8(ADefault, CP_ACP)), CP_ACP); +end; + +function TXmlNode.GetValueAsBoolDef(ADefault: boolean): boolean; +begin + Result := StrToBoolDef(GetValue, ADefault); +end; + +function TXmlNode.GetValueAsDateTimeDef(ADefault: TDateTime): TDateTime; +begin + Result := sdStringToDateTimeDef(GetValue, ADefault); +end; + +function TXmlNode.GetValueAsFloatDef(ADefault: double): double; +var + V: Utf8String; +begin + // backwards compat: old version used to allow commas in floats + V := sdCommaToDot(GetValue); + Result := StrToFloatDef(V, ADefault, cXmlFormatSettings); // changed by hdk +end; + +function TXmlNode.GetValueAsIntegerDef(ADefault: integer): integer; +begin + Result := StrToIntDef(GetValue, ADefault); +end; + +function TXmlNode.GetValueAsInt64Def(ADefault: int64): int64; +begin + Result := StrToInt64Def(GetValue, ADefault); +end; + +function TXmlNode.GetValueAsBool: boolean; +begin + Result := StrToBool(GetValue); +end; + +function TXmlNode.GetValueAsDateTime: TDateTime; +begin + Result := sdStringToDateTime(GetValue); +end; + +function TXmlNode.GetValueAsFloat: double; +begin + Result := StrToFloat(GetValue, cXmlFormatSettings); // changed by hdk +end; + +function TXmlNode.GetValueAsInteger: integer; +begin + Result := StrToInt(GetValue); +end; + +function TXmlNode.GetValueAsInt64: int64; +begin + Result := StrToInt64(GetValue); +end; + +procedure TXmlNode.SetValueAsBool(const AValue: boolean); +begin + SetValue(sdBoolToString(AValue)); +end; + +procedure TXmlNode.SetValueAsDate(const AValue: TDateTime); +begin + SetValue(sdDateTimeToString(AValue, True, False, 0, False)); +end; + +procedure TXmlNode.SetValueAsTime(const AValue: TDateTime); +begin + SetValue(sdDateTimeToString(AValue, False, True, + 0, TNativeXml(FOwner).FUseLocalBias)); +end; + +procedure TXmlNode.SetValueAsDateTime(const AValue: TDateTime); +begin + SetValue(sdDateTimeToString(AValue, TNativeXml(FOwner).FUseLocalBias)); +end; + +procedure TXmlNode.SetValueAsFloat(const AValue: double); +begin + SetValue(sdFloatToString(AValue, + TNativeXml(FOwner).FFloatSignificantDigits, + TNativeXml(FOwner).FFloatAllowScientific)); +end; + +procedure TXmlNode.SetValueAsInteger(const AValue: integer); +begin + SetValue(sdIntToString(AValue)); +end; + +procedure TXmlNode.SetValueAsInt64(const AValue: int64); +begin + SetValue(sdInt64ToString(AValue)); +end; + +procedure TXmlNode.NodesByName(const AName: Utf8String; const AList: TList); +// Fill AList with nodes that have name AName +var + i: integer; +begin + if not assigned(AList) or not assigned(Self) then + exit; + AList.Clear; + for i := 0 to GetNodeCount - 1 do + if Utf8CompareText(Nodes[i].Name, AName) = 0 then + AList.Add(Nodes[i]); +end; + +procedure TXmlNode.WriteBool(const AName: Utf8String; AValue, ADefault: boolean); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, sdBoolToString(AValue)); +end; + +procedure TXmlNode.WriteDateTime(const AName: Utf8String; AValue, ADefault: TDateTime); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, sdDateTimeToString(AValue, + TNativeXml(FOwner).FUseLocalBias)); +end; + +procedure TXmlNode.WriteFloat(const AName: UTF8String; AValue, ADefault: double); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, sdFloatToString(AValue, + TNativeXml(FOwner).FFloatSignificantDigits, + TNativeXml(FOwner).FFloatAllowScientific)); +end; + +procedure TXmlNode.WriteHex(const AName: UTF8String; AValue, Digits: integer; ADefault: integer); +var + HexString: Utf8String; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + HexString := '$' + Utf8String(IntToHex(AValue, Digits)); + WriteValue(AName, HexString); + end; +end; + +procedure TXmlNode.WriteInteger(const AName: Utf8String; AValue, ADefault: integer); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, sdIntToString(AValue)); +end; + +procedure TXmlNode.WriteInt64(const AName: Utf8String; AValue, ADefault: int64); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, sdInt64ToString(AValue)); +end; + +procedure TXmlNode.WriteString(const AName, AValue, ADefault: Utf8String); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteValue(AName, AValue); +end; + +procedure TXmlNode.WriteUnicodeString(const AName: Utf8String; const AValue, ADefault: UnicodeString); +begin + WriteString(AName, sdWideToUtf8(AValue), sdWideToUtf8(ADefault)); +end; + +procedure TXmlNode.WriteAnsiString(const AName: Utf8String; const AValue, ADefault: AnsiString); // added by hdk +begin + WriteString(AName, sdAnsiToUtf8(AValue, CP_ACP), sdAnsiToUtf8(ADefault, CP_ACP)); +end; + +procedure TXmlNode.NodesAdd(Nodes: array of TXmlNode); +var + x: integer; +begin + for x := Low(Nodes) to High(Nodes) do + NodeAdd(Nodes[x]); +end; + +function TXmlNode.GetWriteOnDefault: boolean; +begin + if assigned(FOwner) then + Result := TNativeXml(FOwner).WriteOnDefault + else + Result := False; +end; + +procedure TXmlNode.SetWriteOnDefault(const Value: boolean); +begin + if assigned(FOwner) then + TNativeXml(FOwner).WriteOnDefault := Value; +end; + +function TXmlNode.NodeFindOrCreate(const AName: Utf8String): TXmlNode; +// Find the node with AName, and if not found, add new one +begin + Result := NodeByName(AName); + if not assigned(Result) then + Result := NodeNew(AName); +end; + +function TXmlNode.NodeIndexByName(const AName: Utf8String): integer; +begin + Result := 0; + while Result < NodeCount do + begin + if Utf8CompareText(Nodes[Result].Name, AName) = 0 then + exit; + inc(Result); + end; + if Result = NodeCount then + Result := -1; +end; + +function TXmlNode.AttributeIndexByName(const AName: Utf8String): integer; +begin + Result := 0; + // attributes are nodes from 0 to DirectNodeCount - 1 + while Result < DirectNodeCount do + begin + if Utf8CompareText(Nodes[Result].Name, AName) = 0 then + exit; + inc(Result); + end; + if Result = DirectNodeCount then + Result := -1; +end; + +procedure TXmlNode.WriteValue(const AName, AValue: Utf8String); +var + Child: TXmlNode; +begin + Child := NodeFindOrCreate(AName); + if assigned(Child) then + Child.Value := AValue; +end; + +procedure TXmlNode.DoProgress(Position: int64); +begin + // Call the onprogress + if assigned(FOwner) then + TNativeXml(FOwner).DoProgress(Position); +end; + +function TXmlNode.BufferLength: integer; +var + BufData: Utf8String; + BufPos: integer; +begin + BufData := sdRemoveControlChars(GetValue); + Result := length(BufData) div 4; + if Result * 4 <> length(BufData) then + raise EFilerError.Create(sErrorCalcStreamLength); + Result := Result * 3; + // Check padding chars + BufPos := length(BufData); + if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then + begin + dec(BufPos); + dec(Result); + if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then + dec(Result); + end; +end; + +procedure TXmlNode.BufferRead(var Buffer; Count: Integer; BinaryEncoding: TsdBinaryEncoding); +// Read data from XML base64/Binhex to the buffer (default is xbeBase64) +var + BufData: Utf8String; +begin + BufData := sdRemoveControlChars(GetValue); + case BinaryEncoding of + xbeBase64: + // this is the default method + DecodeBase64Buf(BufData, Buffer, Count); + xbeBinHex: + // for compat with older versions + DecodeBinhexBuf(BufData, Buffer, Count); + end; +end; + +procedure TXmlNode.BufferWrite(const Buffer; Count: Integer); +// Write data from the buffer to XML in base64 format +var + BufData: Utf8String; +begin + if Count > 0 then + BufData := EncodeBase64Buf(Buffer, Count); + + // For comformity with Base64, we must add linebreaks + SetValue(sdAddControlChars(BufData, GetEndOfLine + GetIndent)); +end; + +procedure TXmlNode.WriteAttributeInteger(const AName: Utf8String; AValue, ADefault: integer); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdIntToString(AValue); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeInt64(const AName: UTF8String; AValue, ADefault: int64); // added by hdk +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdInt64ToString(AValue); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeFloat(const AName: Utf8String; AValue, ADefault: double); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdFloatToString(AValue, + TNativeXml(FOwner).FFloatSignificantDigits, + TNativeXml(FOwner).FFloatAllowScientific); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeString(const AName: Utf8String; AValue, ADefault: Utf8String); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := AValue; + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeUnicodeString(const AName: Utf8String; const AValue, ADefault: UnicodeString); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdWideToUtf8(AValue); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeAnsiString(const AName: Utf8String; const AValue, ADefault: AnsiString); // added by hdk +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdAnsiToUtf8(AValue, CP_ACP); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeDateTime(const AName: Utf8String; AValue, ADefault: TDateTime); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdDateTimeToString(AValue, TNativeXml(FOwner).FUseLocalBias); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WriteAttributeBool(const AName: Utf8String; AValue, ADefault: boolean); +var + S: Utf8String; + A: TsdAttribute; +begin + if WriteOnDefault or (AValue <> ADefault) then + begin + A := AttributeByName[AName]; + S := sdBoolToString(AValue); + if assigned(A) then + A.Value := S + else + AttributeAdd(AName, S); + end; +end; + +procedure TXmlNode.WritePen(const AName: Utf8String; APen: TPen); +begin + with NodeFindOrCreate(AName) do + begin + WriteColor('Color', APen.Color, clBlack); + WriteInteger('Mode', integer(APen.Mode), 0); + WriteInteger('Style', integer(APen.Style), 0); + WriteInteger('Width', APen.Width, 0); + end; +end; + +procedure TXmlNode.WriteBrush(const AName: Utf8String; ABrush: TBrush); +begin + with NodeFindOrCreate(AName) do + begin + WriteColor('Color', ABrush.Color, clBlack); + WriteInteger('Style', integer(ABrush.Style), 0); + end; +end; + +procedure TXmlNode.WriteColor(const AName: UTF8String; AValue, ADefault: TColor); +begin + if WriteOnDefault or (AValue <> ADefault) then + WriteHex(AName, ColorToRGB(AValue), 8, 0); +end; + +function TXmlNode.GetBinaryString: RawByteString; +begin + SetLength(Result, BufferLength); + if length(Result) > 0 then + BufferRead(Result[1], length(Result)); +end; + +procedure TXmlNode.SetBinaryString(const Value: RawByteString); +begin + if length(Value) = 0 then + begin + SetValue(''); + exit; + end; + // fill the buffer + BufferWrite(Value[1], length(Value)); +end; + +function TXmlNode.GetEolStyle: TsdEolStyle; +begin + if assigned(FOwner) then + Result := TNativeXml(FOwner).FEolStyle + else + Result := cDefaultEolStyle; +end; + +function TXmlNode.GetPreserveWhiteSpace: boolean; +begin + if assigned(FOwner) then + Result := TNativeXml(FOwner).FPreserveWhiteSpace + else + Result := cDefaultPreserveWhiteSpace; +end; + +function TXmlNode.GetSkipNormalisation: boolean; +begin + if assigned(FOwner) then + Result := TNativeXml(FOwner).FSkipNormalisation + else + Result := False; +end; + +function TXmlNode.GetXmlFormat: TsdXmlFormatType; +begin + if assigned(FOwner) then + Result := TNativeXml(FOwner).FXmlFormat + else + Result := cDefaultXmlFormat; +end; + +procedure TXmlNode.DoNodeLoaded(ANode: TXmlNode); +begin + if assigned(FOwner) then + TNativeXml(FOwner).DoNodeLoaded(ANode); +end; + +procedure TXmlNode.DoNodeNew(ANode: TXmlNode); +begin + if assigned(FOwner) then + TNativeXml(FOwner).DoNodeNew(ANode); +end; + +function TXmlNode.GetContent: Utf8String; +var + S: TsdStringStream; +begin + S := TsdStringStream.Create(''); + try + WriteContent(S); + Result := S.DataString; + finally + S.Free; + end; +end; + +procedure TXmlNode.WriteContent(S: TStream); +begin +// functionality in descendants +end; + +function TXmlNode.NodeByAttributeValue(const NodeName, AttribName, + AttribValue: Utf8String; ShouldRecurse: boolean): TXmlNode; +// This function returns a pointer to the first subnode that has an attribute with +// name AttribName and value AttribValue. +var + i: integer; + Node: TXmlNode; +begin + Result := nil; + // Find all nodes that are potential results + for i := 0 to NodeCount - 1 do + begin + Node := Nodes[i]; + if (UTF8CompareText(Node.Name, NodeName) = 0) and + Node.HasAttribute(AttribName) and + (UTF8CompareText(Node.AttributeValueByName[AttribName], AttribValue) = 0) then + begin + Result := Node; + exit; + end; + // Recursive call + if ShouldRecurse then + Result := Node.NodeByAttributeValue(NodeName, AttribName, AttribValue, True); + if assigned(Result) then + exit; + end; +end; + +function TXmlNode.HasAttribute(const AName: Utf8String): boolean; +var + i: integer; +begin + for i := 0 to AttributeCount - 1 do + if AttributeName[i] = AName then + begin + Result := True; + exit; + end; + Result := False; +end; + +procedure TXmlNode.Clear; +begin +// functionality in descendants +end; + +procedure TXmlNode.DeleteEmptyNodes; +var + i: integer; + Node: TXmlNode; +begin + for i := NodeCount - 1 downto 0 do + begin + Node := Nodes[i]; + // Recursive call + Node.DeleteEmptyNodes; + // Check if we should delete child node + if Node.IsEmpty then + NodeDelete(i); + end; +end; + +procedure TXmlNode.Assign(Source: TPersistent); +begin + if Source is TXmlNode then + begin + CopyFrom(TXmlNode(Source)); + end else + inherited; +end; + +function TXmlNode.WriteToString: Utf8String; +var + SS: TsdStringStream; +begin + SS := TsdStringStream.Create(''); + WriteStream(SS); + Result := SS.DataString; +end; + +procedure TXmlNode.CopyFrom(ANode: TXmlNode); +begin + Clear; +// other functionality is in descendants +end; + +function TXmlNode.FindNode(const NodeName: Utf8String): 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: Utf8String; const AList: TList); + // local + procedure FindNodesRecursive(ANode: TXmlNode; AList: TList); + var + i: integer; + SubNode: TXmlNode; + begin + for i := 0 to ANode.NodeCount - 1 do + begin + SubNode := ANode.Nodes[i]; + if SubNode.CompareNodeName(NodeName) = 0 then + AList.Add(SubNode); + FindNodesRecursive(SubNode, AList); + end; + end; +// main +begin + AList.Clear; + FindNodesRecursive(Self, AList); +end; + +function TXmlNode.CompareNodeName(const NodeName: Utf8String): integer; +begin + // Compare with FullPath or local name based on NodeName's first character + if length(NodeName) > 0 then + begin + if NodeName[1] = '/' then + begin + // FullPath + Result := Utf8CompareText(FullPath, NodeName); + exit; + end; + end; + // local name + Result := Utf8CompareText(Name, NodeName); +end; + +function TXmlNode.GetFullPath: Utf8String; +// GetFullpath will return the complete path of the node from the root, e.g. +// /Root/SubNode1/SubNode2/ThisNode +begin + Result := '/' + Name; + if Treedepth > 0 then + // Recursive call + Result := Parent.GetFullPath + Result; +end; + +procedure TXmlNode.Delete; +begin + if assigned(Parent) then + Parent.NodeRemove(Self); +end; + +function TXmlNode.GetDirectNodeCount: integer; +begin +// functionality in descendants + Result := 0; +end; + +function TXmlNode.GetContainerCount: integer; +begin +// functionality in descendants + Result := 0; +end; + +function TXmlNode.GetContainers(Index: integer): TXmlNode; +begin +// functionality in descendants + Result := nil; +end; + +function TXmlNode.GetDocument: TNativeXml; +begin + if FOwner is TNativeXml then + Result := TNativeXml(FOwner) + else + Result := nil; +end; + +procedure TXmlNode.SetAttributeValueByNameWide(const AName: Utf8String; const Value: UnicodeString); +begin + AttributeValueByName[AName] := sdWidetoUTF8(Value); +end; + +function TXmlNode.GetAttributeValueByNameWide(const AName: Utf8String): UnicodeString; +begin + Result := sdUtf8ToWide(AttributeValueByName[AName]); +end; + +function TXmlNode.IndexInParent: integer; +// Retrieve our index in the parent's nodelist +begin + Result := -1; + if assigned(Parent) then + Result := Parent.NodeIndexOf(Self); +end; + +function TXmlNode.NodeByAttributeValue(const NodeName, AttribName: Utf8String; const AttribValue: UnicodeString; + ShouldRecurse: boolean): TXmlNode; +begin + Result := NodeByAttributeValue(NodeName, AttribName, sdWideToUtf8(AttribValue), ShouldRecurse); +end; + +procedure TXmlNode.SortChildNodes(Compare: TXmlNodeCompareFunction); +// Sort the child nodes using the quicksort algorithm + //local + function DoNodeCompare(Node1, Node2: TXmlNode): integer; + begin + if assigned(Compare) then + Result := Compare(Node1, Node2) + else + Result := Utf8CompareText(Node1.Name, Node2.Name); + end; + // local + procedure QuickSort(iLo, iHi: Integer); + var + Lo, Hi, Mid: longint; + begin + Lo := iLo; + Hi := iHi; + Mid:= (Lo + Hi) div 2; + repeat + while DoNodeCompare(Nodes[Lo], Nodes[Mid]) < 0 do + Inc(Lo); + while DoNodeCompare(Nodes[Hi], Nodes[Mid]) > 0 do + Dec(Hi); + if Lo <= Hi then + begin + // Swap pointers; + NodeExchange(Lo, Hi); + if Mid = Lo then + Mid := Hi + else + if Mid = Hi then + Mid := Lo; + Inc(Lo); + Dec(Hi); + end; + until Lo > Hi; + if Hi > iLo then + QuickSort(iLo, Hi); + if Lo < iHi then + QuickSort(Lo, iHi); + end; +// main +begin + if NodeCount > 1 then + QuickSort(0, NodeCount - 1); +end; + +procedure TXmlNode.AttributeDelete(Index: integer); +var + Attribute: TsdAttribute; +begin + Attribute := Attributes[Index]; + if assigned(Attribute) then + NodeRemove(Attribute); +end; + +procedure TXmlNode.AttributesClear; +begin + while AttributeCount > 0 do + begin + AttributeDelete(0); + end; +end; + +{ TsdCharData } + +destructor TsdCharData.Destroy; +begin + FCoreValueID := 0; + inherited; +end; + +function TXmlNode.NextSibling(ANode: TXmlNode): TXmlNode; +begin + // default is nil, iterating only starts from TsdContainerNode + Result := nil; +end; + + +function TsdCharData.ElementType: TsdElementType; +begin + Result := xeCharData; +end; + +function TsdCharData.GetName: Utf8String; +begin + Result := ElementTypeName; +end; + +function TsdCharData.GetCoreValue: Utf8String; +begin + Result := GetString(FCoreValueID); +end; + +function TsdCharData.GetValue: Utf8String; +begin + Result := sdReplaceString(GetCoreValue) +end; + +function TsdCharData.GetValueUsingReferences(Nodes: array of TXmlNode): Utf8String; +var + HasNonStandardReferences: boolean; +begin + Result := sdReplaceString(GetCoreValue, HasNonStandardReferences, Nodes); +end; + +procedure TsdCharData.SetCoreValue(const Value: Utf8String); +begin + FCoreValueID := AddString(Value); +end; + +procedure TsdCharData.SetValue(const Value: Utf8String); +begin + SetCoreValue(sdEscapeString(Value)) +end; + +procedure TsdCharData.WriteStream(S: TStream); +begin + sdWriteToStream(S, GetCoreValue); +end; + +procedure TsdCharData.SetName(const Value: Utf8String); +begin + // since the API is general with LINQ style, we allow a setter but in the + // XML the chardata name will not be present + if Length(Value) > 0 then + DoDebugOut(Self, wsHint, sCannotSetName); +end; + +procedure TsdCharData.CopyFrom(ANode: TXmlNode); +begin + inherited; + SetCoreValue(TsdCharData(ANode).GetCoreValue); +end; + +function TsdCharData.HasNonStandardReferences: boolean; +var + Res: boolean; +begin + sdReplaceString(GetCoreValue, Res); + Result := Res; +end; + +{ TsdWhitespace } + +function TsdWhitespace.ElementType: TsdElementType; +begin + Result := xeWhiteSpace; +end; + +{ TsdAttribute } + +procedure TsdAttribute.CopyFrom(ANode: TXmlNode); +begin + inherited; + // copy depending data + FCoreValue.CopyFrom(TsdAttribute(ANode).FCoreValue); + // copy other data + SetName(TsdAttribute(ANode).GetName); +end; + +constructor TsdAttribute.Create(AOwner: TNativeXml); +begin + inherited Create(AOwner); + FCoreValue := TsdQuotedText.Create(AOwner); + FCoreValue.FParent := Self; +end; + +destructor TsdAttribute.Destroy; +begin + FNameID := 0; + FreeAndNil(FCoreValue); + inherited; +end; + +function TsdAttribute.ElementType: TsdElementType; +begin + Result := xeAttribute; +end; + +function TsdAttribute.GetName: Utf8String; +begin + Result := GetString(FNameID); +end; + +function TsdAttribute.GetValue: Utf8String; +begin + if assigned(FCoreValue) then + Result := sdReplaceString(FCoreValue.GetCoreValue) + else + Result := ''; +end; + +function TsdAttribute.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + IsTrimmed: boolean; +begin + Result := Self; + FSourcePos := Parser.Position; + // Get the attribute name + FNameID := AddString(sdTrim(Parser.ReadStringUntilChar('='), IsTrimmed)); + if assigned(FCoreValue) then + // value + FCoreValue.ParseStream(Parser); +end; + +procedure TsdAttribute.SetName(const Value: Utf8String); +begin + FNameID := AddString(Value); +end; + +procedure TsdAttribute.SetValue(const Value: Utf8String); +begin + if assigned(FCoreValue) then + FCoreValue.SetCoreValue(sdEscapeString(Value)); +end; + +procedure TsdAttribute.WriteStream(S: TStream); +begin + sdWriteToStream(S, GetName + '='); + // now add the quoted value + if assigned(FCoreValue) then + FCoreValue.WriteStream(S); +end; + +{ TsdQuotedText } + +procedure TsdQuotedText.CopyFrom(ANode: TXmlNode); +begin + inherited; + FQuoteChar := TsdQuotedText(ANode).FQuoteChar; +end; + +constructor TsdQuotedText.Create(AOwner: TNativeXml); +begin + inherited Create(AOwner); + FQuoteChar := '"'; +end; + +function TsdQuotedText.ElementType: TsdElementType; +begin + Result := xeQuotedText; +end; + +function TsdQuotedText.GetName: Utf8String; +begin + Result := ElementTypeName; +end; + +function TsdQuotedText.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + Blanks: Utf8String; +begin + Result := Self; + // Get the quoted value + FQuoteChar := Parser.NextCharSkipBlanks(Blanks); + if not (FQuoteChar in cXmlQuoteChars) then + begin + DoDebugOut(Self, wsWarn, Format(sQuoteCharExpected, [Parser.Position])); + exit; + end; + FCoreValueID := AddString(Parser.ReadQuotedString(FQuoteChar)); +end; + +procedure TsdQuotedText.WriteStream(S: TStream); +begin + sdWriteToStream(S, FQuoteChar + GetCoreValue + FQuoteChar); + DoProgress(S.Position); +end; + +{ TsdContainerNode } + +constructor TsdContainerNode.Create(AOwner: TNativeXml); +begin + inherited Create(AOwner); + FNodes := TsdNodeList.Create(True); + FDirectNodeCount := 0; + FValueIndex := -1; +end; + +destructor TsdContainerNode.Destroy; +begin + FreeAndNil(FNodes); + inherited; +end; + +function TsdContainerNode.FirstNodeByType(AType: TsdElementType): TXmlNode; +begin + Result := FNodes.ByType(AType); +end; + +function TsdContainerNode.GetNodes(Index: integer): TXmlNode; +begin + if (Index >= 0) and (Index < FNodes.Count) then + Result := FNodes[Index] + else + Result := nil; +end; + +function TsdContainerNode.HasSubContainers: boolean; +var + i: integer; +begin + // determine if there is at least one subcontainer + Result := False; + for i := FDirectNodeCount to FNodes.Count - 1 do + begin + if FNodes[i] is TsdContainerNode then + begin + Result := True; + break; + end; + end; +end; + +function TsdContainerNode.NodeAdd(ANode: TXmlNode): integer; +begin + Result := -1; + if not assigned(ANode) then + exit; + // attributes and whitespace are handled separately because NodeAdd may be called with attributes + // after elements in client apps (even tho this is not best practice) + if (ANode is TsdAttribute) or (ANode is TsdWhiteSpace) then + begin + // attributes inserted at FDirectNodeCount (and this value incremented) + FNodes.Insert(FDirectNodeCount, ANode); + Result := FDirectNodeCount; + inc(FDirectNodeCount); + end else + begin + // other subnodes like elements and CharData: add at the end of the list + Result := FNodes.Add(ANode); + end; + ANode.FParent := Self; +end; + +function TsdContainerNode.GetNodeCount: integer; +begin + Result := FNodes.Count +end; + +procedure TsdContainerNode.NodeDelete(Index: integer); +begin + FNodes.Delete(Index); +end; + +procedure TsdContainerNode.NodeExchange(Index1, Index2: integer); +begin + FNodes.Exchange(Index1, Index2); +end; + +function TsdContainerNode.NodeExtract(ANode: TXmlNode): TXmlNode; +begin + Result := TXmlNode(FNodes.Extract(ANode)); +end; + +function TsdContainerNode.NodeIndexOf(ANode: TXmlNode): integer; +begin + Result := FNodes.IndexOf(ANode); +end; + +procedure TsdContainerNode.NodesClear; +var + i: integer; +begin + for i := NodeCount - 1 downto 0 do + begin + NodeDelete(i); + end; + FDirectNodeCount := 0; + FValueIndex := -1; +end; + +procedure TsdContainerNode.NodeInsert(Index: integer; ANode: TXmlNode); +begin + FNodes.Insert(Index, ANode); + ANode.FParent := Self; +end; + +function TsdContainerNode.ParseAttributeList(Parser: TsdXmlParser): AnsiChar; +var + Blanks: Utf8String; + AttributeNode: TsdAttribute; + WhiteSpaceNode: TsdWhiteSpace; +begin + repeat + Result := Parser.NextCharSkipBlanks(Blanks); + if Length(Blanks) > 0 then + begin + if Blanks <> ' ' then + begin + DoDebugOut(Self, wsHint, Format(sNonDefaultChardata, [Parser.LineNumber, Parser.Position])); + // add non-default blank chardata + if GetPreserveWhiteSpace then + begin + WhiteSpaceNode := TsdWhiteSpace.Create(TNativeXml(FOwner)); + NodeAdd(WhiteSpaceNode); + WhiteSpaceNode.SetValue(Blanks); + end; + end + end; + + // Are any of the characters determining the end? + if Result in ['!', '/', '>' ,'?'] then + exit; + + Parser.MoveBack; + AttributeNode := TsdAttribute.Create(TNativeXml(FOwner)); + NodeAdd(AttributeNode); + DoNodeNew(AttributeNode); + AttributeNode.ParseStream(Parser); + DoNodeLoaded(AttributeNode); + until Parser.EndOfStream; +end; + +function TsdContainerNode.ParseQuotedTextList(Parser: TsdXmlParser): AnsiChar; +var + Blanks: Utf8String; + QuotedTextNode: TsdQuotedText; +begin + repeat + Result := Parser.NextCharSkipBlanks(Blanks); + if (Length(Blanks) > 0) and (Blanks <> ' ') then + begin + DoDebugOut(Self, wsHint, Format(sNonDefaultChardata, [Parser.Position])); + end; + + // Are any of the characters determining the end? + if Result in ['!', '/', '>' ,'?'] then + exit; + + Parser.MoveBack; + QuotedTextNode := TsdQuotedText.Create(TNativeXml(FOwner)); + QuotedTextNode.ParseStream(Parser); + NodeAdd(QuotedTextNode); + DoNodeNew(QuotedTextNode); + DoNodeLoaded(QuotedTextNode); + until Parser.EndOfStream; +end; + +procedure TsdContainerNode.WriteAttributeList(S: TStream; Count: integer); +var + i: integer; + PrevSubNode, ThisSubNode: TXmlNode; +begin + PrevSubNode := nil; + for i := 0 to Count - 1 do + begin + ThisSubNode := FNodes[i]; + // write attributes and intermingled chardata + if ThisSubNode is TsdAttribute then + begin + if not (PrevSubNode is TsdCharData) then + // write blank if there is no previous chardata + sdWriteToStream(S, ' '); + // write attribute + ThisSubNode.WriteStream(S); + end; + if ThisSubNode is TsdCharData then + // write chardata + ThisSubNode.WriteStream(S); + + // next iteration + PrevSubNode := ThisSubNode; + end; +end; + +procedure TsdContainerNode.Clear; +begin + inherited; + FNodes.Clear; + FDirectNodeCount := 0; + FValueIndex := -1; +end; + +procedure TsdContainerNode.CopyFrom(ANode: TXmlNode); +var + i: integer; + ThisSubNode, ThatSubNode: TXmlNode; + NodeClass: TsdNodeClass; +begin + inherited; + // copy nodes + for i := 0 to TsdContainerNode(ANode).FNodes.Count - 1 do + begin + ThatSubNode := TsdContainerNode(ANode).FNodes[i]; + NodeClass := TsdNodeClass(ThatSubNode.ClassType); + ThisSubNode := NodeClass.Create(TNativeXml(FOwner)); + FNodes.Add(ThisSubNode); + ThisSubNode.FParent := Self; + ThisSubNode.CopyFrom(ThatSubNode); + end; + // copy other data + FDirectNodeCount := TsdContainerNode(ANode).FDirectNodeCount; + FValueIndex := TsdContainerNode(ANode).FValueIndex; +end; + +function TsdContainerNode.GetContainers(Index: integer): TXmlNode; +var + i, Idx: integer; +begin + Result := nil; + Idx := 0; + for i := FDirectNodeCount to FNodes.Count - 1 do + begin + if FNodes[i] is TsdContainerNode then + begin + if Idx = Index then + begin + Result := TsdContainerNode(FNodes[i]); + exit; + end; + inc(Idx); + end; + end; +end; + +function TsdContainerNode.GetContainerCount: integer; +var + i: integer; +begin + Result := 0; + for i := FDirectNodeCount to FNodes.Count - 1 do + begin + if FNodes[i] is TsdContainerNode then + inc(Result); + end; +end; + +function TsdContainerNode.GetDirectNodeCount: integer; +begin + Result := FDirectNodeCount; +end; + +{ TsdElement } + +procedure TsdElement.CopyFrom(ANode: TXmlNode); +begin + inherited; + // copy other data + SetName(TsdElement(ANode).GetName); + FNodeClosingStyle := TsdElement(ANode).FNodeClosingStyle; +end; + +function TsdElement.ElementType: TsdElementType; +begin + Result := xeElement; +end; + +function TsdElement.GetName: Utf8String; +begin + Result := GetString(FNameID); +end; + +function TsdElement.GetNodeClosingStyle: TsdNodeClosingStyle; +begin + Result := TNativeXml(FOwner).NodeClosingStyle; + if Result = ncDefault then + Result := FNodeClosingStyle; +end; + +function TsdElement.GetValue: Utf8String; +var + IsTrimmed: boolean; +begin + // Return the value of the CharData subnode designated by the parser + if (FValueIndex >= 0) and (FValueIndex < FNodes.Count) then + begin + // chardata value at FValueIndex + Result := FNodes[FValueIndex].Value; + + // Preserve whitespace? + if not GetPreserveWhiteSpace then + // do trimming + Result := sdTrim(Result, IsTrimmed); + + // the SkipNormalisation option allows faster retrieval but is not compat with + // the xml spec. + if not GetSkipNormalisation then + // do un-normalisation + Result := sdUnNormaliseEol(Result, GetEolStyle); + + end else + // default value + Result := ''; +end; + +function TsdElement.ParseElementList(Parser: TsdXmlParser; const SupportedTags: TsdElementTypes): TXmlNode; +// parse the element list, the result (endnode) should be this element +var + B: AnsiChar; + BeginTagName, EndTagName: Utf8String; + Tag: TsdElementType; + NodeClass: TsdNodeClass; + SubNode, EndNode: TXmlNode; + Depth: integer; + EndNodeName: Utf8String; + DeeperNodeName: Utf8String; + IsTrimmed: boolean; +begin + Result := nil; + repeat + // Process char data + ParseIntermediateData(Parser); + + // Process subtags and end tag + if Parser.EndOfStream then + begin + DoDebugOut(Self, wsFail, Format(sPrematureEnd, [Parser.Position])); + exit; + end; + Parser.MoveBack; + + B := Parser.NextChar; + if B = '<' then + begin + + // Determine tag type + Tag := Parser.ReadOpenTag; + if not (Tag in SupportedTags) then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalTag, [cElementTypeNames[Tag], Parser.Position])); + exit; + end; + + // End tag? + if Tag = xeEndTag then + begin + // up front this is the end tag so the result is this node + Result := Self; + + // Read end tag + EndTagName := sdTrim(Parser.ReadStringUntilChar('>'), IsTrimmed); + NodeClosingStyle := ncFull; + + // Check if begin and end tags match + if GetName <> EndTagName then + begin + BeginTagName := GetName; + + // usually a user error with omitted direct end tag + DoDebugOut(Self, wsWarn, Format(sBeginEndMismatch, + [GetName, EndTagName, Parser.LineNumber, Parser.Position])); + + if not TNativeXml(FOwner).FFixStructuralErrors then + exit; + + // try to fix endtag mismatch: + // check if there is a parent node with this name that is already parsed + Depth := 0; + repeat + if assigned(FParent) then + DeeperNodeName := FParent.Name + else + DeeperNodeName := ''; + + if DeeperNodeName = EndTagName then + begin + // this is the parent's node name, so we must defer execution to the parent + DoDebugOut(Self, wsHint, + Format('parent%d = "%s", this endtag = "%s": maybe "%s" should be closed', + [Depth, DeeperNodeName, EndTagName, GetName])); + + // we now break + break; + end; + + // move the node to a lower hierarchy + if assigned(FParent) and assigned(FParent.Parent) then + begin + DoDebugOut(Self, wsInfo, + Format('moving node "%s" from parent "%s" to grandparent "%s"', + [Name, FParent.Name, FParent.Parent.Name])); + FParent.NodeExtract(Self); + FParent.Parent.NodeAdd(Self); + end; + + inc(Depth); + + until Length(DeeperNodeName) = 0; + + // signal that this parser hierarchy is no longer valid + Result := FParent; + + end; + + // We're done reading this element, so we will set the capacity of the + // nodelist to just the amount of items to avoid having overhead. + FNodes.SetCapacity(FNodes.Count); + exit; + end; + + // Determine node class + NodeClass := cNodeClass[Tag]; + if not assigned(NodeClass) then + raise Exception.CreateFmt(sUnsupportedTag, [Parser.Position]); + + // Create new node and add + SubNode := NodeClass.Create(TNativeXml(FOwner)); + NodeAdd(SubNode); + if Tag <> xeElement then + DoNodeNew(SubNode); + + // The node will parse itself + EndNode := SubNode.ParseStream(Parser); + if EndNode <> SubNode then + begin + if assigned(EndNode) then + EndNodeName := EndNode.GetName + else + EndNodeName := 'nil'; + DoDebugOut(Self, wsWarn, Format(sLevelMismatch, + [SubNode.GetName, EndNodeName, Parser.LineNumber, Parser.Position])); + Result := EndNode; + Exit; + end; + + // CDATA subnodes could provide the value of the element + if SubNode is TsdCData then + begin + if FValueIndex < 0 then + FValueIndex := FNodes.Count - 1; + end; + + DoNodeLoaded(SubNode); + + end else + begin + // Since this virtual proc is also used for doctype parsing.. check + // end char here + if (B = ']') and (ElementType = xeDocType) then + break; + end; + until TNativeXml(FOwner).FAbortParsing or Parser.EndOfStream; +end; + +procedure TsdElement.ParseIntermediateData(Parser: TsdXmlParser); +var + CharDataString: Utf8String; + CharDataNode: TsdCharData; + SourcePos: int64; + IsTrimmed: boolean; +begin + SourcePos := Parser.Position; + + CharDataString := Parser.ReadStringUntilChar('<'); + if not GetPreserveWhiteSpace then + CharDataString := sdTrim(CharDataString, IsTrimmed); + + if length(CharDataString) > 0 then + begin + // Insert CharData node + CharDataNode := TsdCharData.Create(TNativeXml(FOwner)); + CharDataNode.FSourcePos := SourcePos; + CharDataNode.FCoreValueID := AddString(CharDataString); + NodeAdd(CharDataNode); + + // if there was no chardata node yet before, this is the value idx + if FValueIndex = -1 then + begin + FValueIndex := FNodes.Count - 1; + end; + + DoNodeNew(CharDataNode); + DoNodeLoaded(CharDataNode); + end; +end; + +function TsdElement.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + Ch: AnsiChar; + AName: Utf8String; + IsTrimmed: boolean; +begin + Result := Self; + + // Flush the reader. + Parser.Flush; + + // the index of the chardata subnode that will hold the value, initially -1 + FValueIndex := -1; + + FSourcePos := Parser.Position; + + // Parse name + AName := sdTrim(Parser.ReadStringUntilBlankOrEndTag, IsTrimmed); + SetName(AName); + + DoNodeNew(Self); + + // Parse attribute list + Ch := ParseAttributeList(Parser); + + // up till now attributes and optional chardata are direct nodes + FDirectNodeCount := FNodes.Count; + + if Ch = '/' then + begin + // Direct tag + Ch := Parser.NextChar; + if Ch <> '>' then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalEndTag, [Ch, Parser.LineNumber, Parser.Position])); + exit; + end; + NodeClosingStyle := ncClose; + end else + begin + if Ch <> '>' then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalEndTag, [Ch, Parser.LineNumber, Parser.Position])); + exit; + end; + + // parse subelements + Result := ParseElementList(Parser, [xeElement..xeCData, xeInstruction..xeEndTag]); + end; + + // progress for elements + DoProgress(Parser.Position); +end; + +procedure TsdElement.SetName(const Value: Utf8String); +begin + FNameID := AddString(Value); +end; + +procedure TsdElement.SetNodeClosingStyle(const Value: TsdNodeClosingStyle); +begin + FNodeClosingStyle := Value; +end; + +procedure TsdElement.SetValue(const Value: Utf8String); +var + Res: Utf8String; + Node: TXmlNode; +begin + if Length(Value) > 0 then + begin + // value that will be set + Res := Value; + + // normalise if not skipping normalisation + if not GetSkipNormalisation then + Res := sdNormaliseEol(Res); + + // add or update a value + if FValueIndex < 0 then + begin + + // we do not have a value node, so we will add it after + // FDirectNodeCount + Node := TsdCharData.Create(TNativeXml(FOwner)); + Node.Value := Res; + NodeInsert(FDirectNodeCount, Node); + FValueIndex := FDirectNodeCount; + + end else + begin + + // just update the value + FNodes[FValueIndex].Value := Res; + + end; + end else + begin + // remove the value + if FValueIndex >= 0 then + begin + NodeDelete(FValueIndex); + FValueIndex := -1; + end; + end; +end; + +procedure TsdElement.WriteStream(S: TStream); +var + i: integer; + SubNode: TXmlNode; + HasSubElements: boolean; +begin + // determine if there is at least one subelement + HasSubElements := HasSubContainers; + + // write element + sdStreamWriteString(S, GetIndent + '<' + GetName); + + // write attributes + WriteAttributeList(S, FDirectNodeCount); + + if (FNodes.Count = FDirectNodeCount) and (NodeClosingStyle = ncClose) then + begin + + // directly write close tag + sdStreamWriteString(S, TNativeXml(FOwner).FDirectCloseTag); + sdStreamWriteString(S, GetEndOfLine); + + end else + begin + // indirect node + sdStreamWriteString(S, '>'); + + // write sub-nodes + for i := FDirectNodeCount to FNodes.Count - 1 do + begin + SubNode := FNodes[i]; + + // due to optional chardatas after the parent we use these ifs + if (i = FDirectNodeCount) and not (SubNode is TsdCharData) then + begin + sdStreamWriteString(S, GetEndOfLine); + end; + if (i > FDirectNodeCount) and (SubNode is TsdCharData) and HasSubElements then + begin + sdStreamWriteString(S, SubNode.GetIndent); + end; + + if (SubNode is TsdElement) or (SubNode is TsdCharData) then + SubNode.WriteStream(S); + + if HasSubElements and (SubNode is TsdCharData) then + sdStreamWriteString(S, GetEndOfLine); + end; + + // endtag + if HasSubElements then + sdStreamWriteString(S, GetIndent); + + sdStreamWriteString(S, '' + GetEndOfLine); + end; + + DoProgress(S.Position); +end; + +{ TsdDeclaration } + +function TsdDeclaration.ElementType: TsdElementType; +begin + Result := xeDeclaration; +end; + +function TsdDeclaration.GetEncoding: Utf8String; +begin + Result := AttributeValueByName['encoding']; +end; + +function TsdDeclaration.GetName: Utf8String; +begin + Result := 'xml'; +end; + +function TsdDeclaration.GetVersion: Utf8String; +begin + Result := AttributeValueByName['version']; +end; + +function TsdDeclaration.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + B: AnsiChar; +begin + Result := Self; + // Directly parse the attribute list + B := ParseAttributeList(Parser); + if B <> '?' then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalEndTag, [B, Parser.LineNumber, Parser.Position])); + exit; + end; + B := Parser.NextChar; + if B <> '>' then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalEndTag, [B, Parser.LineNumber, Parser.Position])); + exit; + end; +end; + +procedure TsdDeclaration.SetEncoding(const Value: Utf8String); +begin + AttributeValueByName['encoding'] := Value; +end; + +procedure TsdDeclaration.SetVersion(const Value: Utf8String); +begin + AttributeValueByName['version'] := Value; +end; + +procedure TsdDeclaration.WriteStream(S: TStream); +begin + // XML declaration + sdWriteToStream(S, GetIndent + '' + GetEndOfLine); + DoProgress(S.Position); +end; + +{ TsdComment } + +function TsdComment.ElementType: TsdElementType; +begin + Result := xeComment; +end; + +function TsdComment.GetName: Utf8String; +begin + Result := ElementTypeName; +end; + +function TsdComment.ParseStream(Parser: TsdXmlParser): TXmlNode; +begin + Result := Self; + FCoreValueID := AddString(Parser.ReadStringUntil('-->')); +end; + +procedure TsdComment.WriteStream(S: TStream); +begin + // Comment + sdWriteToStream(S, ''); + DoProgress(S.Position); +end; + +{ TsdCData } + +function TsdCData.ElementType: TsdElementType; +begin + Result := xeCData; +end; + +function TsdCData.GetName: Utf8String; +begin + Result := ElementTypeName; +end; + +function TsdCData.GetValue: Utf8String; +begin + Result := GetString(FCoreValueID); +end; + +function TsdCData.ParseStream(Parser: TsdXmlParser): TXmlNode; +begin + Result := Self; + // assumes that the "')); +end; + +procedure TsdCData.SetValue(const Value: Utf8String); +begin + FCoreValueID := AddString(Value); +end; + +procedure TsdCData.WriteStream(S: TStream); +begin + // literal data + sdWriteToStream(S, ''); + DoProgress(S.Position); +end; + +{ TsdDocType } + +procedure TsdDocType.CopyFrom(ANode: TXmlNode); +begin + inherited; + // copy depending data + FExternalID.CopyFrom(TsdDocType(ANode).FExternalID); + FSystemLiteral.CopyFrom(TsdDocType(ANode).FSystemLiteral); + FPubIDLiteral.CopyFrom(TsdDocType(ANode).FPubIDLiteral); + // copy other data +end; + +constructor TsdDocType.Create(AOwner: TNativeXml); +begin + inherited; + FExternalID := TsdCharData.Create(AOwner); + FSystemLiteral := TsdQuotedText.Create(AOwner); + FPubIDLiteral := TsdQuotedText.Create(AOwner); +end; + +destructor TsdDocType.Destroy; +begin + FreeAndNil(FExternalID); + FreeAndNil(FSystemLiteral); + FreeAndNil(FPubIDLiteral); + inherited; +end; + +function TsdDocType.ElementType: TsdElementType; +begin + Result := xeDocType; +end; + +procedure TsdDocType.ParseIntermediateData(Parser: TsdXmlParser); +// in DTD's we do not allow chardata, but PE instead. Not implemented yet +var + Blanks: Utf8String; + B: AnsiChar; +begin + repeat + B := Parser.NextCharSkipBlanks(Blanks); + if (Length(Blanks) > 0) and (Blanks <> ' ') then + begin + DoDebugOut(Self, wsHint, Format(sNonDefaultChardata, [Parser.LineNumber, Parser.Position])); + end; + // todo: PERef + if not (B in [']', '<']) then + Parser.ReadStringUntilBlankOrEndTag + else + break; + until False; +end; + +function TsdDocType.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + Blanks1, Blanks2, Blanks3, Blanks4: Utf8String; + B: AnsiChar; + IsTrimmed: boolean; +begin + Result := Self; + // sequence ']) then + begin + Parser.MoveBack; + // Parse external ID + if Parser.CheckString('SYSTEM') then + begin + FExternalId.Value := 'SYSTEM'; + FSystemLiteral.ParseStream(Parser); + end else + begin + if Parser.CheckString('PUBLIC') then + begin + FExternalID.Value := 'PUBLIC'; + FPubIDLiteral.ParseStream(Parser); + FSystemLiteral.ParseStream(Parser); + end else + begin + DoDebugOut(Self, wsWarn, Format(sIllegalTag, [B, Parser.Position])); + exit; + end; + end; + B := Parser.NextCharSkipBlanks(Blanks3); + end; + if B = '[' then + begin + Result := ParseElementList(Parser, + // we allow these elements in the DTD + [xeComment, xeDtdElement, xeDtdAttList, xeDtdEntity, xeDtdNotation, xeInstruction, xeCharData]); + B := Parser.NextCharSkipBlanks(Blanks4); + end; + if B <> '>' then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalTag, [B, Parser.Position])); + end; +end; + +procedure TsdDocType.WriteStream(S: TStream); +var + i: integer; + Line: Utf8String; +begin + if FExternalID.Value = 'SYSTEM' then + begin + Line := GetIndent + ' 0 then + begin + sdWriteToStream(S, {FBlanks3 +} '[ ' + GetEndOfLine); + for i := 0 to GetNodeCount - 1 do + begin + Nodes[i].WriteStream(S); + end; + sdWriteToStream(S, ']'); + end; + sdWriteToStream(S, '>' + GetEndOfLine); + DoProgress(S.Position); +end; + +{ TsdDtdElement } + +function TsdDtdElement.ElementType: TsdElementType; +begin + Result := xeDtdElement; +end; + +function TsdDtdElement.GetValue: Utf8String; +var + S: TsdStringStream; +begin + S := TsdStringStream.Create(''); + try + WriteContent(S); + Result := S.DataString; + finally + S.Free; + end; +end; + +function TsdDtdElement.ParseStream(Parser: TsdXmlParser): TXmlNode; +var + Blanks1, Blanks2: Utf8string; + Ch: AnsiChar; + IsTrimmed: boolean; +begin + Result := Self; + Parser.NextCharSkipBlanks(Blanks1); + Parser.MoveBack; + SetName(sdTrim(Parser.ReadStringUntilBlankOrEndTag, IsTrimmed)); + Parser.NextCharSkipBlanks(Blanks2); + Parser.MoveBack; + // list of quotedtext + Ch := ParseQuotedTextList(Parser); + if Ch <> '>' then + raise Exception.CreateFmt(sIllegalEndTag, [Ch, Parser.LineNumber, Parser.Position]); +end; + +procedure TsdDtdElement.WriteContent(S: TStream); +var + i: integer; +begin + if GetNodeCount > 0 then + begin + for i := 0 to GetNodeCount - 1 do + begin + Nodes[i].WriteStream(S); + end; + end; +end; + +procedure TsdDtdElement.WriteStream(S: TStream); +var + ElementTypeString: Utf8String; +begin + case ElementType of + xeDtdElement: ElementTypeString := 'ELEMENT'; + xeDtdAttList: ElementTypeString := 'ATTLIST'; + xeDtdEntity: ElementTypeString := 'ENTITY'; + xeDtdNotation: ElementTypeString := 'NOTATION'; + else + raise EFilerError.Create(sUnsupportedTag); + end; //case + + // write front matter + sdStreamWriteString(S, '' + GetEndOfLine); + DoProgress(S.Position); +end; + +{ TsdDtdAttList } + +function TsdDtdAttList.ElementType: TsdElementType; +begin + Result := xeDtdAttList; +end; + +{ TsdDtdEntity } + +function TsdDtdEntity.ElementType: TsdElementType; +begin + Result := xeDtdEntity; +end; + +{ TsdDtdNotation } + +function TsdDtdNotation.ElementType: TsdElementType; +begin + Result := xeDtdNotation; +end; + +{ TsdInstruction } + +function TsdInstruction.ElementType: TsdElementType; +begin + Result := xeInstruction; +end; + +function TsdInstruction.GetName: Utf8String; +begin + Result := 'PI'; +end; + +function TsdInstruction.ParseStream(Parser: TsdXmlParser): TXmlNode; +begin + Result := Self; + FCoreValueID := AddString(Parser.ReadStringUntil('?>')); +end; + +procedure TsdInstruction.WriteStream(S: TStream); +var + Line: Utf8String; +begin + // processing instruction + Line := GetIndent + '' + GetEndOfLine; + sdWriteToStream(S, Line); + DoProgress(S.Position); +end; + +{ TsdStyleSheet } + +function TsdStyleSheet.ElementType: TsdElementType; +begin + Result := xeStyleSheet; +end; + +function TsdStyleSheet.GetName: Utf8String; +begin + Result := 'xml-stylesheet'; +end; + +function TsdStyleSheet.ParseStream(Parser: TsdXmlParser): TXmlNode; +begin + Result := Self; + SetValue(Parser.ReadStringUntil('?>')); +end; + +procedure TsdStyleSheet.WriteStream(S: TStream); +var + Line: Utf8String; +begin + // Stylesheet , deprecated but backwards compat + Line := GetIndent + '' + GetEndOfLine; + sdWriteToStream(S, Line); + DoProgress(S.Position); +end; + +{ TsdNodeList } + +function TsdNodeList.ByType(AType: TsdElementType): TXmlNode; +var + i: integer; +begin + for i := 0 to Count - 1 do + if Items[i].ElementType = AType then + begin + Result := Items[i]; + exit; + end; + Result := nil; +end; + +constructor TsdNodeList.Create(AOwnsObjects: boolean); +begin + inherited Create(AOwnsObjects); +end; + +function TsdNodeList.FindFirst: TXmlNode; +begin + if Count = 0 then + Result := nil + else + Result := Items[0]; +end; + +function TsdNodeList.FindNext(ANode: TXmlNode): TXmlNode; +var + Last: TXmlNode; +begin + Result := nil; + if not assigned(ANode) then + exit; + + if ANode.NodeCount > 0 then + begin + Result := ANode.Nodes[0]; + exit; + end; + + while assigned(ANode) do + begin + Last := GetLastSiblingOf(ANode); + if ANode = Last then + begin + ANode := ANode.Parent; + end else + begin + Result := GetNextSiblingOf(ANode); + exit; + end; + end; + +end; + +function TsdNodeList.GetItems(Index: integer): TXmlNode; +begin + if (Index >= 0) and (Index < Count) then + Result := Get(Index) + else + Result := nil; +end; + +function TsdNodeList.GetLastSiblingOf(ANode: TXmlNode): TXmlNode; +var + Parent: TXmlNode; + LastIdx: integer; +begin + Result := nil; + if ANode = nil then + exit; + + Parent := ANode.Parent; + if Parent = nil then + begin + LastIdx := Count - 1; + if LastIdx >= 0 then + Result := Items[LastIdx]; + end else + begin + LastIdx := Parent.NodeCount - 1; + if LastIdx >= 0 then + Result := Parent.Nodes[LastIdx]; + end; +end; + +function TsdNodeList.GetNextSiblingOf(ANode: TXmlNode): TXmlNode; +var + Parent: TXmlNode; + Idx: integer; +begin + Parent := ANode.Parent; + if Parent = nil then + begin + Idx := IndexOf(ANode); + if Idx < 0 then + raise Exception.Create('index must be >= 0'); + Result := Items[Idx + 1]; + end else + begin + Idx := Parent.NodeIndexOf(ANode); + Result := Parent.Nodes[Idx + 1]; + end; +end; + + +{ TNativeXml } + +procedure TNativeXml.Clear; +begin + FStringTable.Clear; + FRootNodes.Clear; + + // Defaults + FDirectCloseTag := cDefaultDirectCloseTag; + FDropCommentsOnParse := cDefaultDropCommentsOnParse; + FEolStyle := cDefaultEolStyle; + FExternalEncoding := cDefaultExternalEncoding; + FFloatAllowScientific := cDefaultFloatAllowScientific; + FFloatSignificantDigits := cDefaultFloatSignificantDigits; + FIndentString := cDefaultIndentString; + FNodeClosingStyle := cDefaultNodeClosingStyle; + FPreserveWhiteSpace := cDefaultPreserveWhiteSpace; + FUseLocalBias := cDefaultUseLocalBias; + FWriteOnDefault := cDefaultWriteOnDefault; + FXmlFormat := cDefaultXmlFormat; + +end; + +constructor TNativeXml.CreateEx(HasDeclaration, HasRootElement: boolean; AOwner: TComponent); +var + Declaration: TsdDeclaration; + Element: TsdElement; +begin + inherited Create(AOwner); + + // FRootNodes is an owned list + FRootNodes := TsdNodeList.Create(True); + FStringTable := TsdStringTable.Create(AOwner); + + // this sets defaults + Clear; + + // defaults that should not be cleared + FFixStructuralErrors := cDefaultFixStructuralErrors; + + // Build default items in RootNodes + if HasDeclaration then + begin + Declaration := TsdDeclaration.Create(Self); + Declaration.Version := cDefaultVersionString; + Declaration.Encoding := cDefaultEncodingString; + FRootNodes.Add(Declaration); + end; + + // then the root element + if HasRootElement then + begin + Element := TsdElement.Create(Self); + FRootNodes.Add(Element); + end; +end; + +constructor TNativeXml.CreateName(const ARootName: Utf8String; AOwner: TComponent); +begin + // we create a standard declaration and root element + CreateEx(True, True, AOwner); + Root.Name := ARootName; +end; + +constructor TNativeXml.Create(AOwner: TComponent); +begin + // simple constructor without declaration, but with a standard root element + CreateEx(False, True, AOwner); +end; + +destructor TNativeXml.Destroy; +begin + FreeAndNil(FRootNodes); + FreeAndNil(FStringTable); + inherited; +end; + +procedure TNativeXml.DoNodeLoaded(ANode: TXmlNode); +begin + if assigned(FOnNodeLoaded) then + FOnNodeLoaded(Self, ANode); +end; + +procedure TNativeXml.DoNodeNew(ANode: TXmlNode); +begin + if assigned(FOnNodeNew) then + FOnNodeNew(Self, ANode); +end; + +procedure TNativeXml.DoProgress(Position: int64); +begin + if assigned(FOnProgress) then + FOnProgress(Self, Position); +end; + +function TNativeXml.GetCommentString: Utf8String; +// Get the first comment node, and return its value +var + Node: TXmlNode; +begin + Result := ''; + Node := FRootNodes.ByType(xeComment); + if assigned(Node) then + Result := Node.Value; +end; + +function TNativeXml.GetCharset: Utf8String; +begin + Result := ''; + if FRootNodes.Count > 0 then + if FRootNodes[0] is TsdDeclaration then + Result := TsdDeclaration(FRootNodes[0]).Encoding; +end; + +function TNativeXml.GetParserLineNumber(Parser: TsdXmlParser): int64; +begin + if assigned(Parser) then + Result := Parser.LineNumber + else + Result := 0; +end; + +function TNativeXml.GetParserPosition(Parser: TsdXmlParser): int64; +begin + if assigned(Parser) then + Result := Parser.Position + else + Result := 0; +end; + +function TNativeXml.GetRoot: TsdElement; +begin + // the first xeElement node in the root nodes + Result := TsdElement(FRootNodes.ByType(xeElement)); +end; + +function TNativeXml.GetRootNodeClass: TsdNodeClass; +begin + // default node class is TsdElement + Result := TsdElement; +end; + +function TNativeXml.GetRootNodeCount: integer; +begin + Result := FRootNodes.Count; +end; + +function TNativeXml.GetRootContainers(Index: integer): TsdContainerNode; +var + i, Idx: integer; +begin + Result := nil; + Idx := 0; + for i := 0 to FRootNodes.Count - 1 do + begin + if FRootNodes[i] is TsdContainerNode then + begin + if Idx = Index then + begin + Result := TsdContainerNode(FRootNodes[i]); + exit; + end; + inc(Idx); + end; + end; +end; + +function TNativeXml.GetRootContainerCount: integer; +var + i: integer; +begin + Result := 0; + for i := 0 to FRootNodes.Count - 1 do + begin + if FRootNodes[i] is TsdContainerNode then + inc(Result); + end; +end; + +function TNativeXml.GetStyleSheet: TsdStyleSheet; +begin + Result := TsdStyleSheet(FRootNodes.ByType(xeStylesheet)); + if not assigned(Result) then + begin + // Add a stylesheet node as second one if none present + Result := TsdStyleSheet.Create(Self); + FRootNodes.Insert(1, Result); + end; +end; + +function TNativeXml.GetVersionString: Utf8String; +begin + Result := ''; + if FRootNodes.Count > 0 then + if FRootNodes[0] is TsdDeclaration then + Result := TsdDeclaration(FRootNodes[0]).Version; +end; + +function TNativeXml.IsEmpty: boolean; +var + R: TXmlNode; +begin + R := GetRoot; + Result := not assigned(R) or R.IsClear; +end; + +function TNativeXml.LineFeed: Utf8String; +begin + case FXmlFormat of + xfReadable: + Result := #13#10; + xfCompact: + Result := #10; + else + Result := #10; + end;//case +end; + +function TNativeXml.LoadFromURL(const URL: Utf8String): int64; +var + M: TMemoryStream; + NetHandle, UrlHandle: HINTERNET; + Buffer: array[0..$400 - 1] of AnsiChar; + BytesRead: cardinal; +begin + Result := 0; + + NetHandle := InternetOpenA('nativexml', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); + + if not assigned(NetHandle) then + begin + // NetHandle is not valid. + DoDebugOut(Self, wsFail, 'Unable to initialize WinInet'); + exit; + end; + + try + UrlHandle := InternetOpenUrlA(NetHandle, PAnsiChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0); + if not assigned(UrlHandle) then + begin + // UrlHandle is not valid. + DoDebugOut(Self, wsFail, format('Cannot open URL %s', [Url])); + exit; + end; + + M := TMemoryStream.Create; + try + // UrlHandle valid? Proceed with download + FillChar(Buffer, SizeOf(Buffer), 0); + repeat + InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead); + if BytesRead > 0 then + M.Write(Buffer, BytesRead); + until BytesRead = 0; + + InternetCloseHandle(UrlHandle); + + // now load the stream + M.Position := 0; + LoadFromStream(M); + // final size in bytes of the url stream + Result := M.Size; + + finally + M.Free; + end; + + finally + InternetCloseHandle(NetHandle); + end; +end; + +procedure TNativeXml.LoadFromFile(const AFileName: string); +var + F: TFileStream; +begin + F := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(F); + finally + F.Free; + end; +end; + +procedure TNativeXml.LoadFromStream(AStream: TStream); +var + Parser: TsdXmlParser; +begin + FStringTable.Clear; + FRootNodes.Clear; + + Parser := TsdXmlParser.Create(AStream, cParserChunkSize); + try + Parser.Owner := Self; + ParseStream(Parser); + + // copy encoding data from the parser + FExternalEncoding := Parser.Encoding; + FExternalCodePage := Parser.CodePage; + FExternalBomInfo := Parser.BomInfo; + + // final onprogress + DoProgress(AStream.Size); + finally + FreeAndNil(Parser); + end; +end; + +procedure TNativeXml.MoveSubNodes(AList: TsdNodeList; FromNode, + ToNode: TXmlNode); +var + i: integer; + Node: TXmlNode; +begin + if (AList = nil) or (FromNode = nil) or (ToNode = nil) then + exit; + if AList.Count = 0 then + exit; + // move subnodes + for i := 0 to AList.Count - 1 do + begin + Node := AList[i]; + if Node.Parent = FromNode then + begin + FromNode.NodeExtract(Node); + ToNode.NodeAdd(Node); + end; + end; +end; + +procedure TNativeXml.New; +var + Declaration: TsdDeclaration; + Element: TsdElement; +begin + Clear; + + // Build default items in RootNodes: first the declaration + Declaration := TsdDeclaration.Create(Self); + Declaration.Version := cDefaultVersionString; + Declaration.Encoding := cDefaultEncodingString; + FExternalEncoding := cDefaultExternalEncoding; + FRootNodes.Add(Declaration); + + // then the root node + Element := TsdElement.Create(Self); + FRootNodes.Add(Element); +end; + +procedure TNativeXml.ParseStream(Parser: TsdXmlParser); +var + B: AnsiChar; + ElementType: TsdElementType; + NodeClass: TsdNodeClass; + Node: TXmlNode; + StringData: Utf8String; + CD: TsdCharData; + SP: int64; + IsTrimmed: boolean; + DeclarationEncodingString: Utf8String; +begin + FAbortParsing := False; + + // read BOM + Parser.ReadBOM; + + // store external bominfo for use later when writing + FExternalBomInfo := Parser.BomInfo; + + // Read next tag + repeat + SP := Parser.Position; + StringData := Parser.ReadStringUntilChar('<'); + if not FPreserveWhiteSpace then + StringData := sdTrim(StringData, IsTrimmed); + + if length(StringData) > 0 then + begin + // Add chardata node + CD := TsdCharData.Create(Self); + CD.SourcePos := SP; + CD.Value := StringData; + FRootNodes.Add(CD); + DoNodeNew(CD); + DoNodeLoaded(CD); + end; + + // At the end of the stream? Then stop + if Parser.EndOfStream then + break; + Parser.MoveBack; + + B := Parser.NextChar; + if B = '<' then + begin + // Determine tag type + ElementType := Parser.ReadOpenTag; + if ElementType = xeError then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalTag, [B, Parser.Position])); + exit; + end; + + // Determine node class + NodeClass := cNodeClass[ElementType]; + if not assigned(NodeClass) then + begin + DoDebugOut(Self, wsWarn, Format(sUnsupportedTag, + [cElementTypeNames[ElementType], Parser.Position])); + exit; + end; + + // Create new node and add + Node := NodeClass.Create(Self); + FRootNodes.Add(Node); + if ElementType <> xeElement then + DoNodeNew(Node); + + // The node will parse itself + Node.ParseStream(Parser); + DoNodeLoaded(Node); + + // After adding nodes: + // see if we added the declaration node + if Node.ElementType = xeDeclaration then + begin + // give the parser the codepage from encoding in the declaration. + // The .SetCodePage setter cares for the re-encoding of the chunk. + DeclarationEncodingString := TsdDeclaration(Node).Encoding; + Parser.Encoding := sdCharsetToStringEncoding(DeclarationEncodingString); + Parser.CodePage := sdCharsetToCodePage(DeclarationEncodingString); + + DoDebugOut(Self, wsInfo, Format('declaration with encoding "%s" and codepage %d', + [TsdDeclaration(Node).Encoding, Parser.CodePage])); + end; + + // drop comments when parsing? + if (Node.ElementType = xeComment) and FDropCommentsOnParse then + begin + // drop comment on parse + DoDebugOut(Self, wsInfo, 'option DropCommentsOnParse is true, deleting comment'); + FRootNodes.Remove(Node); + end; + + end; + + // Check if application has aborted parsing + until FAbortParsing or Parser.EndOfStream; +end; + +function TNativeXml.ParseSubstituteContentFromNode(ANode: TXmlNode; const ASubstitute: Utf8String): TXmlNode; +// this is a simple version of TNativeXml.ParseStream, in order to re-parse +// substituted chardata (e.g. from entities, see also NativeXmlC14n.pas) +var + S: TsdStringStream; + Parser: TsdXmlParser; + Parent: TXmlNode; + + // local + function ParseSubstituteStream(Parser: TsdXmlParser): TXmlNode; + var + B: AnsiChar; + ElementType: TsdElementType; + NodeClass: TsdNodeClass; + Node: TXmlNode; + StringData: Utf8String; + CD: TsdCharData; + IsTrimmed: boolean; + begin + FAbortParsing := False; + + // result will have the first re-parsed node + Result := nil; + + Parser.EncodeChunk; + + // Read next tag + repeat + StringData := sdTrim(Parser.ReadStringUntilChar('<'), IsTrimmed); + + if length(StringData) > 0 then + begin + // Add chardata node + CD := TsdCharData.Create(Self); + CD.Value := StringData; + Parent.NodeAdd(CD); + if not assigned(Result) then + Result := CD; + end; + + // At the end of the stream? Then stop + if Parser.EndOfStream then + break; + Parser.MoveBack; + + B := Parser.NextChar; + if B = '<' then + begin + // Determine tag type + ElementType := Parser.ReadOpenTag; + if ElementType = xeError then + begin + DoDebugOut(Self, wsWarn, Format(sIllegalTag, [B, Parser.Position])); + exit; + end; + + // Determine node class + NodeClass := cNodeClass[ElementType]; + if not assigned(NodeClass) then + begin + DoDebugOut(Self, wsWarn, Format(sUnsupportedTag, + [cElementTypeNames[ElementType], Parser.Position])); + exit; + end; + + // Create new node and add + Node := NodeClass.Create(Self); + Parent.NodeAdd(Node); + if not assigned(Result) then + Result := Node; + + // The node will parse itself + Node.ParseStream(Parser); + end; + + // Check if application has aborted parsing + until FAbortParsing or Parser.EndOfStream; + end; + +// main +begin + Result := nil; + Parent := ANode.Parent; + if not assigned(Parent) then + exit; + + // remove the node that gets substituted + Parent.NodeRemove(ANode); + + S := TsdStringStream.Create(ASubstitute); + try + S.Position := 0; + Parser := TsdXmlParser.Create(S, cParserChunkSize); + try + Parser.Owner := Self; + Result := ParseSubstituteStream(Parser); + finally + FreeAndNil(Parser); + end; + finally + S.Free; + end; +end; + +procedure TNativeXml.ReadFromString(const AValue: Utf8String); +var + S: TStream; +begin + S := TsdStringStream.Create(AValue); + try + LoadFromStream(S); + finally + S.Free; + end; +end; + +procedure TNativeXml.SaveToFile(const AFileName: string); +var + S: TStream; +begin + S := TFileStream.Create(AFileName, fmCreate); + try + SaveToStream(S); + finally + S.Free; + end; +end; + +procedure TNativeXml.SaveToStream(Stream: TStream); +var + Writer: TsdXmlWriter; + BomInfo: TsdBomInfo; +begin + // Create xml writer, which enabes correct BOM, encoding and codepage. + Writer := TsdXmlWriter.Create(Self, Stream, cWriterChunkSize); + try + + // based on externalencoding, we create the external BOM + case FExternalEncoding of + seAnsi: + begin + BomInfo.Len := 0; + BomInfo.Encoding := seAnsi; + BomInfo.HasBOM := False; + end; + seUTF8: + begin + BomInfo.Len := 0; + BomInfo.Encoding := seUTF8; + BomInfo.HasBOM := False; + end; + seUTF16BE: + begin + // Len = 2 and HasBom = True + BomInfo := cBomInfoList[cBomInfoIdxUTF16BE]; + end; + seUTF16LE: + begin + // Len = 2 and HasBom = True + BomInfo := cBomInfoList[cBomInfoIdxUTF16LE]; + end; + else + DoDebugOut(Self, wsFail, sUnsupportedEncoding); + exit; + end; + FExternalBomInfo := BomInfo; + + // external byte order mark + if FExternalBomInfo.HasBOM then + begin + Writer.FEncoding := seUTF8; // only to write BOM without hassle + Writer.Write(FExternalBomInfo.BOM[0], FExternalBomInfo.Len); + end; + + // set external encoding + Writer.FEncoding := FExternalEncoding; + Writer.FCodePage := FExternalCodePage; + + // write the stream + WriteStream(Writer); + finally + Writer.Free; + end; +end; + +procedure TNativeXml.SetCommentString(const Value: Utf8String); +// Find first comment node and set it's value, otherwise add new comment node +// right below the xml declaration +var + Node: TXmlNode; +begin + Node := FRootNodes.ByType(xeComment); + if not assigned(Node) and (length(Value) > 0) then + begin + Node := TsdComment.Create(Self); + FRootNodes.Insert(1, Node); + end; + if assigned(Node) then + Node.Value := Value; +end; + +procedure TNativeXml.SetCharset(const Value: Utf8String); +var + Node: TXmlNode; +begin + if Value = GetCharset then + exit; + + // write declaration (if not there) + Node := FRootNodes[0]; + if not (Node is TsdDeclaration) then + begin + if length(Value) > 0 then + begin + Node := TsdDeclaration.Create(Self); + FRootNodes.Insert(0, Node); + end; + end; + + // write charset + if Node is TsdDeclaration then + TsdDeclaration(Node).Encoding := Value; + + // write the external codepage + FExternalCodepage := sdCharsetToCodepage(Value); + // write external encoding + FExternalEncoding := sdCharsetToStringEncoding(Value); +end; + +procedure TNativeXml.SetPreserveWhiteSpace(Value: boolean); +begin + FPreserveWhiteSpace := Value; + if FPreserveWhiteSpace then + FXmlFormat := xfPreserve; +end; + +procedure TNativeXml.SetVersionString(const Value: Utf8String); +var + Node: TXmlNode; +begin + if Value = GetVersionString then + exit; + Node := FRootNodes[0]; + if not (Node is TsdDeclaration) then + begin + if length(Value) > 0 then + begin + Node := TsdDeclaration.Create(Self); + FRootNodes.Insert(0, Node); + end; + end; + if assigned(Node) then + TsdDeclaration(Node).Version := Value; +end; + +procedure TNativeXml.WriteStream(S: TStream); +var + i: integer; + Node: TXmlNode; +begin + if not assigned(Root) and FParserWarnings then + raise EFilerError.Create(sRootElementNotDefined); + + DoProgress(0); + + + // write the root nodes + for i := 0 to FRootNodes.Count - 1 do + begin + // external codepage info + if i = 0 then + begin + Node := FRootNodes[i]; + if Node.ElementType = xeDeclaration then + DoDebugOut(Self, wsInfo, Format('writing declaration with encoding "%s" and codepage %d', + [TsdDeclaration(Node).Encoding, FExternalCodePage])); + end; + + FRootNodes[i].WriteStream(S); + end; + + DoProgress(S.Size); +end; + +function TNativeXml.WriteToString: string; +var + S: TsdStringStream; +begin + S := TsdStringStream.Create(''); + try + SaveToStream(S); + Result := S.DataString; + finally + S.Free; + end; +end; + +function TNativeXml.WriteToLocalString: Utf8String; +var + S: TsdStringStream; +begin + S := TsdStringStream.Create(''); + try + WriteStream(S); + Result := S.DataString; + finally + S.Free; + end; +end; + +function TNativeXml.WriteToLocalUnicodeString: UnicodeString; +begin + Result := sdUtf8ToWide(WriteToLocalString); +end; + +function TNativeXml.FindFirst: TXmlNode; +begin + if not assigned(FRootNodes) or (FRootNodes.Count = 0) then + Result := nil + else + Result := FRootNodes[0]; +end; + +function TNativeXml.FindNext(ANode: TXmlNode): TXmlNode; + // local + function GetLastSiblingOf(ANode: TXmlNode): TXmlNode; + var + Parent: TXmlNode; + LastIdx: integer; + begin + Result := nil; + if ANode = nil then + exit; + + Parent := ANode.Parent; + if Parent = nil then + begin + LastIdx := RootNodes.Count - 1; + if LastIdx >= 0 then + Result := FRootNodes[LastIdx]; + end else + begin + LastIdx := Parent.NodeCount - 1; + if LastIdx >= 0 then + Result := Parent.Nodes[LastIdx]; + end; + end; + + // local + function GetNextSiblingOf(ANode: TXmlNode): TXmlNode; + var + Parent: TXmlNode; + Idx: integer; + begin + Parent := ANode.Parent; + if Parent = nil then + begin + Idx := FRootNodes.IndexOf(ANode); + Result := FRootNodes[Idx + 1]; + end else + begin + Idx := Parent.NodeIndexOf(ANode); + Result := Parent.Nodes[Idx + 1]; + end; + end; + +// main +var + Last: TXmlNode; +begin + Result := nil; + if not assigned(ANode) then + exit; + + if ANode.NodeCount > 0 then + begin + Result := ANode.Nodes[0]; + exit; + end; + + while assigned(ANode) do + begin + Last := GetLastSiblingOf(ANode); + if ANode = Last then + begin + ANode := ANode.Parent; + end else + begin + Result := GetNextSiblingOf(ANode); + exit; + end; + end; + +end; + +function TNativeXml.InsertDocType(const AName: Utf8String): TsdDocType; +begin + Result := TsdDocType.Create(Self); + Result.Name := AName; + Result.ExternalId.Value := 'SYSTEM'; + FRootNodes.Insert(1, Result); +end; + + +class function TNativeXml.DecodeBase64(const Source: Utf8String; OnDebug: TsdDebugEvent): RawByteString; +begin + try + Result := NativeXml.DecodeBase64(Source); + except + on EFilerError do + OnDebug(nil, wsFail, sErrorCalcStreamLength); + end; +end; + +class function TNativeXml.EncodeBase64(const Source: RawByteString; const ControlChars: Utf8String): Utf8String; +begin + Result := sdAddControlChars(NativeXml.EncodeBase64(Source), ControlChars); +end; + +procedure TNativeXml.SetExternalEncoding(const Value: TsdStringEncoding); +var + Codepage: integer; +begin + if FExternalEncoding = Value then + exit; + Codepage := cStringEncodingCodepages[Value]; + if Codepage = 0 then + begin + DoDebugOut(Self, wsFail, + Format('external encoding "%s" is not allowed (use ExternalCodepage)', + [cStringEncodingCharsetNames[Value]])); + exit; + end; + FExternalEncoding := Value; + FExternalCodepage := Codepage; +end; + +function TNativeXml.Canonicalize: integer; +begin +//to-do longterm + Result := 0; +end; + +procedure TNativeXml.ForEach(Sender: TObject; AEvent: TsdXmlNodeEvent); +var + Node: TXmlNode; +begin + if not assigned(AEvent) or not assigned(Sender) then + exit; + Node := FindFirst; + while assigned(Node) do + begin + AEvent(Sender, Node); + Node := FindNext(Node); + end; +end; + + +{ TsdXmlParser } + +function TsdXmlParser.CheckString(const S: Utf8String): boolean; +// case-insensitive string check +var + i, Count, StartIdx: integer; +begin + Count := MakeDataAvailable; + StartIdx := FUtf8CurrentIdx; + Result := True; + for i := 1 to length(S) do + begin + if FEndOfStream then + begin + Result := False; + exit; + end; + // case-insensitive, so we use LoCase in both sides (LoCase is + // faster than function LowerCase, since it deals directly with chars). + if LoCase(S[i]) <> LoCase(FUtf8Buffer[FUtf8CurrentIdx]) then + begin + Result := False; + // revert + FUtf8CurrentIdx := StartIdx; + exit; + end; + IncCurrentIdxCheck(Count); + end; +end; + +constructor TsdXmlParser.Create(ASource: TStream; AChunkSize: integer); +begin + inherited Create; + FSource := ASource; + FChunkSize := AChunkSize; + SetLength(FRawBuffer, FChunkSize); + + // Read from the stream directly to the raw buffer + FRawFirstIdx := 0; + FRawLastIdx := FSource.Read(FRawBuffer[0], FChunkSize); + FUtf8FirstIdx := 0; + FUtf8CurrentIdx := 0; + + // Normalise end-of-line is enabled by default (True) + FNormaliseEOLEnabled := True; +end; + +destructor TsdXmlParser.Destroy; +begin + SetLength(FRawBuffer, 0); + SetLength(FUtf8Buffer, 0); + inherited; +end; + +procedure TsdXmlParser.EncodeChunk; + + // local + procedure EncodeAnsiChunk; + var + RawLen, Utf8Len: integer; + begin + RawLen := FRawLastIdx - FRawFirstIdx; + SetLength(FRawBuffer, FRawFirstIdx + RawLen); + // Utf8 buffer might be 3x ansi size at max + SetLength(FUtf8Buffer, FUtf8FirstIdx + 3 * RawLen); + Utf8Len := sdAnsiToUtf8Buffer(FRawBuffer[FRawFirstIdx], FUtf8Buffer[FUtf8FirstIdx], FCodePage, RawLen); + FUtf8LastIdx := FUtf8FirstIdx + Utf8Len; + end; + + // local + procedure EncodeUtf8Chunk; + var + RawLen, Utf8Len: integer; + begin + RawLen := FRawLastIdx - FRawFirstIdx; + // buffers + SetLength(FRawBuffer, FRawFirstIdx + RawLen); + SetLength(FUtf8Buffer, FUtf8FirstIdx + RawLen); + Move(FRawBuffer[FRawFirstIdx], FUtf8Buffer[FUtf8FirstIdx], RawLen); + Utf8Len := RawLen; + FUtf8LastIdx := FUtf8FirstIdx + Utf8Len; + end; + + // local + procedure EncodeUtf16Chunk; + type + TWordArray = array of word; + var + RawLen, Utf8Len: integer; + i: integer; + W: word; + begin + RawLen := FRawLastIdx - FRawFirstIdx; + + // If UTF16 BE (Big Endian), we must swap byte order + if FEncoding = seUTF16BE then + begin + for i := FRawFirstIdx div 2 to FRawLastIdx div 2 - 1 do + begin + W := TWordArray(FRawBuffer)[i]; + TWordArray(FRawBuffer)[i] := Swap(W); + end; + end; + + // Utf8 buffer might be 2x utf16 size at max + SetLength(FRawBuffer, FRawFirstIdx + RawLen); + SetLength(FUtf8Buffer, FUtf8FirstIdx + (2 * RawLen)); + + // Now convert from UTF16 to UTF8 + Utf8Len := sdWideToUtf8Buffer(FRawBuffer[FRawFirstIdx], FUtf8Buffer[FUtf8FirstIdx], RawLen div 2); + FUtf8LastIdx := FUtf8FirstIdx + Utf8Len; + end; +// main +begin + // call EncodeChunk methods based on encoding + case FEncoding of + seAnsi: + begin + if (FCodePage = 0) or (FCodePage = 65001{CP_UTF8}) then + begin + EncodeUtf8Chunk; + end else + begin + EncodeAnsiChunk; + end; + end; + + seUTF8: + begin + EncodeUtf8Chunk; + end; + + seUTF16BE, seUTF16LE: + begin + EncodeUtf16Chunk; + end; + end; + + // collapse all end-of-line to a single LineFeed (#$0A) + if FNormaliseEOLEnabled then + NormaliseEOL; + +end; + +procedure TsdXmlParser.Flush(Force: boolean); +var + i: integer; + RawLen, Utf8Len: integer; +begin + // Number of bytes to move + RawLen := FRawLastIdx - FRawFirstIdx; + Utf8Len := FUtf8LastIdx - FUtf8FirstIdx; + if FUtf8CurrentIdx - FUtf8FirstIdx > 0 then + begin + // Calcuate base line number and base position + for i := 0 to FUtf8FirstIdx - 1 do + begin + // linefeed + if FUtf8Buffer[i] = #$0A then + inc(FBaseLineNumber); + end; + inc(FUtf8BasePosition, FUtf8FirstIdx); + // moves + Move(FRawBuffer[FRawFirstIdx], FRawBuffer[0], RawLen); + Move(FUtf8Buffer[FUtf8FirstIdx], FUtf8Buffer[0], Utf8Len); + // update current idx + dec(FUtf8CurrentIdx, FUtf8FirstIdx); + // update first/last indices + FRawFirstIdx := 0; + FRawLastIdx := RawLen; + FUtf8FirstIdx := 0; + FUtf8LastIdx := Utf8Len; + end; +end; + +function TsdXmlParser.GetLineNumber: int64; +var + i: integer; +begin + Result := FBaseLineNumber; + for i := 0 to FUtf8CurrentIdx - 1 do + begin + // linefeed + if FUtf8Buffer[i] = #$0A then + inc(Result); + end; +end; + +function TsdXmlParser.GetPosition: int64; +begin + Result := FUtf8BasePosition + FUtf8CurrentIdx; +end; + +procedure TsdXmlParser.IncCurrentIdxCheck(var BytesAvail: integer); +// increment FCurrentIdx and check bytes available +begin + inc(FUtf8CurrentIdx); + dec(BytesAvail); + if BytesAvail <= 0 then + BytesAvail := MakeDataAvailable +end; + +function TsdXmlParser.IsBinaryXml: boolean; +var + i: integer; + Cookie: array[0..3] of AnsiChar; +begin + Result := False; + if FRawLastIdx <= length(cBinaryXmlCookie) then + exit; + + // read binary cookie + Move(FRawBuffer[0], Cookie, 4); + + for i := 0 to length(cBinaryXmlCookie) - 1 do + if Cookie[i] <> cBinaryXmlCookie[i] then + exit; + + // cookie for binary xml matches + Result := True; +end; + +function TsdXmlParser.LoCase(Ch: AnsiChar): AnsiChar; +begin + Result := Ch; + case Result of + 'A'..'Z': inc(Result, Ord('a') - Ord('A')); + end; +end; + +function TsdXmlParser.MakeDataAvailable: integer; +var + BytesRead: integer; +begin + Result := FUtf8LastIdx - FUtf8CurrentIdx; + while Result < 1 do + begin + // We must make data available + BytesRead := ReadNextChunk; + Result := FUtf8LastIdx - FUtf8CurrentIdx; + // Still no data available? + if BytesRead = 0 then + begin + FEndOfStream := True; + exit; + end; + end; +end; + +procedure TsdXmlParser.MoveBack; +begin + assert(FUtf8CurrentIdx > 0); + dec(FUtf8CurrentIdx); +end; + +function TsdXmlParser.NextChar: AnsiChar; +begin + MakeDataAvailable; + if FEndOfStream then + begin + Result := #0; + exit; + end; + Result := FUtf8Buffer[FUtf8CurrentIdx]; + inc(FUtf8CurrentIdx); +end; + +procedure TsdXmlParser.NormaliseEOL; +var + i: integer; +begin + // collapse all end-of-line to a single LineFeed (#$0A) + i := FUtf8FirstIdx; + while i < FUtf8LastIdx do + begin + if FUtf8Buffer[i] = #$0A then + begin + if FUtf8Buffer[i - 1] = #$0D then + begin + Move(FUtf8Buffer[i], FUtf8Buffer[i - 1], FUtf8LastIdx - i); + dec(FUtf8LastIdx); + end; + end; + inc(i); + end; +end; + +function TsdXmlParser.ReadNextChunk: integer; +begin + SetLength(FRawBuffer, FRawLastIdx + FChunkSize); + + // Read from the stream directly to our chunk + // Result is the bytes read + Result := FSource.Read(FRawBuffer[FRawLastIdx], FChunkSize); + if Result > 0 then + begin + FRawFirstIdx := FRawLastIdx; + FUtf8FirstIdx := FUtf8LastIdx; + inc(FRawLastIdx, Result); + EncodeChunk; + end; +end; + +function TsdXmlParser.ReadQuotedString(AQuote: AnsiChar): Utf8String; +begin + // It seems that the xml spec simply does not allow double quotes as in + // Delphi, so we do not need a complicated algo to do this. We can simply + // search for the quote again as terminator. + Result := ReadStringUntilChar(AQuote); +end; + +function TsdXmlParser.ReadString(AIndex, ACount: integer): Utf8String; +begin + SetLength(Result, ACount); + if ACount > 0 then + Move(FUtf8Buffer[AIndex], Result[1], ACount); +end; + +function TsdXmlParser.ReadStringUntil(const Terminator: Utf8String): Utf8String; +var + Count, MatchLen: integer; + FirstChar: AnsiChar; + StartIdx: integer; +begin + FirstChar := Terminator[1]; + MatchLen := length(Terminator); + StartIdx := FUtf8CurrentIdx; + Count := MakeDataAvailable; + while not FEndOfStream do + begin + if FUtf8Buffer[FUtf8CurrentIdx] = FirstChar then + begin + + if CheckString(Terminator) then + begin + // We found the terminating string + Result := ReadString(StartIdx, FUtf8CurrentIdx - StartIdx - MatchLen); + exit; + end; + + end; + IncCurrentIdxCheck(Count); + end; + // when left here stream ended prematurely + DoDebugOut(Self, wsWarn, Format(sPrematureEnd, [GetPosition])); +end; + +function TsdXmlParser.ReadStringUntilChar(AChar: AnsiChar): Utf8String; +var + Count: integer; + StartIdx: integer; +begin + Count := MakeDataAvailable; + + StartIdx := FUtf8CurrentIdx; + while not FEndOfStream do + begin + if FUtf8Buffer[FUtf8CurrentIdx] = AChar then + begin + // We found AChar + Result := ReadString(StartIdx, FUtf8CurrentIdx - StartIdx); + // Adjust FUtf8CurrentIdx + inc(FUtf8CurrentIdx); + exit; + end; + IncCurrentIdxCheck(Count); + end; + + // Arriving here: end of stream and AChar not reached + Result := ReadString(StartIdx, FUtf8CurrentIdx - StartIdx); +end; + +procedure TsdXmlParser.SetCodePage(const Value: integer); +begin + FCodePage := Value; + // re-encode the chunk (eg from default UTF-8 codepage to other ansi codepage) + EncodeChunk; +end; + +// TsdXmlParser + +function TsdXmlParser.NextCharSkipBlanks(var Blanks: Utf8String): AnsiChar; +var + Count: integer; +begin + Blanks := ''; + Count := MakeDataAvailable; + while not FEndOfStream do + begin + Result := FUtf8Buffer[FUtf8CurrentIdx]; + IncCurrentIdxCheck(Count); + if not (Result in cXmlBlankChars) then + exit; + Blanks := Blanks + Result; + end; + Result := #0; +end; + +procedure TsdXmlParser.ReadBOM; +var + i, j: integer; + BOM: array[0..3] of byte; + BomInfoFound: boolean; +begin + if FRawLastIdx <= 4 then + begin + DoDebugOut(Self, wsWarn, Format(sPrematureEnd, [FRawLastIdx])); + exit; + end; + + // read the BOM if it is there + Move(FRawBuffer[0], BOM, 4); + + i := 0; + BomInfoFound := False; + while i < cBomInfoListCount do + begin + BomInfoFound := True; + for j := 0 to cBomInfoList[i].Len - 1 do + begin + if BOM[j] <> cBomInfoList[i].BOM[j] then + begin + BomInfoFound := False; + break; + end; + end; + if BomInfoFound then + begin + FBomInfo := cBomInfoList[i]; + FEncoding := FBomInfo.Encoding; + break; + end; + inc(i); + end; + + // BOM info not found? + if BomInfoFound then + begin + // Non-supported encodings + if not (FEncoding in [seAnsi, seUTF8, seUTF16BE, seUTF16LE]) then + begin + DoDebugOut(Self, wsFail, Format(sUnsupportedEncoding, [cStringEncodingCharsetNames[FEncoding]])); + // avoid trying to read exotic encodings such as EBDIC + exit; + end; + + // Rewind based on BOM + if FBomInfo.HasBom then + begin + FRawLastIdx := FChunkSize - FBomInfo.Len; + Move(FRawBuffer[FBomInfo.Len], FRawBuffer[0], FRawLastIdx); + SetLength(FRawBuffer, FRawLastIdx); + DoDebugOut(Self, wsInfo, Format('BOM with encoding %s', [cStringEncodingCharsetNames[FEncoding]])); + end; + + end else + begin + // No BOM, and unknown encoding, e.g. html instead of xml + // we use UTF8 as default + DoDebugOut(Self, wsWarn, sUnknownEncoding); + FEncoding := seUTF8; + end; + + // encode the first chunk + EncodeChunk; +end; + +function TsdXmlParser.ReadOpenTag: TsdElementType; +var + AnsiCh: AnsiChar; +begin + Result := xeError; + AnsiCh := NextChar; + if FEndOfStream then + exit; + + case AnsiCh of + '!': + begin + AnsiCh := LoCase(NextChar); + case AnsiCh of + '[': if CheckString('cdata[') then + Result := xeCData; + 'd': if CheckString('octype') then + Result := xeDocType; + 'e': + begin + if CheckString('lement') then + Result := xeDtdElement; + if CheckString('ntity') then + Result := xeDtdEntity; + end; + 'a': if CheckString('ttlist') then + Result := xeDtdAttList; + 'n': if CheckString('otation') then + Result := xeDtdNotation; + '-': if CheckString('-') then + Result := xeComment; + else + begin + DoDebugOut(Self, wsFail, Format(sIllegalTag, [AnsiCh, GetPosition])); + exit; + end; + end; + end; + '?': + begin + if CheckString('xml') then + begin + if CheckString('-stylesheet') then + Result := xeStyleSheet + else + Result := xeDeclaration; + end else + Result := xeInstruction; + end; + '/': Result := xeEndTag; + else + Result := xeElement; + MoveBack; + end; +end; + +function TsdXmlParser.ReadStringUntilBlankOrEndTag: Utf8String; +var + Count: integer; + StartIdx: integer; +begin + Count := MakeDataAvailable; + StartIdx := FUtf8CurrentIdx; + while not FEndOfStream do + begin + if FUtf8Buffer[FUtf8CurrentIdx] in cXmlBlankCharsOrEndTag then + begin + // We found the termination + Result := ReadString(StartIdx, FUtf8CurrentIdx - StartIdx); + exit; + end; + IncCurrentIdxCheck(Count); + end; + // when left here stream ended prematurely + DoDebugOut(Self, wsWarn, Format(sPrematureEnd, [GetPosition])); +end; + +{ TsdXmlWriter } + +constructor TsdXmlWriter.Create(AOwner: TsdDebugComponent; ASource: TStream; AChunkSize: integer); +begin + inherited Create(ASource, AChunkSize); + FOwner := AOwner; +end; + +destructor TsdXmlWriter.Destroy; +begin + SetLength(FRawBuffer, 0); + inherited; +end; + +procedure TsdXmlWriter.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; + const AMessage: Utf8String); +begin + if FOwner is TsdDebugComponent then + TsdDebugComponent(FOwner).DoDebugOut(Sender, WarnStyle, AMessage); +end; + +function TsdXmlWriter.Write(const Buffer; Count: Integer): Longint; +type + PWord = ^Word; +var + i, AnsiCount, WideCount: integer; + DefaultCharUsed: boolean; + W: PWord; // pointer to a word + // local + procedure AllocRawBuffer(ASize: integer); + begin + if FRawBufferSize < ASize then + begin + FRawBufferSize := ASize; + SetLength(FRawBuffer, FRawBufferSize); + end; + end; +// main +begin + case FEncoding of + + seAnsi: + begin + AllocRawBuffer(Count); + AnsiCount := sdUtf8ToAnsiBuffer(Buffer, FRawBuffer[0], FCodepage, Count, DefaultCharUsed); + Result := inherited Write(FRawBuffer[0], AnsiCount); + if DefaultCharUsed then + begin + DoDebugOut(Self, wsWarn, sDefaultCharUsed); + end; + end; + + seUTF8: + begin + Result := inherited Write(Buffer, Count) + end; + + seUTF16LE: + begin + AllocRawBuffer(2 * Count); + WideCount := sdUtf8ToWideBuffer(Buffer, FRawBuffer[0], Count); + Result := inherited Write(FRawBuffer[0], 2 * WideCount); + end; + + seUTF16BE: + begin + AllocRawBuffer(2 * Count); + WideCount := sdUtf8ToWideBuffer(Buffer, FRawBuffer[0], Count); + // swap the byte order from little endian to big endian + W := PWord(@FRawBuffer[0]); + for i := 0 to WideCount - 1 do + begin + W^ := Swap(W^); + inc(W); + end; + Result := inherited Write(FRawBuffer[0], 2 * WideCount); + end; + else + // unsupported encoding + DoDebugOut(Self, wsFail, sUnsupportedEncoding); + Result := 0; + end; +end; + +{ Utility Functions } + +function sdWideToUtf8(const W: UnicodeString): Utf8String; +var + WideCount, Utf8Count: integer; +begin + WideCount := length(W); + SetLength(Result, WideCount * 3); // just to be sure + if WideCount = 0 then + exit; + + Utf8Count := sdWideToUtf8Buffer(W[1], Result[1], WideCount); + SetLength(Result, Utf8Count); +end; + +function sdUtf8ToWide(const U: Utf8String): UnicodeString; +var + Utf8Count, WideCount: integer; +begin + Utf8Count := length(U); + SetLength(Result, Utf8Count); + if Utf8Count = 0 then + exit; + + WideCount := sdUtf8ToWideBuffer(U[1], Result[1], Utf8Count); + SetLength(Result, WideCount); +end; + +function sdWideToUtf8Buffer(const WideBuf; var Utf8Buf; WideCount: integer): integer; +// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process +// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes). +// Therefore, the block at Dst must be at least 1.5 the size of the source block. +// The function returns the number of *bytes* written. +var + W: word; + WideIdx, Utf8Idx: integer; +begin + WideIdx := 0; + Utf8Idx := 0; + while WideIdx < WideCount do + begin + W := TWordArray(WideBuf)[WideIdx]; + if W <= $7F then + begin + TByteArray(Utf8Buf)[Utf8Idx] := byte(W); + inc(Utf8Idx); + end else + begin + if W > $7FF then + begin + TByteArray(Utf8Buf)[Utf8Idx] := byte($E0 or (W shr 12)); + inc(Utf8Idx); + TByteArray(Utf8Buf)[Utf8Idx] := byte($80 or ((W shr 6) and $3F)); + inc(Utf8Idx); + TByteArray(Utf8Buf)[Utf8Idx] := byte($80 or (W and $3F)); + inc(Utf8Idx); + end else + begin // $7F < W <= $7FF + TByteArray(Utf8Buf)[Utf8Idx] := byte($C0 or (W shr 6)); + inc(Utf8Idx); + TByteArray(Utf8Buf)[Utf8Idx] := byte($80 or (W and $3F)); + inc(Utf8Idx); + end; + end; + inc(WideIdx); + end; + Result := Utf8Idx; +end; + +function sdUtf8ToWideBuffer(const Utf8Buf; var WideBuf; ByteCount: integer): integer; +// Convert an UTF8 buffer to Unicode (UTF16 LE) buffer. This routine will process +// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes). +// Therefore, the block at WideBuf must be at least 2 times the size of Count, since +// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The +// function returns the number of *wide chars* written. Note that the Utf8Buf block must +// have an exact number of UTF8 characters in it, if Count doesn't match then +// the last character will be converted anyway (going past the block boundary!) +var + W: word; + C: byte; + WideIdx, Utf8Idx: integer; +begin + Utf8Idx := 0; + WideIdx := 0; + while Utf8Idx < ByteCount do + begin + // 1st byte + W := TByteArray(Utf8Buf)[Utf8Idx]; + inc(Utf8Idx); + if W and $80 <> 0 then + begin + W := W and $3F; + if W and $20 <> 0 then + begin + // 2nd byte + C := TByteArray(Utf8Buf)[Utf8Idx]; + inc(Utf8Idx); + if C and $C0 <> $80 then + // malformed trail byte or out of range char + Continue; + W := (W shl 6) or (C and $3F); + end; + // 2nd or 3rd byte + C := TByteArray(Utf8Buf)[Utf8Idx]; + inc(Utf8Idx); + if C and $C0 <> $80 then + // malformed trail byte + Continue; + TWordArray(WideBuf)[WideIdx] := (W shl 6) or (C and $3F); + inc(WideIdx); + end else + begin + TWordArray(WideBuf)[WideIdx] := W; + inc(WideIdx); + end; + end; + Result := WideIdx; +end; + +function sdAnsiToUtf8(const A: AnsiString; ACodePage: integer): Utf8String; +var + AnsiCount, Utf8Count: integer; +begin + AnsiCount := length(A); + SetLength(Result, AnsiCount * 3); // just to be sure + if AnsiCount = 0 then + exit; + + Utf8Count := sdAnsiToUtf8Buffer(A[1], Result[1], ACodePage, AnsiCount); + SetLength(Result, Utf8Count); +end; + +function sdAnsiToUtf8Buffer(const AnsiBuf; var Utf8Buf; ACodePage, AnsiCount: integer): integer; +var + AnsiIdx, Utf8Idx: integer; + AnsiCh: AnsiChar; + WideCh: WideChar; + Len: integer; +begin + AnsiIdx := 0; + Utf8Idx := 0; + while AnsiIdx < AnsiCount do + begin + AnsiCh := TAnsiCharArray(AnsiBuf)[AnsiIdx]; + if ord(AnsiCh) < $80 then + begin + // characters < $80: just copy the single characters + TAnsiCharArray(Utf8Buf)[Utf8Idx] := AnsiCh; + inc(Utf8Idx); + end else + begin + // characters >= $80: copy to widechar using codepage, then convert to Utf8 + // MultiByteToWideChar is in the Windows unit of Borland Delphi 7 + MultiByteToWideChar(ACodePage, 0, @AnsiCh, 1, @WideCh, 1); + Len := sdWideToUtf8Buffer(WideCh, TAnsiCharArray(Utf8Buf)[Utf8Idx], 1); + inc(Utf8Idx, Len); + end; + inc(AnsiIdx); + end; + Result := Utf8Idx; +end; + +function sdUtf8ToAnsi(const U: Utf8String; ACodePage: integer): AnsiString; +// Convert UTF8 to Ansi string +var + Utf8Count, AnsiCount: integer; + DefaultCharUsed: boolean; +begin + Utf8Count := length(U); + SetLength(Result, Utf8Count); + if Utf8Count = 0 then + exit; + + AnsiCount := sdUtf8ToAnsiBuffer(U[1], Result[1], ACodePage, Utf8Count, DefaultCharUsed); + SetLength(Result, AnsiCount); +end; + +function sdUtf8ToAnsiBuffer(const Utf8Buf; var AnsiBuf; ACodePage, Utf8Count: integer; + var DefaultCharUsed: boolean): integer; +var + AnsiIdx, Utf8Idx: integer; + Utf8Ch: AnsiChar; + WideCh: WideChar; + Len: integer; + DU: pointer; +const + cDefaultChar: AnsiChar = '?'; +begin + AnsiIdx := 0; + Utf8Idx := 0; + while Utf8Idx < Utf8Count do + begin + Utf8Ch := TAnsiCharArray(Utf8Buf)[Utf8Idx]; + if ord(Utf8Ch) < $80 then + begin + // characters < $80: just copy the single characters + DefaultCharUsed := False; + Len := 1; + TAnsiCharArray(AnsiBuf)[AnsiIdx] := Utf8Ch; + inc(AnsiIdx); + end else + begin + Len := sdUtf8CharacterLength(TAnsiCharArray(Utf8Buf)[Utf8Idx]); + sdUtf8ToWideBuffer(TAnsiCharArray(Utf8Buf)[Utf8Idx], WideCh, 1); + // characters >= $80: copy to widechar using codepage, then convert to Utf8 + // WideCharToMultiByte is in the Windows unit of Borland Delphi 7 + DefaultCharUsed := False; + DU := @DefaultCharUsed; + WideCharToMultiByte(ACodePage, 0, @WideCh, 1, @TAnsiCharArray(AnsiBuf)[AnsiIdx], 1, @cDefaultChar, @DU); + DefaultCharUsed := DU <> nil; + inc(AnsiIdx); + end; + inc(Utf8Idx, Len); + end; + Result := AnsiIdx; +end; + +function sdEscapeString(const AValue: Utf8String): Utf8String; +// contributor: Michael Cessna +var + i, Len: Integer; + P: PAnsiChar; + HasEscapes: boolean; + ScratchMem: TsdFastMemStream; +begin + Result := ''; + Len := Length(AValue); + if Len = 0 then + Exit; + + HasEscapes := False; + P := PAnsiChar(AValue); + for i := 0 to Len - 1 do + begin + case P^ of + '"' : HasEscapes := True; + '''' : HasEscapes := True; + '&' : HasEscapes := True; + '<' : HasEscapes := True; + '>' : HasEscapes := True; + end; + Inc(P); + end; + if not HasEscapes then + begin + Result := AValue; + Exit; + end; + + // ScratchMem is a TsdFastMemStream + ScratchMem := TsdFastMemStream.Create(Len * 2); + try + P := PAnsiChar(AValue); + for i := 0 to Len - 1 do + begin + case P^ of + '"' : ScratchMem.Write(AnsiString('"'), 6); + '''' : ScratchMem.Write(AnsiString('''), 6); + '&' : ScratchMem.Write(AnsiString('&'), 5); + '<' : ScratchMem.Write(AnsiString('<'), 4); + '>' : ScratchMem.Write(AnsiString('>'), 4); + else + ScratchMem.Write(P^, 1); + end; + Inc(P); + end; + SetString(Result, PAnsiChar(ScratchMem.Memory), ScratchMem.Position); + finally + ScratchMem.Free; + end; +end; + +function sdReplaceString(const AValue: Utf8String; var HasNonStandardReferences: boolean; + References: array of TXmlNode): Utf8String; overload; +var + i, j, k, Len: Integer; + P, Q: PAnsiChar; + HasReferences, FoundReference: boolean; + Reference, Replacement: Utf8String; + ScratchMem: TsdFastMemStream; + + //local + function FindNonStandardReferenceReplacement(AReference: Utf8String): Utf8String; + var + i: integer; + Entity: TsdDtdEntity; + ReferenceName, ReferenceValue: Utf8String; + begin + Result := ''; + if Length(References) = 0 then + exit; + for i := 0 to Length(References) - 1 do + begin + if References[i] is TsdDtdEntity then + begin + Entity := TsdDtdEntity(References[i]); + ReferenceName := '&' + Entity.Name + ';'; + ReferenceValue := Entity.Value; + if AReference = ReferenceName then + begin + Result := ReferenceValue; + break; + end; + end; + end; + end; + +// main +begin + Result := ''; + Len := Length(AValue); + if Len = 0 then + Exit; + + HasReferences := False; + HasNonStandardReferences := False; + P := PAnsiChar(AValue); + for i := 0 to Len - 1 do + begin + if P^ = '&' then + HasReferences := True; + Inc(P); + end; + if not HasReferences then + begin + Result := AValue; + Exit; + end; + + // ScratchMem is a TsdFastMemStream + ScratchMem := TsdFastMemStream.Create(Len); + try + P := PAnsiChar(AValue); + i := 0; + while i < Len do + begin + FoundReference := False; + if P^ = '&' then + begin + Q := P; + inc(Q); + for j := i + 1 to Len - 1 do + begin + if Q^ = '&' then + begin + // erronous duplicate quote! just let it be + FoundReference := False; + Break; + end; + if Q^ = ';' then + begin + // find reference + Reference := Copy(AValue, i + 1, j - i + 1); + inc(P, Length(Reference) - 1); + inc(i, Length(Reference) - 1); + + // Look up standard escapes + for k := 0 to cEscapeCount - 1 do + if Reference = cXmlReplacePhrases[k] then + begin + // Replacement + Replacement := cXmlEscapePhrases[k]; + ScratchMem.Write(Replacement[1], Length(Replacement)); + FoundReference := True; + Break; + end; + if not FoundReference then + begin + + // there was a non-standard reference, try to replace + Replacement := FindNonStandardReferenceReplacement(Reference); + if length(Replacement) = 0 then + begin + // replacement not found, so just write the reference + ScratchMem.Write(Reference[1], Length(Reference)); + end else + begin + // write the replacement that was found :) + ScratchMem.Write(Replacement[1], Length(Replacement)); + end; + FoundReference := True; + HasNonStandardReferences := True; + + end; + Break; + end; + inc(Q); + end; + end; + if not FoundReference then + ScratchMem.Write(P^, 1); + Inc(P); + Inc(i); + end; + SetString(Result, PAnsiChar(ScratchMem.Memory), ScratchMem.Position); + finally + ScratchMem.Free; + end; +end; + +function sdReplaceString(const AValue: Utf8String; var HasNonStandardReferences: boolean): Utf8String; +var + References: array of TXmlNode; +begin + SetLength(References, 0); + sdReplaceString(AValue, HasNonStandardReferences, References); +end; + +function sdReplaceString(const AValue: Utf8String): Utf8String; overload; +var + HasNonStandardReferences: boolean; + References: array of TXmlNode; +begin + SetLength(References, 0); + Result := sdReplaceString(AValue, HasNonStandardReferences, References); +end; + +function sdCommaToDot(const AValue: Utf8String): Utf8String; +var + i: integer; +begin + Result := AValue; + for i := 1 to Length(AValue) do + if AValue[i] = ',' then + Result[i] := '.'; +end; + +function sdTrim(const S: Utf8String): Utf8String; +var + IsTrimmed: boolean; +begin + Result := sdTrim(S, IsTrimmed); +end; + +function sdTrim(const S: Utf8String; var IsTrimmed: boolean): Utf8String; +var + I, L: Integer; +begin + IsTrimmed := False; + L := Length(S); + i := 1; + while (i <= L) and (S[i] <= ' ') do + begin + inc(i); + IsTrimmed := True; + end; + if i > L then + Result := '' + else + begin + while S[L] <= ' ' do + begin + dec(L); + IsTrimmed := True; + end; + Result := Copy(S, i, L - i + 1); + end; +end; + +function sdNormaliseEol(const S: Utf8String): Utf8String; +var + i, L: integer; +begin + // collapse all end-of-line to a single LineFeed (#$0A) + i := 1; + L := Length(S); + Result := S; + while i <= L do + begin + if Result[i] = #$0A then + begin + if Result[i - 1] = #$0D then + begin + Move(Result[i], Result[i - 1], L - i + 1); + dec(L); + end; + end; + inc(i); + end; + SetLength(Result, L); +end; + +function sdUnNormaliseEol(const S: Utf8String; EolStyle: TsdEolStyle): Utf8String; +// expand all single LineFeed (#$0A) to EOL defined by EolStyle +var + i, L: integer; +begin + Result := S; + // only needs change if EolStyle = esWindows, in other words, if EolStyle = esLinux, + // we are finished + if EolStyle = esWindows then + begin + i := 1; + L := Length(Result); + while i <= L do + begin + if Result[i] = #$0A then + begin + inc(L); + SetLength(Result, L); + Move(Result[i], Result[i + 1], L - i); + Result[i] := #$0D; + inc(i); + end; + inc(i); + end; + end; +end; + +procedure sdWriteToStream(S: TStream; const Value: Utf8String); +begin + if Length(Value) > 0 then + begin + S.Write(Value[1], Length(Value)); + end; +end; + +function sdCharsetToCodePage(ACharset: Utf8String; ADefaultCodepage: integer = 65001): integer; +var + i: integer; +begin + for i := 0 to cCodePageInfoCount - 1 do + begin + if AnsiCompareText(ACharset, cCodePageInfo[i].Name) = 0 then + begin + Result := cCodePageInfo[i].Codepage; + exit; + end; + end; + // Default + Result := ADefaultCodepage; +end; + +function sdCharsetToStringEncoding(ACharset: Utf8String): TsdStringEncoding; +var + Codepage: integer; +begin + Codepage := sdCharsetToCodePage(ACharset); + case Codepage of + 1200: Result := seUTF16LE; + 1201: Result := seUTF16BE; + 65001: Result := seUTF8; + else + Result := seAnsi; + end; +end; + +function sdCodepageToCharset(ACodepage: integer): Utf8String; +// find the charset corresponding to windows codepage +var + i: integer; +begin + for i := 0 to cCodePageInfoCount - 1 do + begin + if cCodepageInfo[i].Codepage = ACodepage then + begin + Result := cCodepageInfo[i].Name; + exit; + end; + end; + // default to 'utf-8' + Result := 'utf-8'; +end; + +function Utf8CompareText(const S1, S2: Utf8String): integer; +begin + // AnsiCompareText is case-insensitive + Result := AnsiCompareText(AnsiString(S1), AnsiString(S2)); +end; + +function GetTimeZoneBias: Integer; +// uses windows unit, func GetTimeZoneInformation +// contributor: Stefan Glienke +var + TimeZoneInfo: TTimeZoneInformation; +begin + case GetTimeZoneInformation(TimeZoneInfo) of + TIME_ZONE_ID_UNKNOWN: Result := TimeZoneInfo.Bias; + TIME_ZONE_ID_STANDARD: Result := TimeZoneInfo.Bias + TimeZoneInfo.StandardBias; + TIME_ZONE_ID_DAYLIGHT: Result := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias; + else + Result := 0; + end; +end; + +{ XYZ to string functions } + +function sdDateTimeToString(ADate: TDateTime; UseDate: boolean = True; UseTime: boolean = True; + SplitSecondDigits: integer = 0; UseLocalBias: boolean = False): Utf8String; +// 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; + ABias: Integer; + DatePortion, TimePortion, SplitSecondPortion, LocalBiasPortion: Utf8String; +const + Neg: array[Boolean] of string = ('+', '-'); +begin + DatePortion := ''; + TimePortion := ''; + + if UseDate then + begin + DecodeDate(ADate, AYear, AMonth, ADay); + DatePortion := Utf8String(Format('%.4d-%.2d-%.2d', [AYear, AMonth, ADay])); + // if we also use time, add the 'T' in advance + if UseTime then + DatePortion := DatePortion + 'T'; + end; + if UseTime then + begin + DecodeTime(ADate, AHour, AMin, ASec, AMSec); + if SplitSecondDigits > 0 then + begin + SplitSecondPortion := Utf8String(Format('%.3d', [AMSec])); + if SplitSecondDigits < 3 then + begin + SplitSecondPortion := copy(SplitSecondPortion, 1, SplitSecondDigits); + end; + SplitSecondPortion := '.' + SplitSecondPortion; + end else + begin + SplitSecondPortion := ''; + end; + if UseLocalBias then + begin + ABias := GetTimeZoneBias; + LocalBiasPortion := Utf8String(Format('%s%.2d:%.2d', + [Neg[ABias > 0], Abs(ABias) div MinsPerHour, Abs(ABias) mod MinsPerHour])) + end else + begin + LocalBiasPortion := 'Z'; + end; + // final time portion + TimePortion := Utf8String(Format('%.2d:%.2d:%.2d', [AHour, AMin, ASec])) + + SplitSecondPortion + LocalBiasPortion; + end; + // final result + Result := DatePortion + TimePortion; +end; + +function sdBoolToString(Value: boolean): Utf8String; +const + // do NOT localize! This is part of the W3 XML spec + cBoolValues: array[boolean] of Utf8String = ('false', 'true'); +begin + Result := cBoolValues[Value]; +end; + +function sdFloatToString(Value: double; SignificantDigits: integer; AllowScientific: boolean): Utf8String; +const + Limits: array[1..9] of integer = + (10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000); +var + Limit, Limitd, PointPos, IntVal, ScPower: integer; + Body: Utf8String; +begin + if (SignificantDigits < 1) or (SignificantDigits > 9) then + raise Exception.Create(sSignificantDigitsOutOfRange); + + // 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); + + // Exceptional case which happens when the value rounds up to the limit + if Intval = Limit then + begin + IntVal := IntVal div 10; + inc(PointPos); + end; + + // 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; + +function sdIntToString(Value: integer): Utf8String; +begin + Result := Utf8String(IntToStr(Value)); +end; + +function sdInt64ToString(Value: int64): Utf8String; +begin + // int64 can be used with IntToStr + Result := Utf8String(IntToStr(Value)); +end; + +{ end XYZ to string functions } + +{ string to XYZ functions } + +function sdStringToDateTime(const ADate: Utf8String; UseLocalBias: Boolean): 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 +// contributor: Stefan Glienke +var + AYear, AMonth, ADay, AHour, AMin, ASec, AMSec: word; + ALocalBias, ABias: Integer; +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 + 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); + ALocalBias := GetTimeZoneBias; + if UseLocalBias then + begin + if (Length(ADate) > 24) then + begin + ABias := StrToInt(Copy(ADate, 25, 2)) * MinsPerHour + + StrToInt(Copy(ADate, 28, 2)); + if ADate[24] = '+' then + ABias := ABias * -1; + Result := Result + ABias / MinsPerDay; + end; + Result := Result - ALocalBias / MinsPerDay; + end; +end; + +function sdStringToDateTimeDef(const ADate: Utf8String; ADefault: TDateTime; UseLocalBias: Boolean): 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 := sdStringToDateTime(ADate, UseLocalBias); + except + Result := ADefault; + end; +end; + +function EncodeBase64(const Source: RawByteString): Utf8String; +// 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; + +function EncodeBase64Buf(const Buffer; Count: Integer): Utf8String; +var + i, j: integer; + Core: integer; + FourChar: cardinal; + S: PByte; +begin + // Make sure "Core" is always a multiple of 3, and this multiple + // gets saved as 4 characters + Core := (Count + 2) div 3; + + // Set the length of the string that stores encoded characters + SetLength(Result, Core * 4); + S := @Buffer; + + // Do the loop "Core" times + for i := 0 to Core - 1 do + begin + FourChar := 0; + for j := 0 to 2 do + begin + FourChar := FourChar shl 8 + S^; + inc(S); + end; + for j := 0 to 3 do + begin + Result[i * 4 + 4 - j] := cBase64Char[FourChar and $3F]; + FourChar := FourChar shr 6; + end; + end; + + // For comformity to Base64, we must pad the data instead of zero out + // when the size is not an exact multiple of 3 + case Core * 3 - Count of + 0:;// nothing to do + 1: // pad one char + Result[Core * 4] := cBase64PadChar; + 2: // pad two chars + begin + Result[Core * 4 - 1] := cBase64PadChar; + Result[Core * 4 ] := cBase64PadChar; + end; + end;//case +end; + +function DecodeBase64(const Source: Utf8String): RawByteString; +// Decode BASE64 data in Source into binary data. The function returns the binary +// data as Utf8String. +var + BufData: Utf8String; + BufSize, BufPos: integer; +begin + BufData := sdRemoveControlChars(Source); + + // Determine length of data + BufSize := length(BufData) div 4; + if BufSize * 4 <> length(BufData) then + raise EFilerError.Create(sErrorCalcStreamLength); + BufSize := BufSize * 3; + + // Check padding chars + BufPos := length(BufData); + if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then + begin + dec(BufPos); + dec(BufSize); + if (BufPos > 0) and (BufData[BufPos] = cBase64PadChar) then + dec(BufSize); + end; + Setlength(Result, BufSize); + + // Decode + if BufSize > 0 then + DecodeBase64Buf(BufData, Result[1], BufSize); +end; + +procedure DecodeBase64Buf(var Source: Utf8String; var Buffer; Count: Integer); +var + i, j: integer; + BufPos, Core: integer; + FourChar: cardinal; + D: PByte; + Map: array[AnsiChar] of byte; +begin + // Core * 4 is the number of chars to read - check length + Core := Length(Source) div 4; + if Count > Core * 3 then + raise EFilerError.Create(sMissingDataInBinaryStream); + + // 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 ('=') + BufPos := length(Source); + if (BufPos > 0) and (Source[BufPos] = cBase64PadChar) then + begin + Source[BufPos] := cBase64Char[0]; + dec(BufPos); + if (BufPos > 0) and (Source[BufPos] = cBase64PadChar) then + Source[BufPos] := cBase64Char[0]; + end; + + // Do this "Core" times + for i := 0 to Core - 1 do + begin + FourChar := 0; + + // Unroll the characters + for j := 0 to 3 do + FourChar := FourChar 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^ := FourChar shr (j * 8) and $FF; + inc(D); + end; + end; +end; + +function EncodeBinHex(const Source: RawByteString): Utf8String; +// Encode binary data in Source as BINHEX. The function returns the BINHEX encoded +// data as UTF8String, without any linebreaks. +var + Text: Utf8String; +begin + SetLength(Text, Length(Source) * 2); + BinToHex(PAnsiChar(Source), PAnsiChar(Text), Length(Source)); + Result := Text; +end; + +function DecodeBinHex(const Source: Utf8String): RawByteString; +// Decode BINHEX data in Source into binary data. The function returns the binary +// data as RawByteString. Use a TStringStream to convert this data to a stream. +var + Data: Utf8String; + Size: integer; + Buffer: RawByteString; +begin + Data := sdRemoveControlChars(Source); + + // Determine length of data + Size := length(Data) div 2; + if Size * 2 <> length(Data) then + raise EFilerError.Create(sErrorCalcStreamLength); + + SetLength(Buffer, Size); + HexToBin(PAnsiChar(Data), PAnsiChar(Buffer), Size); + Result := Buffer; +end; + +procedure DecodeBinhexBuf(var Source: Utf8String; var Buffer; Count: Integer); +var + Size: integer; +begin + // Determine length of data + Size := Count div 2; + if Size * 2 <> Count then + raise EFilerError.Create(sErrorCalcStreamLength); + + HexToBin(PAnsiChar(Source), PAnsiChar(Buffer), Count); +end; + +function sdRemoveControlChars(const AValue: Utf8String): Utf8String; +// Remove control characters from Utf8String AValue +var + i, j: integer; +begin + Setlength(Result, Length(AValue)); + i := 1; + j := 1; + while i <= Length(AValue) do + if AValue[i] in cXmlBlankChars 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 sdAddControlChars(const AValue: Utf8String; const ControlChars: Utf8String; Interval: integer): Utf8String; +// Insert Chars in AValue at each Interval +var + i, j, L: integer; + // local + procedure InsertControlChars; + var + k: integer; + begin + for k := 1 to Length(ControlChars) do + begin + Result[j] := ControlChars[k]; + inc(j); + end; + end; +// main +begin + if (Length(ControlChars) = 0) or (Interval <= 0) then + begin + Result := AValue; + exit; + end; + + // Calculate length based on original length and total extra length for control chars + L := Length(AValue) + ((Length(AValue) - 1) div Interval + 3) * Length(ControlChars); + SetLength(Result, L); + + // Copy and insert + j := 1; + for i := 1 to Length(AValue) do + begin + if (i mod Interval) = 1 then + // Insert control chars + InsertControlChars; + Result[j] := AValue[i]; + inc(j); + end; + InsertControlChars; + + // Adjust length + dec(j); + if L > j then + SetLength(Result, j); +end; + +{ former unit sdStringEncodig } + +function sdUtf8CharacterLength(const Buffer): integer; +// determine the character length (1..4 bytes) of the Utf8 character +// in the buffer +type + TByteArray = array[0..3] of byte; +var + P0, P1, P2, P3: byte; +begin + P0 := TByteArray(Buffer)[0]; + Result := 1; + if P0 < $C0 then // %11000000 + begin + // regular single byte character + exit; + end; + P1 := TByteArray(Buffer)[1]; + if (P0 and $E0) = $C0 then + begin + // could be 2 byte character + if (P1 and $C0) = $80 then + begin + Result := 2; + end; + exit; + end; + P2 := TByteArray(Buffer)[2]; + if (P0 and $F0) = $E0 then + begin + // could be 3 byte character + if ((P1 and $C0) = $80) and ((P2 and $C0) = $80) then + begin + Result := 3; + end; + exit; + end; + P3 := TByteArray(Buffer)[3]; + if (P0 and $F8) = $F0 then + begin + // could be 4 byte character + // NB 4 byte chars are incompatible with Widechar since + // they are outside the basic lingual plane + if ((P1 and $C0) = $80) + and ((P2 and $C0) = $80) + and ((P3 and $C0) = $80) then + begin + Result := 4; + end; + end; +end; + +procedure GetXmlFormatSettings; +var + TimePrefix, TimePostfix, HourFormat: string; +begin + cXmlFormatSettings.CurrencyString := ''; + cXmlFormatSettings.CurrencyFormat := 0; + cXmlFormatSettings.NegCurrFormat := 0; + cXmlFormatSettings.ThousandSeparator := ','; + cXmlFormatSettings.DecimalSeparator := '.'; + cXmlFormatSettings.CurrencyDecimals := 0; + cXmlFormatSettings.DateSeparator := '/'; + cXmlFormatSettings.ShortDateFormat := 'm/d/yy'; + cXmlFormatSettings.LongDateFormat := 'mmmm d, yyyy'; + cXmlFormatSettings.TimeSeparator := ':'; + cXmlFormatSettings.TimeAMString := 'am'; + cXmlFormatSettings.TimePMString := 'pm'; + TimePrefix := ''; + HourFormat := 'h'; + TimePostfix := ' AMPM'; + cXmlFormatSettings.ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + cXmlFormatSettings.LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + cXmlFormatSettings.ListSeparator := ','; +end; + +initialization + + // NativeXml's xml format settings (with decimal separator = '.') + GetXmlFormatSettings; + +end. ADDED ZPreview/src/Delphi/Common/NativeXml/NativeXmlC14n.pas Index: ZPreview/src/Delphi/Common/NativeXml/NativeXmlC14n.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NativeXmlC14n.pas @@ -0,0 +1,135 @@ +{ Canonicalize an xml document + + The acronym for canonicalization is "C14N" + + An xml document after C14N must be: + - encoded in UTF-8 only + - xml declaration removed + - entities expanded to their character equivalent + - CDATA sections replaced by character equivalent + - special < > and " entities encoded + - attributes normalized as if by validating parser + - empty elements opened with start and end tags + - namespace declarations and attributes sorted + + Experimental! + + Author: Nils Haeck M.Sc. + Copyright (c) 2010 - 2011 Simdesign B.V. (www.simdesign.nl) + + It is NOT allowed under ANY circumstances to publish, alter or copy this code + without accepting the license conditions in accompanying LICENSE.txt + first! + + 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. +} +unit NativeXmlC14n; + +interface + +uses + SysUtils, NativeXml, sdDebug; + +type + + TNativeXmlC14N = class(TDebugComponent) + public + class procedure Canonicalize(AXml: TNativeXml); + end; + +implementation + +{ TNativeXmlC14N } + +class procedure TNativeXmlC14N.Canonicalize(AXml: TNativeXml); +var + Decl: TXmlNode; + DTD: TsdDocType; + DtdEntityNodes: array of TXmlNode; + i, j, TotalNodeCount, CharDataCount, ReferencesCount: integer; + Node: TXmlNode; + CharData: TsdCharData; + SubstituteText: Utf8String; +begin + TotalNodeCount := 0; + CharDataCount := 0; + ReferencesCount := 0; + + // encode in UTF-8 only - this is already achieved by the parser + + // xml compacted + //AXml.XmlFormat := xfCompact; + + // remove xml declaration + Decl := AXml.RootNodes[0]; + if Decl is TsdDeclaration then + begin + AXml.RootNodes.Delete(0); + end; + + // recursively expand entities to their character equivalent: + + // find dtdentity nodes in the dtd + DTD := TsdDocType(AXml.RootNodes.ByType(xeDocType)); + if assigned(DTD) then + begin + j := 0; + SetLength(DtdEntityNodes, j); + for i := 0 to DTD.NodeCount - 1 do + if DTD.Nodes[i] is TsdDtdEntity then + begin + inc(j); + SetLength(DtdEntityNodes, j); + DtdEntityNodes[j - 1] := TsdDtdEntity(DTD.Nodes[i]); + end; + end; + + // find references + + Node := AXml.FindFirst; + while assigned(Node) do + begin + inc(TotalNodeCount); + + // check for entity references + if Node is TsdCharData then + begin + inc(CharDataCount); + + // non-standard references usually come from entity references in the dtd + if TsdCharData(Node).HasNonStandardReferences then + begin + inc(ReferencesCount); + + CharData := TsdCharData(Node); + + // substitute chardata value using the references + SubstituteText := AnsiDequotedStr(CharData.GetValueUsingReferences(DtdEntityNodes), '"'); + + Node := AXml.ParseSubstituteContentFromNode(Chardata, SubstituteText); + end; + end; + + Node := AXml.FindNext(Node); + end; + + + // replace CDATA sections by character equivalent + + // encode special < > and " entities + + // normalize attributes as if by validating parser + + // open empty elements with start and end tags + + // sort namespace declarations and attributes + + AXml.DoDebugOut(AXml, wsInfo, format('total node count: %d, chardata count: %d, references count: %d', + [TotalNodeCount, CharDataCount, ReferencesCount])); + AXml.DoDebugOut(AXml, wsInfo, 'C14N created'); +end; + +end. ADDED ZPreview/src/Delphi/Common/NativeXml/NativeXmlCodepages.pas Index: ZPreview/src/Delphi/Common/NativeXml/NativeXmlCodepages.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NativeXmlCodepages.pas @@ -0,0 +1,169 @@ +unit NativeXmlCodepages; + +interface + +type + + // codepage information (name and codepage record) + TCodepageInfo = packed record + Name: Utf8String; + Codepage: integer; + end; + +const + + // Codepages defined in Windows + cCodepageInfoCount = 143; + cCodePageInfo: array[0..cCodepageInfoCount - 1] of TCodepageInfo = + ( (Name: 'IBM037'; Codepage: 37), //1 + (Name: 'IBM437'; Codepage: 437), + (Name: 'IBM500'; Codepage: 500), + (Name: 'ASMO-708'; Codepage: 708), + (Name: 'ASMO-449+'; Codepage: 709), //5 + (Name: 'BCON V4'; Codepage: 709), + (Name: 'Arabic'; Codepage: 710), + (Name: 'DOS-720'; Codepage: 720), + (Name: 'ibm737'; Codepage: 737), + (Name: 'ibm775'; Codepage: 775), //10 + (Name: 'ibm850'; Codepage: 850), + (Name: 'ibm852'; Codepage: 852), + (Name: 'IBM855'; Codepage: 855), + (Name: 'ibm857'; Codepage: 857), + (Name: 'IBM00858'; Codepage: 858), + (Name: 'IBM860'; Codepage: 860), + (Name: 'ibm861'; Codepage: 861), + (Name: 'DOS-862'; Codepage: 862), + (Name: 'IBM863'; Codepage: 863), + (Name: 'IBM864'; Codepage: 864), //20 + (Name: 'IBM865'; Codepage: 865), + (Name: 'cp866'; Codepage: 866), + (Name: 'ibm869'; Codepage: 869), + (Name: 'IBM870'; Codepage: 870), + (Name: 'windows-874'; Codepage: 874), + (Name: 'cp875'; Codepage: 875), + (Name: 'shift_jis'; Codepage: 932), + (Name: 'gb2312'; Codepage: 936), + (Name: 'ks_c_5601-1987'; Codepage: 949), + (Name: 'big5'; Codepage: 950), //30 + (Name: 'IBM1026'; Codepage: 1026), + (Name: 'IBM01047'; Codepage: 1047), + (Name: 'IBM01140'; Codepage: 1140), + (Name: 'IBM01141'; Codepage: 1141), + (Name: 'IBM01142'; Codepage: 1142), + (Name: 'IBM01143'; Codepage: 1143), + (Name: 'IBM01144'; Codepage: 1144), + (Name: 'IBM01145'; Codepage: 1145), + (Name: 'IBM01146'; Codepage: 1146), + (Name: 'IBM01147'; Codepage: 1147), //40 + (Name: 'IBM01148'; Codepage: 1148), + (Name: 'IBM01149'; Codepage: 1149), + (Name: 'utf-16'; Codepage: 1200), + (Name: 'unicodeFFFE'; Codepage: 1201), + (Name: 'windows-1250'; Codepage: 1250), + (Name: 'windows-1251'; Codepage: 1251), + (Name: 'windows-1252'; Codepage: 1252), + (Name: 'windows-1253'; Codepage: 1253), + (Name: 'windows-1254'; Codepage: 1254), + (Name: 'windows-1255'; Codepage: 1255), //50 + (Name: 'windows-1256'; Codepage: 1256), + (Name: 'windows-1257'; Codepage: 1257), + (Name: 'windows-1258'; Codepage: 1258), + (Name: 'Johab'; Codepage: 1361), + (Name: 'macintosh'; Codepage: 10000), + (Name: 'x-mac-japanese'; Codepage: 10001), + (Name: 'x-mac-chinesetrad'; Codepage: 10002), + (Name: 'x-mac-korean'; Codepage: 10003), + (Name: 'x-mac-arabic'; Codepage: 10004), + (Name: 'x-mac-hebrew'; Codepage: 10005), //60 + (Name: 'x-mac-greek'; Codepage: 10006), + (Name: 'x-mac-cyrillic'; Codepage: 10007), + (Name: 'x-mac-chinesesimp'; Codepage: 10008), + (Name: 'x-mac-romanian'; Codepage: 10010), + (Name: 'x-mac-ukrainian'; Codepage: 10017), + (Name: 'x-mac-thai'; Codepage: 10021), + (Name: 'x-mac-ce'; Codepage: 10029), + (Name: 'x-mac-icelandic'; Codepage: 10079), + (Name: 'x-mac-turkish'; Codepage: 10081), + (Name: 'x-mac-croatian'; Codepage: 10082), //70 + (Name: 'utf-32'; Codepage: 12000), + (Name: 'utf-32BE'; Codepage: 12001), + (Name: 'x-Chinese_CNS'; Codepage: 20000), + (Name: 'x-cp20001'; Codepage: 20001), + (Name: 'x_Chinese-Eten'; Codepage: 20002), + (Name: 'x-cp20003'; Codepage: 20003), + (Name: 'x-cp20004'; Codepage: 20004), + (Name: 'x-cp20005'; Codepage: 20005), + (Name: 'x-IA5'; Codepage: 20105), + (Name: 'x-IA5-German'; Codepage: 20106), //80 + (Name: 'x-IA5-Swedish'; Codepage: 20107), + (Name: 'x-IA5-Norwegian'; Codepage: 20108), + (Name: 'us-ascii'; Codepage: 20127), + (Name: 'x-cp20261'; Codepage: 20261), + (Name: 'x-cp20269'; Codepage: 20269), + (Name: 'IBM273'; Codepage: 20273), + (Name: 'IBM277'; Codepage: 20277), + (Name: 'IBM278'; Codepage: 20278), + (Name: 'IBM280'; Codepage: 20280), + (Name: 'IBM284'; Codepage: 20284), //90 + (Name: 'IBM285'; Codepage: 20285), + (Name: 'IBM290'; Codepage: 20290), + (Name: 'IBM297'; Codepage: 20297), + (Name: 'IBM420'; Codepage: 20420), + (Name: 'IBM423'; Codepage: 20423), + (Name: 'IBM424'; Codepage: 20424), + (Name: 'x-EBCDIC-KoreanExtended'; Codepage: 20833), + (Name: 'IBM-Thai'; Codepage: 20838), + (Name: 'koi8-r'; Codepage: 20866), + (Name: 'IBM871'; Codepage: 20871), //100 + (Name: 'IBM880'; Codepage: 20880), + (Name: 'IBM905'; Codepage: 20905), + (Name: 'IBM00924'; Codepage: 20924), + (Name: 'EUC-JP'; Codepage: 20932), + (Name: 'x-cp20936'; Codepage: 20936), + (Name: 'x-cp20949'; Codepage: 20949), + (Name: 'cp1025'; Codepage: 21025), + (Name: 'koi8-u'; Codepage: 21866), + (Name: 'iso-8859-1'; Codepage: 28591), + (Name: 'iso-8859-2'; Codepage: 28592), //110 + (Name: 'iso-8859-3'; Codepage: 28593), + (Name: 'iso-8859-4'; Codepage: 28594), + (Name: 'iso-8859-5'; Codepage: 28595), + (Name: 'iso-8859-6'; Codepage: 28596), + (Name: 'iso-8859-7'; Codepage: 28597), + (Name: 'iso-8859-8'; Codepage: 28598), + (Name: 'iso-8859-9'; Codepage: 28599), + (Name: 'iso-8859-13'; Codepage: 28603), + (Name: 'iso-8859-15'; Codepage: 28605), + (Name: 'x-Europa'; Codepage: 29001), //120 + (Name: 'iso-8859-8-i'; Codepage: 38598), + (Name: 'iso-2022-jp'; Codepage: 50220), + (Name: 'csISO2022JP'; Codepage: 50221), + (Name: 'iso-2022-jp'; Codepage: 50222), + (Name: 'iso-2022-kr'; Codepage: 50225), + (Name: 'x-cp50227'; Codepage: 50227), + (Name: 'euc-jp'; Codepage: 51932), + (Name: 'EUC-CN'; Codepage: 51936), + (Name: 'euc-kr'; Codepage: 51949), + (Name: 'hz-gb-2312'; Codepage: 52936), //130 + (Name: 'GB18030'; Codepage: 54936), + (Name: 'x-iscii-de'; Codepage: 57002), + (Name: 'x-iscii-be'; Codepage: 57003), + (Name: 'x-iscii-ta'; Codepage: 57004), + (Name: 'x-iscii-te'; Codepage: 57005), + (Name: 'x-iscii-as'; Codepage: 57006), + (Name: 'x-iscii-or'; Codepage: 57007), + (Name: 'x-iscii-ka'; Codepage: 57008), + (Name: 'x-iscii-ma'; Codepage: 57009), + (Name: 'x-iscii-gu'; Codepage: 57010), //140 + (Name: 'x-iscii-pa'; Codepage: 57011), + (Name: 'utf-7'; Codepage: 65000), + (Name: 'utf-8'; Codepage: 65001));//143 + +implementation + +end. + + + + + ADDED ZPreview/src/Delphi/Common/NativeXml/NativeXmlNodes.pas Index: ZPreview/src/Delphi/Common/NativeXml/NativeXmlNodes.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NativeXmlNodes.pas @@ -0,0 +1,491 @@ +{ unit NativeXmlNodes + + NativeXmlNodes.pas provides some functionality for xml nodes and attributes + in a LINQ-like way. The first LINQ enhancement was directly in NativeXml.pas, + made by Hans-Dieter Karl. Now this functionality is in unit NativeXmlNodes.pas, + using auxiliary class NativeXmlEx. +} +unit NativeXmlNodes; + +interface + +uses + Classes, Contnrs, NativeXml, NativeXmlCodepages; + +type + + TNativeXmlEx = class(TNativeXml) + public + constructor CreateEx(AOwner: TComponent; HasDeclaration, HasDocType, HasRoot: boolean; ARootName: Utf8String); + // some more added methods in a LINQ-like way: + // attributes + function AttrText(AName, AValue: Utf8String): TsdAttribute; + function AttrInt(AName: Utf8String; AValue: integer): TsdAttribute; + function AttrInt64(AName: Utf8String; AValue: int64): TsdAttribute; + function AttrFloat(AName: Utf8String; AValue: double): TsdAttribute; overload; + function AttrFloat(AName: Utf8String; AValue: double; ASignificantDigits: integer; + AAllowScientific: boolean): TsdAttribute; overload; + function AttrDateTime(AName: Utf8String; AValue: TDateTime): TsdAttribute; + function AttrBool(AName: Utf8String; AValue: boolean): TsdAttribute; + + // container nodes + function NodeNew(AName: Utf8String): TXmlNode; overload; virtual; + function NodeNew(AName: Utf8String; SubNodes: array of TXmlNode): TXmlNode; overload; virtual; + function NodeNewEx(AName: Utf8String; out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewEx(AName: Utf8String; out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; overload; + + // string nodes + function NodeNewText(AName, AValue: Utf8String): TXmlNode; overload; + function NodeNewTextEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewText(AName, AValue: Utf8String; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewTextEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewType(AName: Utf8String; AElementType: TsdElementType): TXmlNode; overload; + function NodeNewTypeEx(AName: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewType(AName: Utf8String; AElementType: TsdElementType; + SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewTypeEx(AName: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewAttr(AName: Utf8String; Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewAttrEx(AName: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewAttr(AName: Utf8String; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewAttrEx(AName: Utf8String; out AXMLNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewTextType(AName, AValue: Utf8String; + AElementType: TsdElementType): TXmlNode; overload; + function NodeNewTextTypeEx(AName, AValue: Utf8String; + AElementType: TsdElementType; out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewTextType(AName, AValue: Utf8String; + AElementType: TsdElementType; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewTextTypeEx(AName, AValue: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewTextAttr(AName, AValue: Utf8string; Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewTextAttrEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewTextAttr(AName, AValue: Utf8String; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewTextAttrEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewTextTypeAttr(AName, AValue: Utf8String; AElementType: TsdElementType; + Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewTextTypeAttr(AName, AValue: Utf8String; AElementType: TsdElementType; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewTextTypeAttrEx(AName, AValue: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewTextTypeAttrEx(AName, AValue: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; overload; + + // integer nodes + function NodeNewInt(AName: Utf8String; AValue: integer): TXmlNode; overload; + function NodeNewIntEx(AName: Utf8String; AValue: integer; out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewInt(AName: Utf8String; AValue: integer; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewIntEx(AName: Utf8String; AValue: integer; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewIntType(AName: Utf8String; AValue: integer; + AElementType: TsdElementType): TXmlNode; overload; + function NodeNewIntTypeEx(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; out AXmlNode: TXmlNode): TXmlNode; overload; + function NodeNewIntType(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewIntTypeEx(AName: Utf8String; AValue: integer; AElementType: TsdElementType; + out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewIntAttr(AName: Utf8String; AValue: integer; Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewIntAttrEx(AName: Utf8String; AValue: integer; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewIntAttr(AName: Utf8String; AValue: integer; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewIntAttrEx(AName: Utf8String; AValue: integer; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; overload; + + function NodeNewIntTypeAttr(AName: Utf8String; AValue: integer; AElementType: TsdElementType; + Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewIntTypeAttrEx(AName: Utf8String; AValue: integer; AElementType: TsdElementType; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute): TXmlNode; overload; + function NodeNewIntTypeAttr(AName: Utf8String; AValue: integer; AElementType: TsdElementType; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; overload; + function NodeNewIntTypeAttrEx(AName: Utf8String; AValue: integer; AElementType: TsdElementType; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; overload; + end; + +implementation + +// simple constructor without declaration, but with a standard root element +constructor TNativeXmlEx.CreateEx(AOwner: TComponent; HasDeclaration, HasDocType, HasRoot: boolean; ARootName: Utf8String); +begin + inherited Create(AOwner); + + // FRootNodes is an owned list + FRootNodes := TsdNodeList.Create(True); + + // CreateEx options +//todo FHasDeclaration := HasDeclaration; +//todo FHasDocType := HasDocType; +//todo FHasRoot := HasRoot; +//todo FRootName := ARootName; + + // this resets defaults +//todo ResetDefaults; + + // now clear the rootnodes and create optional declaration, doctype and root +//todo ClearData(FHasDeclaration, FHasDocType, FHasRoot); +end; + +function TNativeXmlEx.AttrText(AName, AValue: Utf8String): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := AValue; +end; + +function TNativeXmlEx.AttrInt(AName: Utf8String; AValue: integer): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdIntToString(AValue); +end; + +function TNativeXmlEx.AttrInt64(AName: Utf8String; AValue: int64): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdInt64ToString(AValue); +end; + + +function TNativeXmlEx.AttrFloat(AName: Utf8String; AValue: double): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdFloatToString(AValue, cDefaultFloatSignificantDigits, + cDefaultFloatAllowScientific); +end; + +function TNativeXmlEx.AttrFloat(AName: Utf8String; AValue: double; ASignificantDigits: integer; + AAllowScientific: boolean): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdFloatToString(AValue, ASignificantDigits, AAllowScientific); +end; + +function TNativeXmlEx.AttrDateTime(AName: Utf8String; AValue: TDateTime): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdDateTimeToString(AValue, True, True); +end; + +function TNativeXmlEx.AttrBool(AName: Utf8String; AValue: boolean): TsdAttribute; +begin + Result := TsdAttribute.Create(Self); + Result.Name := AName; + Result.Value := sdBoolToString(AValue); +end; + + +function TNativeXmlEx.NodeNew(AName: Utf8String): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', xeElement, [], []); +end; + +function TNativeXmlEx.NodeNewEx(AName: Utf8String; out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', xeElement, AXmlNode, [], []); +end; + +function TNativeXmlEx.NodeNew(AName: Utf8String; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', xeElement, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewEx(AName: Utf8String; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', xeElement, AXmlNode, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewType(AName: Utf8String; AElementType: TsdElementType): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', AElementType, [], []); +end; + +function TNativeXmlEx.NodeNewTypeEx(AName: Utf8string; AElementType: TsdElementType; + out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', AElementType, AXmlNode, [], []); +end; + +function TNativeXmlEx.NodeNewType(AName: Utf8string; AElementType: TsdElementType; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', AElementType, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewTypeEx(AName: Utf8String; AElementType: TsdElementType; + out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', AElementType, AXmlNode, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewAttr(AName: Utf8String; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', xeElement, Attributes, []); +end; + +function TNativeXmlEx.NodeNewAttrEx(AName: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', xeElement, AXmlNode, Attributes, []); +end; + +function TNativeXmlEx.NodeNewAttr(AName: Utf8String; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, '', xeElement, Attributes, SubNodes); +end; + +function TNativeXmlEx.NodeNewAttrEx(AName: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, '', xeElement, AXmlNode, Attributes, + SubNodes); +end; + +function TNativeXmlEx.NodeNewText(AName, AValue: Utf8String): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, xeElement, [], []); +end; + +function TNativeXmlEx.NodeNewTextEx(AName, AValue: Utf8String; + out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, xeElement, AXmlNode, [], []); +end; + +function TNativeXmlEx.NodeNewText(AName, AValue: Utf8String; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, xeElement, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewTextEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, xeElement, AXmlNode, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewTextType(AName, AValue: Utf8String; + AElementType: TsdElementType): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, AElementType, [], []); +end; + +function TNativeXmlEx.NodeNewTextTypeEx(AName, AValue: Utf8String; + AElementType: TsdElementType; out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, AElementType, AXmlNode, [], []); +end; + +function TNativeXmlEx.NodeNewTextType(AName, AValue: Utf8String; + AElementType: TsdElementType; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, AElementType, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewTextTypeEx(AName, AValue: Utf8String; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, AElementType, AXmlNode, [], + SubNodes); +end; + +function TNativeXmlEx.NodeNewTextAttr(AName, AValue: Utf8String; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, xeElement, Attributes, []); +end; + +function TNativeXmlEx.NodeNewTextAttrEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, xeElement, AXmlNode, Attributes, + []); +end; + +function TNativeXmlEx.NodeNewTextAttr(AName, AValue: Utf8String; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, xeElement, Attributes, SubNodes); +end; + +function TNativeXmlEx.NodeNewTextAttrEx(AName, AValue: Utf8String; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, xeElement, AXmlNode, Attributes, + SubNodes); +end; + +function TNativeXmlEx.NodeNewTextTypeAttr(AName, AValue: Utf8String; + AElementType: TsdElementType; Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, AValue, AElementType, Attributes, []); +end; + +function TNativeXmlEx.NodeNewTextTypeAttrEx(AName, AValue: Utf8String; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, AValue, AElementType, AXmlNode, + Attributes, []); +end; + +function TNativeXmlEx.NodeNewTextTypeAttr(AName, AValue: Utf8String; + AElementType: TsdElementType; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; +var + NodeClass: TsdNodeClass; +begin + NodeClass := cNodeClass[AElementType]; + Result := NodeClass.Create(Self); + Result.Name := AName; + Result.Value := AValue; + + Result.AttributesAdd(Attributes); + Result.NodesAdd(SubNodes); +end; + +function TNativeXmlEx.NodeNewTextTypeAttrEx(AName, AValue: Utf8String; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + AXmlNode := NodeNewTextTypeAttr(AName, AValue, AElementType, Attributes, + SubNodes); + Result := AXmlNode; +end; + +function TNativeXmlEx.NodeNewInt(AName: Utf8String; AValue: integer): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), xeElement, [], []); +end; + +function TNativeXmlEx.NodeNewIntEx(AName: Utf8String; AValue: integer; + out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), xeElement, AXmlNode, + [], []); +end; + +function TNativeXmlEx.NodeNewInt(AName: Utf8String; AValue: integer; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), xeElement, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewIntEx(AName: Utf8String; AValue: integer; + out AXmlNode: TXmlNode; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), xeElement, AXmlNode, + [], SubNodes); +end; + +function TNativeXmlEx.NodeNewIntAttr(AName: Utf8String; AValue: integer; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), xeElement, Attributes, + []); +end; + +function TNativeXmlEx.NodeNewIntAttrEx(AName: Utf8String; AValue: integer; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), xeElement, AXmlNode, + Attributes, []); +end; + +function TNativeXmlEx.NodeNewIntAttr(AName: Utf8String; AValue: integer; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), xeElement, Attributes, + SubNodes); +end; + +function TNativeXmlEx.NodeNewIntAttrEx(AName: Utf8String; AValue: integer; + out AXmlNode: TXmlNode; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), xeElement, AXmlNode, + Attributes, SubNodes); +end; + +function TNativeXmlEx.NodeNewIntTypeAttr(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), AElementType, Attributes, + []); +end; + +function TNativeXmlEx.NodeNewIntTypeAttrEx(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), AElementType, AXmlNode, + Attributes, []); +end; + +function TNativeXmlEx.NodeNewIntType(AName: Utf8String; AValue: integer; + AElementType: TsdElementType): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), AElementType, [], []); +end; + +function TNativeXmlEx.NodeNewIntTypeEx(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; out AXmlNode: TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), AElementType, AXmlNode, + [], []); +end; + +function TNativeXmlEx.NodeNewIntType(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), AElementType, [], SubNodes); +end; + +function TNativeXmlEx.NodeNewIntTypeEx(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), AElementType, AXmlNode, + [], SubNodes); +end; + +function TNativeXmlEx.NodeNewIntTypeAttr(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; Attributes: array of TsdAttribute; + SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttr(AName, sdIntToString(AValue), AElementType, Attributes, + SubNodes); +end; + +function TNativeXmlEx.NodeNewIntTypeAttrEx(AName: Utf8String; AValue: integer; + AElementType: TsdElementType; out AXmlNode: TXmlNode; + Attributes: array of TsdAttribute; SubNodes: array of TXmlNode): TXmlNode; +begin + Result := NodeNewTextTypeAttrEx(AName, sdIntToString(AValue), AElementType, AXmlNode, + Attributes, SubNodes); +end; + +end. ADDED ZPreview/src/Delphi/Common/NativeXml/NativeXmlObjectStorage.pas Index: ZPreview/src/Delphi/Common/NativeXml/NativeXmlObjectStorage.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/NativeXmlObjectStorage.pas @@ -0,0 +1,1388 @@ +{ unit NativeXmlObjectStorage + + This unit provides functionality to store any TObject descendant to an XML file + or stream. Internally it makes full use of RTTI (RunTime Type Information) in + order to store all published properties and events. + + It can even be used to copy forms, but form inheritance is not exploited, so + child forms descending from parent forms store everything that the parent already + stored. + + All published properties and events of objects are stored. This includes + the "DefineProperties". These are stored in binary form in the XML, encoded + as BASE64. + + Known limitations: + - The method and event lookup will not work correctly across forms. + + Please see the "ObjectToXML" demo for example usage of this unit. + + Original Author: Nils Haeck M.Sc. + Copyright (c) 2003-2011 Simdesign B.V. + + Contributor(s): + Adam Siwon: + - fixes for stored properties + - TCollection items + + It is NOT allowed under ANY circumstances to publish or copy this code + without accepting the license conditions in accompanying LICENSE.txt + first! + + 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. +} +unit NativeXmlObjectStorage; + +{$i simdesign.inc} + +// undefine 'useForms' to avoid including the forms and controls units (visual lib). +// This will reduce the app by several megabytes. +{$define useForms} + +interface + + +uses + Classes, SysUtils, +{$ifdef useForms} + Forms, Controls, +{$endif} + TypInfo, Variants, NativeXml, sdDebug; + +type + + // Use TsdXmlObjectWriter to write any TPersistent descendant's published properties + // to an XML node. + TsdXmlObjectWriter = class(TDebugPersistent) + protected + procedure WriteProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo); + public + // Call WriteObject to write the published properties of AObject to the TXmlNode + // ANode. Specify AParent in order to store references to parent methods and + // events correctly. + procedure WriteObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil); + // Call WriteComponent to write the published properties of AComponent to the TXmlNode + // ANode. Specify AParent in order to store references to parent methods and + // events correctly. + procedure WriteComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent = nil); + end; + + // Use TsdXmlObjectReader to read any TPersistent descendant's published properties + // from an XML node. + TsdXmlObjectReader = class(TDebugPersistent) + private + FSetDefaultValues: Boolean; + protected + function ReadProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo): boolean; + public + // Call CreateComponent to first create AComponent and then read its published + // properties from the TXmlNode ANode. Specify AParent in order to resolve + // references to parent methods and events correctly. In order to successfully + // create the component from scratch, the component's class must be registered + // beforehand with a call to RegisterClass. Specify Owner to add the component + // as a child to Owner's component list. This is usually a form. Specify Name + // as the new component name for the created component. + function CreateComponent(ANode: TXmlNode; AOwner, AParent: TComponent; AName: string = ''): TComponent; + // Call ReadObject to read the published properties of AObject from the TXmlNode + // ANode. Specify AParent in order to resolve references to parent methods and + // events correctly. + function ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil): boolean; + // Call ReadComponent to read the published properties of AComponent from the TXmlNode + // ANode. Specify AParent in order to resolve references to parent methods and + // events correctly. + procedure ReadComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent); + // The flag that determines whether the property that are not saved in the + // XML file. + property SetDefaultValues: Boolean read FSetDefaultValues write FSetDefaultValues; + end; + +// High-level create methods + +// Create and read a component from the XML file with FileName. In order to successfully +// create the component from scratch, the component's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the component +// as a child to Owner's component list. This is usually a form. Specify Name +// as the new component name for the created component. +function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent; + const Name: string): TComponent; + +// Create and read a component from the TXmlNode ANode. In order to successfully +// create the component from scratch, the component's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the component +// as a child to Owner's component list. This is usually a form. Specify Name +// as the new component name for the created component. +function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent; + const Name: string): TComponent; + +// Create and read a component from the XML stream S. In order to successfully +// create the component from scratch, the component's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the component +// as a child to Owner's component list. This is usually a form. Specify Name +// as the new component name for the created component. +function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent; + const Name: string): TComponent; + +// Create and read a component from the XML in string in Value. In order to successfully +// create the component from scratch, the component's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the component +// as a child to Owner's component list. This is usually a form. Specify Name +// as the new component name for the created component. +function ComponentCreateFromXmlString(const Value: string; Owner: TComponent; + const Name: string): TComponent; + +{$ifdef useForms} +// Create and read a form from the XML file with FileName. In order to successfully +// create the form from scratch, the form's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the form +// as a child to Owner's component list. For forms this is usually Application. +// Specify Name as the new form name for the created form. +function FormCreateFromXmlFile(const FileName: string; Owner: TComponent; + const Name: string): TForm; + +// Create and read a form from the XML stream in S. In order to successfully +// create the form from scratch, the form's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the form +// as a child to Owner's component list. For forms this is usually Application. +// Specify Name as the new form name for the created form. +function FormCreateFromXmlStream(S: TStream; Owner: TComponent; + const Name: string): TForm; + +// Create and read a form from the XML string in Value. In order to successfully +// create the form from scratch, the form's class must be registered +// beforehand with a call to RegisterClass. Specify Owner to add the form +// as a child to Owner's component list. For forms this is usually Application. +// Specify Name as the new form name for the created form. +function FormCreateFromXmlString(const Value: string; Owner: TComponent; + const Name: string): TForm; +{$endif} + +// High-level load methods + +// Load all the published properties of AObject from the XML file in Filename. +// Specify AParent in order to resolve references to parent methods and +// events correctly. +procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string; + AParent: TComponent = nil); + +// Load all the published properties of AObject from the TXmlNode ANode. +// Specify AParent in order to resolve references to parent methods and +// events correctly. +procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); + +// Load all the published properties of AObject from the XML stream in S. +// Specify AParent in order to resolve references to parent methods and +// events correctly. +procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); + +// Load all the published properties of AObject from the XML string in Value. +// Specify AParent in order to resolve references to parent methods and +// events correctly. +procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil); + +// High-level save methods + +// Save all the published properties of AObject as XML to the file in Filename. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string; + AParent: TComponent = nil); + +// Save all the published properties of AObject to the TXmlNode ANode. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); + +// Save all the published properties of AObject as XML in stream S. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); + +// Save all the published properties of AObject as XML in string Value. +// Specify AParent in order to store references to parent methods and +// events correctly. +function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string; + +// Save all the published properties of AComponent as XML in the file in Filename. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string; + AParent: TComponent = nil); + +// Save all the published properties of AComponent to the TXmlNode ANode. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode; + AParent: TComponent = nil); + +// Save all the published properties of AComponent as XML in the stream in S. +// Specify AParent in order to store references to parent methods and +// events correctly. +procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream; + AParent: TComponent = nil); + +// Save all the published properties of AComponent as XML in the string Value. +// Specify AParent in order to store references to parent methods and +// events correctly. +function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string; + +{$ifdef useForms} +// Save the form AForm as XML to the file in Filename. This method also stores +// properties of all child components on the form, and can therefore be used +// as a form-storage method. +procedure FormSaveToXmlFile(AForm: TForm; const FileName: string); + +// Save the form AForm as XML to the stream in S. This method also stores +// properties of all child components on the form, and can therefore be used +// as a form-storage method. +procedure FormSaveToXmlStream(AForm: TForm; S: TStream); + +// Save the form AForm as XML to a string. This method also stores +// properties of all child components on the form, and can therefore be used +// as a form-storage method. +function FormSaveToXmlString(AForm: TForm): string; +{$endif} + +resourcestring + + sIllegalVarType = 'illegal variant type'; + sUnregisteredClassType = 'unregistered classtype encountered in '; + sInvalidPropertyValue = 'invalid property value'; + sInvalidMethodName = 'invalid method name'; + +implementation + +type + + TPersistentAccess = class(TPersistent); + TComponentAccess = class(TComponent) + public + procedure SetComponentState(const AState: TComponentState); + published + property ComponentState; + end; + + TReaderAccess = class(TReader); + +function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent; + const Name: string): TComponent; +var + S: TStream; +begin + S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + Result := ComponentCreateFromXmlStream(S, Owner, Name); + finally + S.Free; + end; +end; + +function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent; + const Name: string): TComponent; +var + AReader: TsdXmlObjectReader; +begin + Result := nil; + if not assigned(ANode) then + exit; + // Create reader + AReader := TsdXmlObjectReader.Create; + try + // Read the component from the node + Result := AReader.CreateComponent(ANode, Owner, nil, Name); + finally + AReader.Free; + end; +end; + +function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent; + const Name: string): TComponent; +var + ADoc: TNativeXml; +begin + Result := nil; + if not assigned(S) then + exit; + // Create XML document + ADoc := TNativeXml.Create(nil); + try + // Load XML + ADoc.LoadFromStream(S); + // Load from XML node + Result := ComponentCreateFromXmlNode(ADoc.Root, Owner, Name); + finally + ADoc.Free; + end; +end; + +function ComponentCreateFromXmlString(const Value: string; Owner: TComponent; + const Name: string): TComponent; +var + S: TStream; +begin + S := TStringStream.Create(Value); + try + Result := ComponentCreateFromXmlStream(S, Owner, Name); + finally + S.Free; + end; +end; + +{$ifdef useForms} +function FormCreateFromXmlFile(const FileName: string; Owner: TComponent; + const Name: string): TForm; +var + S: TStream; +begin + S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + Result := FormCreateFromXmlStream(S, Owner, Name); + finally + S.Free; + end; +end; + +function FormCreateFromXmlStream(S: TStream; Owner: TComponent; + const Name: string): TForm; +var + ADoc: TNativeXml; +begin + Result := nil; + if not assigned(S) then exit; + // Create XML document + ADoc := TNativeXml.Create(nil); + try + // Load XML + ADoc.LoadFromStream(S); + + // Load from XML node + Result := TForm(ComponentCreateFromXmlNode(ADoc.Root, Owner, Name)); + finally + ADoc.Free; + end; +end; + +function FormCreateFromXmlString(const Value: string; Owner: TComponent; + const Name: string): TForm; +var + S: TStream; +begin + S := TStringStream.Create(Value); + try + Result := FormCreateFromXmlStream(S, Owner, Name); + finally + S.Free; + end; +end; +{$endif} + +procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string; + AParent: TComponent = nil); +var + S: TStream; +begin + S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + ObjectLoadFromXmlStream(AObject, S, AParent); + finally + S.Free; + end; +end; + +procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); +var + AReader: TsdXmlObjectReader; +begin + if not assigned(AObject) or not assigned(ANode) then + exit; + // Create writer + AReader := TsdXmlObjectReader.Create; + try + // Write the object to the document + if AObject is TComponent then + AReader.ReadComponent(ANode, TComponent(AObject), AParent) + else + AReader.ReadObject(ANode, AObject, AParent); + finally + AReader.Free; + end; +end; + +procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); +var + ADoc: TNativeXml; +begin + if not assigned(S) then + exit; + // Create XML document + ADoc := TNativeXml.Create(nil); + try + // Load XML + ADoc.LoadFromStream(S); + // Load from XML node + ObjectLoadFromXmlNode(AObject, ADoc.Root, AParent); + finally + ADoc.Free; + end; +end; + +procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil); +var + S: TStringStream; +begin + S := TStringStream.Create(Value); + try + ObjectLoadFromXmlStream(AObject, S, AParent); + finally + S.Free; + end; +end; + +procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string; + AParent: TComponent = nil); +var + S: TStream; +begin + S := TFileStream.Create(FileName, fmCreate); + try + ObjectSaveToXmlStream(AObject, S, AParent); + finally + S.Free; + end; +end; + +procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil); +var + AWriter: TsdXmlObjectWriter; +begin + if not assigned(AObject) or not assigned(ANode) then + exit; + // Create writer + AWriter := TsdXmlObjectWriter.Create; + try + // Write the object to the document + if AObject is TComponent then + AWriter.WriteComponent(ANode, TComponent(AObject), AParent) + else begin + ANode.Name := UTF8String(AObject.ClassName); + AWriter.WriteObject(ANode, AObject, AParent); + end; + finally + AWriter.Free; + end; +end; + +procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil); +var + ADoc: TNativeXml; +begin + if not assigned(S) then + exit; + // Create XML document + ADoc := TNativeXml.Create(nil); + try + ADoc.XmlFormat := xfReadable; + // Save to XML node + ObjectSaveToXmlNode(AObject, ADoc.Root, AParent); + // Save to stream + ADoc.SaveToStream(S); + finally + ADoc.Free; + end; +end; + +function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string; +var + S: TStringStream; +begin + S := TStringStream.Create(''); + try + ObjectSaveToXmlStream(AObject, S, AParent); + Result := S.DataString; + finally + S.Free; + end; +end; + +procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string; + AParent: TComponent = nil); +begin + ObjectSaveToXmlFile(AComponent, FileName, AParent); +end; + +procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode; + AParent: TComponent = nil); +begin + ObjectSaveToXmlNode(AComponent, ANode, AParent); +end; + +procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream; + AParent: TComponent = nil); +begin + ObjectSaveToXmlStream(AComponent, S, AParent); +end; + +function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string; +begin + Result := ObjectSaveToXmlString(AComponent, AParent); +end; + +{$ifdef useForms} +procedure FormSaveToXmlFile(AForm: TForm; const FileName: string); +begin + ComponentSaveToXmlFile(AForm, FileName, AForm); +end; + +procedure FormSaveToXmlStream(AForm: TForm; S: TStream); +begin + ComponentSaveToXmlStream(AForm, S, AForm); +end; + +function FormSaveToXmlString(AForm: TForm): string; +begin + Result := ComponentSaveToXmlString(AForm, AForm); +end; +{$endif} + +{ TsdXmlObjectWriter } + +procedure TsdXmlObjectWriter.WriteComponent(ANode: TXmlNode; AComponent, + AParent: TComponent); +begin + if not assigned(ANode) or not assigned(AComponent) then + exit; + ANode.Name := UTF8String(AComponent.ClassName); + if length(AComponent.Name) > 0 then + ANode.AttributeAdd('Name', UTF8String(AComponent.Name)); + WriteObject(ANode, AComponent, AParent); +end; + +procedure TsdXmlObjectWriter.WriteObject(ANode: TXmlNode; AObject: TObject; + AParent: TComponent); +var + i, Count: Integer; + PropInfo: PPropInfo; + PropList: PPropList; + S: TStringStream; + AWriter: TWriter; + AChildNode: TXmlNode; + AComponentNode: TXmlNode; + C: TComponent; +begin + if not assigned(ANode) or not assigned(AObject) then + exit; + + // If this is a component, store child components + if AObject is TComponent then + begin + C := TComponent(AObject); + if C.ComponentCount > 0 then + begin + AChildNode := ANode.NodeNew('Components'); + for i := 0 to C.ComponentCount - 1 do + begin + AComponentNode := AChildNode.NodeNew(UTF8String(C.Components[i].ClassName)); + if length(C.Components[i].Name) > 0 then + AComponentNode.AttributeAdd('Name', UTF8String(C.Components[i].Name)); + WriteObject(AComponentNode, C.Components[i], TComponent(AObject)); + end; + end; + end; + + // If this is a collection, store collections items + if AObject is TCollection then + for i := 0 to TCollection(AObject).Count - 1 do + begin + AChildNode := ANode.NodeNew(UTF8String(TCollection(AObject).Items[i].ClassName)); + WriteObject(AChildNode, TCollection(AObject).Items[i], AParent); + end; + + // Save all regular properties that need storing + Count := GetTypeData(AObject.ClassInfo)^.PropCount; + if Count > 0 then + begin + GetMem(PropList, Count * SizeOf(Pointer)); + try + GetPropInfos(AObject.ClassInfo, PropList); + for i := 0 to Count - 1 do + begin + PropInfo := PropList^[i]; + if PropInfo = nil then + continue; + if IsStoredProp(AObject, PropInfo) then + WriteProperty(ANode, AObject, AParent, PropInfo); + end; + finally + FreeMem(PropList, Count * SizeOf(Pointer)); + end; + end; + + // Save defined properties + if AObject is TPersistent then + begin + S := TStringStream.Create(''); + try + AWriter := TWriter.Create(S, 4096); + try + TPersistentAccess(AObject).DefineProperties(AWriter); + finally + AWriter.Free; + end; + // Do we have data from DefineProperties? + if S.Size > 0 then + begin + // Yes, add a node with binary data + ANode.NodeNew('DefinedProperties').BinaryString := RawByteString(S.DataString); + end; + finally + S.Free; + end; + end; +end; + +procedure TsdXmlObjectWriter.WriteProperty(ANode: TXmlNode; AObject: TObject; + AParent: TComponent; PropInfo: PPropInfo); +var + PropType: PTypeInfo; + AChildNode: TXmlNode; + ACollectionNode: TXmlNode; + + //local + procedure WritePropName; + begin + AChildNode := ANode.NodeNew(PPropInfo(PropInfo)^.Name); + end; + + //local + procedure WriteInteger(Value: Int64); + begin + AChildNode.Value := UTF8String(IntToStr(Value)); + end; + + //local + procedure WriteString(Value: string); + begin + AChildNode.ValueUnicode := Value; + end; + + //local + procedure WriteSet(Value: Longint); + var + I: Integer; + BaseType: PTypeInfo; + S, Enum: string; + begin + BaseType := GetTypeData(PropType)^.CompType^; + for i := 0 to SizeOf(TIntegerSet) * 8 - 1 do + begin + if i in TIntegerSet(Value) then + begin + Enum := GetEnumName(BaseType, i); + if i > 0 then + S := S + ',' + Enum + else + S := Enum; + end; + end; + AChildNode.Value := UTF8String(Format('[%s]', [S])); + end; + + //local + procedure WriteIntProp(IntType: PTypeInfo; Value: Longint); + var + Ident: string; + IntToIdent: TIntToIdent; + begin + IntToIdent := FindIntToIdent(IntType); + if Assigned(IntToIdent) and IntToIdent(Value, Ident) then + WriteString(Ident) + else + WriteInteger(Value); + end; + + //local + procedure WriteCollectionProp(Collection: TCollection); + var + i: integer; + begin + if assigned(Collection) then + begin + for i := 0 to Collection.Count - 1 do + begin + ACollectionNode := AChildNode.NodeNew(UTF8String(Collection.Items[i].ClassName)); + WriteObject(ACollectionNode, Collection.Items[I], AParent); + end; + end; + end; + + //local + procedure WriteOrdProp; + var + Value: Longint; + begin + Value := GetOrdProp(AObject, PropInfo); + if not (Value = PPropInfo(PropInfo)^.Default) then + begin + WritePropName; + case PropType^.Kind of + tkInteger: WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value); + tkChar: WriteString(Chr(Value)); + tkSet: WriteSet(Value); + tkEnumeration: WriteString(GetEnumName(PropType, Value)); + end; + end; + end; + + //local + procedure WriteFloatProp; + var + Value: Extended; + begin + Value := GetFloatProp(AObject, PropInfo); + if not (Value = 0) then + ANode.WriteFloat(PPropInfo(PropInfo)^.Name, Value); + end; + + //local + procedure WriteInt64Prop; + var + Value: Int64; + begin + Value := GetInt64Prop(AObject, PropInfo); + if not (Value = 0) then + ANode.WriteInt64(PPropInfo(PropInfo)^.Name, Value); + end; + + //local + procedure WriteStrProp; + var + Value: Utf8String; + begin + Value := Utf8String(GetStrProp(AObject, PropInfo)); + if not (length(Value) = 0) then + ANode.WriteString(PPropInfo(PropInfo)^.Name, Value); + end; + + //local + procedure WriteWideStrProp; + var + Value: Utf8String; + begin + Value := Utf8String(GetWideStrProp(AObject, PropInfo)); + if not (length(Value) = 0) then + ANode.WriteString(PPropInfo(PropInfo)^.Name, Value); + end; + {$ifdef D12UP} + + //local + procedure WriteUnicodeStrProp; + var + Value: UnicodeString; + begin + Value := GetUnicodeStrProp(AObject, PropInfo); + if not (length(Value) = 0) then + ANode.WriteString(PPropInfo(PropInfo)^.Name, Value); + end; + {$endif} + + //local + procedure WriteObjectProp; + var + Value: TObject; + ComponentName: string; + //local-local + function GetComponentName(Component: TComponent): string; + begin + if Component.Owner = AParent then + Result := Component.Name + else if Component = AParent then + Result := 'Owner' + else if assigned(Component.Owner) and (length(Component.Owner.Name) > 0) + and (length(Component.Name) > 0) then + Result := Component.Owner.Name + '.' + Component.Name + else if length(Component.Name) > 0 then + Result := Component.Name + '.Owner' + else Result := ''; + end; + begin + Value := TObject(GetOrdProp(AObject, PropInfo)); + if not assigned(Value) then + exit; + WritePropName; + if (Value is TComponent) and not (csSubComponent in TComponent(Value).ComponentStyle) then + begin + ComponentName := GetComponentName(TComponent(Value)); + if length(ComponentName) > 0 then + WriteString(ComponentName); + end else + begin + WriteString(Format('(%s)', [Value.ClassName])); + if Value is TCollection then + WriteCollectionProp(TCollection(Value)) + else + begin + if AObject is TComponent then + WriteObject(AChildNode, Value, TComponent(AObject)) + else + WriteObject(AChildNode, Value, AParent) + end; + // No need to store an empty child.. so check and remove + if AChildNode.NodeCount = 0 then + ANode.NodeRemove(AChildNode); + end; + end; + + //local + procedure WriteMethodProp; + var + Value: TMethod; + function IsDefaultValue: Boolean; + begin + Result := (Value.Code = nil) or + ((Value.Code <> nil) and assigned(AParent) and (AParent.MethodName(Value.Code) = '')); + end; + begin + Value := GetMethodProp(AObject, PropInfo); + if not IsDefaultValue then + begin + if assigned(Value.Code) then + begin + WritePropName; + if assigned(AParent) then + WriteString(AParent.MethodName(Value.Code)) + else + AChildNode.Value := '???'; + end; + end; + end; + + //local + function WriteVariantProp: boolean; + var + AValue: Variant; + ACurrency: Currency; + var + VType: Integer; + begin + Result := True; + AValue := GetVariantProp(AObject, PropInfo); + if not VarIsEmpty(AValue) or VarIsNull(AValue) then + begin + if VarIsArray(AValue) then + begin + DoDebugOut(Self, wsWarn, sIllegalVarType); + Result := False; + Exit; + end; + WritePropName; + VType := VarType(AValue); + AChildNode.AttributeAdd('VarType', UTF8String(IntToHex(VType, 4))); + case VType and varTypeMask of + varNull: AChildNode.Value := ''; + varOleStr: AChildNode.Value := Utf8String(AValue); + varString: AChildNode.Value := Utf8String(AValue); + varByte, + varSmallInt, + varInteger: AChildNode.SetValueAsInteger(AValue); + varSingle, + varDouble: AChildNode.SetValueAsFloat(AValue); + varCurrency: + begin + ACurrency := AValue; + AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency)); + end; + varDate: AChildNode.SetValueAsDateTime(AValue); + varBoolean: AChildNode.SetValueAsBool(AValue); + else + try + ANode.Value := AValue; + except + DoDebugOut(Self, wsWarn, sIllegalVarType); + Result := False; + Exit; + end; + end;//case + end; + end; + +//main +begin + if (PPropInfo(PropInfo)^.SetProc <> nil) and + (PPropInfo(PropInfo)^.GetProc <> nil) then + begin + PropType := PPropInfo(PropInfo)^.PropType^; + case PropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp; + tkFloat: WriteFloatProp; + tkString, tkLString: WriteStrProp; + {$ifdef D7UP} + tkWString: WriteWideStrProp; + {$endif} + {$ifdef D12UP} + tkUString: WriteUnicodeStrProp; + {$endif} + tkClass: WriteObjectProp; + tkMethod: WriteMethodProp; + tkVariant: WriteVariantProp; + tkInt64: WriteInt64Prop; + end; + end; +end; + +{ TsdXmlObjectReader } + +function TsdXmlObjectReader.CreateComponent(ANode: TXmlNode; + AOwner, AParent: TComponent; AName: string): TComponent; +var + AClass: TComponentClass; +begin + AClass := TComponentClass(GetClass(string(ANode.Name))); + if not assigned(AClass) then + begin + DoDebugOut(Self, wsFail, Format(sUnregisteredClassType, [ANode.Name])); + Result := nil; + Exit; + end; + Result := AClass.Create(AOwner); + if length(AName) = 0 then + Result.Name := string(ANode.AttributeByName['Name']) + else + Result.Name := AName; + if not assigned(AParent) then + AParent := Result; + ReadComponent(ANode, Result, AParent); +end; + +procedure TsdXmlObjectReader.ReadComponent(ANode: TXmlNode; AComponent, + AParent: TComponent); +begin + ReadObject(ANode, AComponent, AParent); +end; + +function TsdXmlObjectReader.ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent): boolean; +var + i, Count: Integer; + Item: TCollectionItem; + PropInfo: PPropInfo; + PropList: PPropList; + S: TStringStream; + AReader: TReader; + AChildNode: TXmlNode; + AComponentNode: TXmlNode; + AClass: TComponentClass; + AComponent: TComponent; + C: TComponent; + CA: TComponentAccess; + Coll: TCollection; +begin + Result := True; + if not assigned(ANode) or not assigned(AObject) then + exit; + + // Start loading + if AObject is TComponent then + begin + CA := TComponentAccess(AObject); + CA.Updating; + CA.SetComponentState(CA.ComponentState + [csLoading, csReading]); + end; + try + + // If this is a component, load child components + if AObject is TComponent then + begin + C := TComponent(AObject); + AChildNode := ANode.NodeByName('Components'); + if assigned(AChildNode) then + begin + for i := 0 to AChildNode.NodeCount - 1 do + begin + AComponentNode := AChildNode.Nodes[i]; + AComponent := C.FindComponent(string(AComponentNode.AttributeByName['Name'])); + if not assigned(AComponent) then + begin + AClass := TComponentClass(GetClass(string(AComponentNode.Name))); + if not assigned(AClass) then + begin + DoDebugOut(Self, wsFail, sUnregisteredClassType); + Result := False; + Exit; + end; + AComponent := AClass.Create(TComponent(AObject)); + AComponent.Name := AComponentNode.AttributeByName['Name'].Value; +{$ifdef useForms} + // In case of new (visual) controls we set the parent + if (AComponent is TControl) and (AObject is TWinControl) then + TControl(AComponent).Parent := TWinControl(AObject); +{$endif} + end; + ReadComponent(AComponentNode, AComponent, TComponent(AObject)); + end; + end; + end; + + // If this is a collection, load collections items + if AObject is TCollection then + begin + Coll := TCollection(AObject); + Coll.BeginUpdate; + try + Coll.Clear; + for i := 0 to ANode.NodeCount - 1 do + begin + Item := Coll.Add; + ReadObject(ANode.Nodes[i], Item, AParent); + end; + finally + Coll.EndUpdate; + end; + end; + + // Load all loadable regular properties + Count := GetTypeData(AObject.ClassInfo)^.PropCount; + if Count > 0 then + begin + GetMem(PropList, Count * SizeOf(Pointer)); + try + GetPropInfos(AObject.ClassInfo, PropList); + for i := 0 to Count - 1 do + begin + PropInfo := PropList^[i]; + if PropInfo = nil then + continue; + ReadProperty(ANode, AObject, AParent, PropInfo); + end; + finally + FreeMem(PropList, Count * SizeOf(Pointer)); + end; + end; + + // Load defined properties + if AObject is TPersistent then + begin + AChildNode := ANode.NodeByName('DefinedProperties'); + if assigned(AChildNode) then + begin + S := TStringStream.Create(AChildNode.BinaryString); + try + AReader := TReader.Create(S, 4096); + try + while AReader.Position < S.Size do + TReaderAccess(AReader).ReadProperty(TPersistent(AObject)); + finally + AReader.Free; + end; + finally + S.Free; + end; + end; + end; + + finally + // End loading + if AObject is TComponent then + begin + CA := TComponentAccess(AObject); + CA.SetComponentState(CA.ComponentState - [csReading]); + CA.Loaded; + CA.Updated; + end; + end; +end; + +function TsdXmlObjectReader.ReadProperty(ANode: TXmlNode; + AObject: TObject; AParent: TComponent; PropInfo: PPropInfo): boolean; +var + PropType: PTypeInfo; + AChildNode: TXmlNode; + Method: TMethod; + PropObject: TObject; + //local + function SetSetProp(const AValue: string): boolean; + var + S: string; + P: integer; + ASet: integer; + EnumType: PTypeInfo; + // local local + function AddToEnum(const EnumName: string): boolean; + var + V: integer; + begin + Result := True; + if length(EnumName) = 0 then + exit; + V := GetEnumValue(EnumType, EnumName); + if V = -1 then + begin + DoDebugOut(Self, wsFail, sInvalidPropertyValue); + Result := False; + Exit; + end; + Include(TIntegerSet(ASet), V); + end; + begin + Result := True; + ASet := 0; + EnumType := GetTypeData(PropType)^.CompType^; + S := copy(AValue, 2, length(AValue) - 2); + repeat + P := Pos(',', S); + if P > 0 then + begin + AddToEnum(copy(S, 1, P - 1)); + S := copy(S, P + 1, length(S)); + end else + begin + Result := AddToEnum(S); + break; + end; + until False; + SetOrdProp(AObject, PropInfo, ASet); + end; + + procedure SetIntProp(const AValue: string); + var + V: Longint; + IdentToInt: TIdentToInt; + begin + IdentToInt := FindIdentToInt(PropType); + if Assigned(IdentToInt) and IdentToInt(AValue, V) then + SetOrdProp(AObject, PropInfo, V) + else + SetOrdProp(AObject, PropInfo, StrToInt(AValue)); + end; + + function SetCharProp(const AValue: string): boolean; + begin + Result := True; + if length(AValue) <> 1 then + begin + DoDebugOut(Self, wsFail, sInvalidPropertyValue); + Result := False; + Exit; + end; + SetOrdProp(AObject, PropInfo, Ord(AValue[1])); + end; + + function SetEnumProp(const AValue: string): boolean; + var + V: integer; + begin + Result := True; + V := GetEnumValue(PropType, AValue); + if V = -1 then + begin + DoDebugOut(Self, wsFail, sInvalidPropertyValue); + Result := False; + Exit; + end; + SetOrdProp(AObject, PropInfo, V) + end; + + procedure ReadCollectionProp(ACollection: TCollection); + var + i: integer; + Item: TPersistent; + begin + ACollection.BeginUpdate; + try + ACollection.Clear; + for i := 0 to AChildNode.NodeCount - 1 do + begin + Item := ACollection.Add; + ReadObject(AChildNode.Nodes[i], Item, AParent); + end; + finally + ACollection.EndUpdate; + end; + end; + + function SetObjectProp(const AValue: string): boolean; + var + AClassName: string; + PropObject: TObject; + Reference: TComponent; + begin + Result := True; + if length(AValue) = 0 then + exit; + if AValue[1] = '(' then + begin + // Persistent class + AClassName := Copy(AValue, 2, length(AValue) - 2); + PropObject := TObject(GetOrdProp(AObject, PropInfo)); + if assigned(PropObject) and (PropObject.ClassName = AClassName) then + begin + if PropObject is TCollection then + ReadCollectionProp(TCollection(PropObject)) + else + begin + if AObject is TComponent then + ReadObject(AChildNode, PropObject, TComponent(AObject)) + else + ReadObject(AChildNode, PropObject, AParent); + end; + end else + begin + DoDebugOut(Self, wsFail, sUnregisteredClassType); + Result := False; + Exit; + end; + end else + begin + // Component reference + if assigned(AParent) then + begin + Reference := FindNestedComponent(AParent, AValue); + SetOrdProp(AObject, PropInfo, Longint(Reference)); + end; + end; + end; + + function SetMethodProp(const AValue: string): boolean; + var + Method: TMethod; + begin + Result := True; + // to do: add OnFindMethod + if not assigned(AParent) then + exit; + Method.Code := AParent.MethodAddress(AValue); + if not assigned(Method.Code) then + begin + DoDebugOut(Self, wsFail, sInvalidMethodName); + Result := False; + Exit; + end; + Method.Data := AParent; + TypInfo.SetMethodProp(AObject, PropInfo, Method); + end; + + function SetVariantProp(const AValue: string): boolean; + var + VType: integer; + Value: Variant; + ACurrency: Currency; + begin + Result := True; + VType := StrToInt('$' + AChildNode.AttributeByName['VarType'].Value); + + case VType and varTypeMask of + varNull: Value := Null; + varOleStr: Value := AChildNode.ValueUnicode; + varString: Value := AChildNode.Value; + varByte, + varSmallInt, + varInteger: Value := AChildNode.GetValueAsInteger; + varSingle, + varDouble: Value := AChildNode.GetValueAsFloat; + varCurrency: + begin + AChildNode.BufferRead(ACurrency, SizeOf(ACurrency)); + Value := ACurrency; + end; + varDate: Value := AChildNode.GetValueAsDateTime; + varBoolean: Value := AChildNode.GetValueAsBool; + else + try + Value := ANode.Value; + except + DoDebugOut(Self, wsFail, sIllegalVarType); + Result := False; + Exit; + end; + end;//case + + TVarData(Value).VType := VType; + TypInfo.SetVariantProp(AObject, PropInfo, Value); + end; + +begin + Result := True; + if (PPropInfo(PropInfo)^.SetProc <> nil) and + (PPropInfo(PropInfo)^.GetProc <> nil) then + begin + PropType := PPropInfo(PropInfo)^.PropType^; + AChildNode := ANode.NodeByName(PPropInfo(PropInfo)^.Name); + if assigned(AChildNode) then + begin + // Non-default values from XML + case PropType^.Kind of + tkInteger: SetIntProp(AChildNode.Value); + tkChar: SetCharProp(AChildNode.Value); + tkSet: SetSetProp(AChildNode.Value); + tkEnumeration: SetEnumProp(AChildNode.Value); + tkFloat: SetFloatProp(AObject, PropInfo, AChildNode.GetValueAsFloat); + tkString, + tkLString: SetStrProp(AObject, PropInfo, AChildNode.Value); + {$ifndef D12up} + tkWString: SetWideStrProp(AObject, PropInfo, UTF8Decode(AChildNode.Value)); + {$else} + tkWString: SetWideStrProp(AObject, PropInfo, UTF8ToWideString(AChildNode.Value)); + {$endif} + {$ifdef D12UP} + tkUString: SetUnicodeStrProp(AObject, PropInfo, AChildNode.Value); + {$endif} + tkClass: SetObjectProp(AChildNode.Value); + tkMethod: SetMethodProp(AChildNode.Value); + tkVariant: SetVariantProp(AChildNode.Value); + tkInt64: SetInt64Prop(AObject, PropInfo, AChildNode.GetValueAsInt64); + end;//case + end else + begin + if SetDefaultValues then + begin + // Set Default value + case PropType^.Kind of + tkInteger: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); + tkChar: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); + tkSet: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); + tkEnumeration: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default); + tkFloat: SetFloatProp(AObject, PropInfo, 0); + tkString, + tkLString, + tkWString: SetStrProp(AObject, PropInfo, ''); + {$ifdef D12UP} + tkUString: SetStrProp(AObject, PropInfo, ''); + {$endif} + tkClass: + begin + PropObject := TObject(GetOrdProp(AObject, PropInfo)); + if PropObject is TComponent then + SetOrdProp(AObject, PropInfo, 0); + end; + tkMethod: + begin + Method := TypInfo.GetMethodProp(AObject, PropInfo); + Method.Code := nil; + TypInfo.SetMethodProp(AObject, PropInfo, Method); + end; + tkInt64: SetInt64Prop(AObject, PropInfo, 0); + end;//case + end; + end; + end; +end; + +{ TComponentAccess } + +procedure TComponentAccess.SetComponentState(const AState: TComponentState); +type + PInteger = ^integer; +var + PSet: PInteger; + AInfo: PPropInfo; +begin + // This is a "severe" hack in order to set a non-writable property value, + // also using RTTI + PSet := PInteger(@AState); + AInfo := GetPropInfo(TComponentAccess, 'ComponentState'); + if assigned(AInfo.GetProc) then + PInteger(Integer(Self) + Integer(AInfo.GetProc) and $00FFFFFF)^ := PSet^; +end; + +end. + ADDED ZPreview/src/Delphi/Common/NativeXml/contributors.txt Index: ZPreview/src/Delphi/Common/NativeXml/contributors.txt ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/contributors.txt @@ -0,0 +1,12 @@ + Contributor(s): + + Marius Z: devised and helped with the LINQ-like stackable NodeNewXYZ + functions in TNativeXml + Stefan Glienke: TDateTime methods use GetTimeZoneInformation + + Hans-Dieter Karl (hdk): added additional Ansi/Wide/Int64/DateTime functions, some fixes + + NativeXmlNodes.pas provides some functionality for xml nodes and attributes + in a LINQ-like way. The first LINQ enhancement was directly in NativeXml.pas, + made by Hans-Dieter Karl. Now this functionality is in unit NativeXmlNodes.pas, + using auxiliary class NativeXmlEx. ADDED ZPreview/src/Delphi/Common/NativeXml/readme.txt Index: ZPreview/src/Delphi/Common/NativeXml/readme.txt ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/readme.txt @@ -0,0 +1,27 @@ + unit NativeXml + + This is a small-footprint implementation to read and write XML documents + natively from Delpi code. NativeXml has very fast parsing speeds. + + 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. + + Note: any external encoding (ANSI, UTF16, etc) is converted to an internal + encoding that is UTF8. NativeXml uses Utf8String as string type internally, + and converts from strings with external encoding in the parsing process. + When writing, UTtf8String strings are converted to the external encoding strings, + if the encoding was set beforehand, or defaults to UTF8 if no encoding was set. + + Author: Nils Haeck M.Sc. + Copyright (c) 2004 - 2011 Simdesign B.V. (www.simdesign.nl) + + + It is NOT allowed under ANY circumstances to publish, alter or copy this code + without accepting the license conditions in accompanying LICENSE.txt + first! + + 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. ADDED ZPreview/src/Delphi/Common/NativeXml/sdDebug.pas Index: ZPreview/src/Delphi/Common/NativeXml/sdDebug.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/sdDebug.pas @@ -0,0 +1,220 @@ +{ unit sdDebug + + universal method for debugging + + Exceptions often are a hindrance, so instead use these classes + to give important info to the application or user with these + three basic classes + + Besides debug methods, this unit also defines a few compatibility types: + The include file simdesign.inc defines $D5UP and after the + uses-clause these types for D5 are defined. This way, many simdesign + projects are compatible with Delphi 5. + fpc: if lazarus + freepascal is defined, Utf8String just reverts to "string". + + Author: Nils Haeck M.Sc. + Original Date: 08nov2010 + copyright (c) SimDesign BV (www.simdesign.nl) +} +unit sdDebug; + +{$i simdesign.inc} + +interface + +uses + Classes; + +{$ifdef D5UP} +// D5 compatibility types +const + MinsPerHour = 60; + MinsPerDay = MinsPerHour * 24; + soCurrent = soFromCurrent; + soBeginning = soFromBeginning; + soEnd = soFromEnd; + +type + Utf8String = AnsiString; + TSeekOrigin = word; + + PIntegerArray = ^TIntegerArray; + TIntegerArray = array of Integer; + + PByte = ^Byte; + PInteger = ^Integer; + PSingle = ^Single; + PDouble = ^Double; + + // TFormatSettings stub + TFormatSettings = record + end; + + PWord = ^Word; + + function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double; + function StrToBool(S: AnsiString): Boolean; + function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean; +{$endif} + +// lazarus compatibility +{$ifdef fpc} +type + Utf8String = string; +{$endif fpc} + +// Delphi unicode compatibility +{$ifndef UNICODE} +type + UnicodeString = WideString; + RawByteString = AnsiString; +{$endif UNICODE} + +type + TsdWarnStyle = (wsInfo, wsHint, wsWarn, wsFail); + +const + cWarnStyleNames: array[TsdWarnStyle] of Utf8String = ('info', 'hint', 'warn', 'fail'); + +type + // event with debug data + TsdDebugEvent = procedure(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String) of object; + + // simple update event + TsdUpdateEvent = procedure(Sender: TObject) of object; + + TsdDebugComponent = class(TComponent) + protected + FOnDebugOut: TsdDebugEvent; + public + procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual; + // Connect to OnDebugOut to get debug information in the client application + property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut; + end; + + TsdDebugObject = class(TObject) + protected + FOnDebugOut: TsdDebugEvent; + procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual; + public + property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut; + end; + + TsdDebugPersistent = class(TPersistent) + protected + FOwner: TsdDebugComponent; + procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual; + public + constructor CreateDebug(AOwner: TsdDebugComponent); virtual; + end; + +{ Functions } + +function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String; + +function sdClassName(AObject: TObject): Utf8String; + +implementation + +{$ifdef D5UP} +// D5 compatibility types +uses + SysUtils; + +function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double; +begin + try + Result:= StrToFloat(S); + except + Result:= Default; + end; +end; + +// Only basic support +function StrToBool(S: AnsiString): Boolean; +begin + S := LowerCase(S); + if (S = 'no') or (S = '0') or (S = 'false') then + Result := False + else + if (S = 'yes') or (S = '1') or (S = 'true') then + Result:= True + else + raise EConvertError.Create(''); +end; + +function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean; +begin + try + Result := StrToBool(S); + except + Result := Default; + end; +end; +{$endif} + +{ TsdDebugComponent } + +procedure TsdDebugComponent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); +var + AOwner: TComponent; +begin + AOwner := Self; + while AOwner is TsdDebugComponent do + begin + if assigned(TsdDebugComponent(AOwner).FOnDebugOut) then + begin + TsdDebugComponent(AOwner).FOnDebugOut(Sender, WarnStyle, AMessage); + exit; + end; + AOwner := AOwner.Owner; + end; +end; + +{ TsdDebugObject } + +procedure TsdDebugObject.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); +begin + if assigned(FOnDebugOut) then + FOnDebugOut(Sender, WarnStyle, AMessage); +end; + +{ TsdDebugPersistent } + +constructor TsdDebugPersistent.CreateDebug(AOwner: TsdDebugComponent); +begin + inherited Create; + FOwner := AOwner; +end; + +procedure TsdDebugPersistent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); +begin + if FOwner is TsdDebugComponent then + TsdDebugComponent(FOwner).DoDebugOut(Sender, WarnStyle, AMessage); +end; + +{ Functions } + +function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String; +var + SenderString: Utf8String; +begin + if assigned(Sender) then + SenderString := Utf8String(Sender.ClassName) + else + SenderString := ''; + Result := '[' + cWarnStyleNames[WarnStyle] + '] ' + SenderString + ': ' + AMessage; +end; + +function sdClassName(AObject: TObject): Utf8String; +begin + Result := 'nil'; + if assigned(AObject) then + Result := Utf8String(AObject.ClassName); +end; + +end. + + + + ADDED ZPreview/src/Delphi/Common/NativeXml/sdStreams.pas Index: ZPreview/src/Delphi/Common/NativeXml/sdStreams.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/sdStreams.pas @@ -0,0 +1,309 @@ +{ sdStreams.pas + + - TsdFastMemStream with improved capacity setting + - TsdStringStream + - TsdBufferWriter + + Author: Nils Haeck M.Sc. + copyright (c) 2002 - 2011 SimDesign BV (www.simdesign.nl) +} +unit sdStreams; + +{$ifdef lcl}{$MODE Delphi}{$endif} + +{$define simdesign.inc} + +interface + +uses + Classes, SysUtils; + +type + + // TsdFastMemStream deals differently with capacity compared to a normal + // TMemoryStream; it increases the capacity with the natural growing function + // (fibonacci) each time, and has an initial capacity of $1000. The initial + // capacity is configurable with the create parameter. + TsdFastMemStream = class(TStream) + private + FMemory: Pointer; + FPosition: longint; + FFib1: longint; + FCapacity: longint; + FSize: longint; + protected + procedure SetCapacity(Value: longint); + procedure SetSize(NewSize: Longint); override; + public + constructor Create(InitialCapacity: longint = $1000); + destructor Destroy; override; + procedure Clear; + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + procedure LoadFromFile(AFilename: string); + procedure LoadFromStream(Stream: TStream); + procedure SaveToFile(AFilename: string); + procedure SaveToStream(Stream: TStream); + property Memory: Pointer read FMemory; + property Size: longint read FSize write SetSize; + end; + + // 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. + TsdStringStream = class(TsdFastMemStream) + public + constructor Create(const S: Utf8String); + function DataString: Utf8String; + end; + + // TsdBufferWriter is a buffered stream that takes another stream (ASource) + // 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. + TsdBufferWriter = class(TsdFastMemStream) + private + FSource: TStream; + FChunkSize: integer; + FRawBuffer: array of byte; + FRawPosition: Integer; + protected + procedure WriteChunk(Count: integer); + public + // Create the buffered writer stream by passing the destination stream in ASource, + // this destination stream must already be initialized. + constructor Create(ASource: TStream; AChunkSize: integer); + destructor Destroy; override; + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + end; + +implementation + +{ TsdFastMemStream } + +procedure TsdFastMemStream.Clear; +begin + SetCapacity(0); + FSize := 0; + FPosition := 0; +end; + +constructor TsdFastMemStream.Create(InitialCapacity: Integer); +begin + inherited Create; + FFib1 := InitialCapacity div 2; + FCapacity := InitialCapacity; + if FFib1 < 4 then + FFib1 := 4; + if FCapacity < 4 then + FCapacity := 4; + ReallocMem(FMemory, FCapacity); +end; + +destructor TsdFastMemStream.Destroy; +begin + ReallocMem(FMemory, 0); + inherited; +end; + +procedure TsdFastMemStream.LoadFromFile(AFilename: string); +var + Stream: TStream; +begin + Stream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TsdFastMemStream.LoadFromStream(Stream: TStream); +var + Count: Longint; +begin + Stream.Position := 0; + Count := Stream.Size; + SetSize(Count); + if Count <> 0 then Stream.ReadBuffer(FMemory^, Count); +end; + +function TsdFastMemStream.Read(var Buffer; Count: Integer): Longint; +begin + if (FPosition >= 0) and (Count >= 0) then + begin + Result := FSize - FPosition; + if Result > 0 then + begin + if Result > Count then + Result := Count; + Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result); + Inc(FPosition, Result); + Exit; + end; + end; + Result := 0; +end; + +procedure TsdFastMemStream.SaveToFile(AFilename: string); +var + Stream: TStream; +begin + Stream := TFileStream.Create(AFileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TsdFastMemStream.SaveToStream(Stream: TStream); +begin + if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize); +end; + +function TsdFastMemStream.Seek(Offset: Integer; Origin: Word): Longint; +begin + case Origin of + soFromBeginning: FPosition := Offset; + soFromCurrent: Inc(FPosition, Offset); + soFromEnd: FPosition := FSize + Offset; + end; + Result := FPosition; +end; + +procedure TsdFastMemStream.SetCapacity(Value: longint); +// Fibonacci 0,1,1,2,3,5,8,... FCapacity is Fib2. +// Fibonacci is a natural growing function where +// 0 + 1 = 1; 1 + 1 = 2; 1 + 2 = 3; 2 + 3 = 5; etc +var + Fib3: longint; +begin + while FCapacity < Value do + begin + Fib3 := FFib1 + FCapacity; + FFib1 := FCapacity; + FCapacity := Fib3; + end; + ReallocMem(FMemory, FCapacity); +end; + +procedure TsdFastMemStream.SetSize(NewSize: longint); +var + OldPosition: Longint; +begin + OldPosition := FPosition; + SetCapacity(NewSize); + FSize := NewSize; + if OldPosition > NewSize then + Seek(0, soFromEnd); +end; + +function TsdFastMemStream.Write(const Buffer; Count: Integer): Longint; +var + NewPos: Longint; +begin + if (FPosition >= 0) and (Count >= 0) then + begin + NewPos := FPosition + Count; + if NewPos > 0 then + begin + if NewPos > FSize then + begin + if NewPos > FCapacity then + SetCapacity(NewPos); + FSize := NewPos; + end; + System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count); + FPosition := NewPos; + Result := Count; + Exit; + end; + end; + Result := 0; +end; + +{ TsdStringStream } + +constructor TsdStringStream.Create(const S: Utf8String); +begin + inherited Create; + SetSize(length(S)); + if Size > 0 then + begin + Write(S[1], Size); + Position := 0; + end; +end; + +function TsdStringStream.DataString: Utf8String; +begin + SetLength(Result, Size); + if Size > 0 then + begin + Position := 0; + Read(Result[1], length(Result)); + end; +end; + +{ TsdBufferWriter } + +constructor TsdBufferWriter.Create(ASource: TStream; AChunkSize: integer); +begin + inherited Create; + FSource := ASource; + FChunkSize := AChunkSize; + SetLength(FRawBuffer, FChunkSize); +end; + +destructor TsdBufferWriter.Destroy; +begin + // write the last chunk, if any + WriteChunk(FRawPosition); + // free the rawbuffer + SetLength(FRawBuffer, 0); + inherited; +end; + +function TsdBufferWriter.Read(var Buffer; Count: Integer): Longint; +begin + // not implemented + raise Exception.Create('not implemented'); +end; + +function TsdBufferWriter.Write(const Buffer; Count: Integer): Longint; +var + Idx, Siz: integer; +begin + // index in the source buffer + Idx := 0; + // remaining size + Siz := Count; + + // surplus + while FRawPosition + Siz >= FChunkSize do + begin + Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], FChunkSize - FRawPosition); + WriteChunk(FChunkSize); + dec(Siz, FChunkSize - FRawPosition); + inc(Idx, FChunkSize - FRawPosition); + FRawPosition := 0; + end; + + // copy the raw buffer + Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], Siz); + inc(FRawPosition, Siz); + + Result := Count; +end; + +procedure TsdBufferWriter.WriteChunk(Count: integer); +begin + if Count > 0 then + begin + FSource.WriteBuffer(FRawBuffer[0], Count); + end; +end; + +end. ADDED ZPreview/src/Delphi/Common/NativeXml/sdStringTable.pas Index: ZPreview/src/Delphi/Common/NativeXml/sdStringTable.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/sdStringTable.pas @@ -0,0 +1,765 @@ +{ unit sdStringTable + + An optimized table of *unique* strings, using two separate sorted indices: + - by (string) ID + - by sdCompareRefString method + + The sdCompareRefString method does not use common alphabetical compare, but + rather a comparison from first character, then last character, then 2nd, + then before-last, etc. until all characters are compared, or a mismatch is + found. + + Since many (programmer) strings have numbers at the end of the string, + (e.g. "MyNewNode1", "MyNewNode2", etc), the comparison terminates earlier than + with a common alphabetical compare. + + sdStringTable is used by NativeXml but can also be used independently in + your projects. + + Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl) + Original Date: 28 May 2007 + + Modified: + 05jan2011: enhancement, no longer uses stringrec + 17jun2011: changed TStringTable ancestor from TDebugPersistent to TDebugComponent + 24jun2011: "find" fix + 18jul2011: renamed TsdStringTable to TsdSymbolTable and added TsdSymbolStyle + + It is NOT allowed under ANY circumstances to publish or copy this code + without accepting the license conditions in accompanying LICENSE.txt + first! + + 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. + + Copyright (c) 2007 - 2011 Simdesign BV +} +unit sdStringTable; + +{$ifdef lcl}{$MODE Delphi}{$endif} + +interface + +uses + Classes, SysUtils, Contnrs, sdDebug; + + // symbol styles (cardinal) + // Default symbol style is ssUnknown, but highlevel code can + // distinguish between symbol styles. TsdSymbolTable just stores + // the symbol as counted Utf8String. + +const + + ssUnknown = 0; // data not determined yet + ssString = 1; // data is a string + ssBase64Binary = 2; // data is binary and will be handled by Base64 funcs + ssHexBinary = 3; // data is binary and will be handled by BinHex funcs + ssBoolean = 4; // boolean (stored in a byte, just 0 and 1 of cardinal) + ssCardinal = 5; // cardinal (1..N bytes, see TBinaryXml.ReadCardinal) + ssInteger = 6; // integer (1..N bytes) + ssDecimal = 7; // decimal value (see TNativeXml.EncodeDecimalSymbol) + ssDate = 8; // date (see TNativeXml.EncodeDateSymbol) + ssTime = 9; // time (see TNativeXml.EncodeTimeSymbol) + ssDateTime = 10; // datetime (see TNativeXml.EncodeDateTimeSymbol) + + // These were the default symbol styles as used by NativeXml. Other units may + // define more symbols after the last default symbol + +type + // A symbol table, holding a collection of unique strings, sorted in 2 ways + // for fast access. Strings can be added with AddString or AddStringRec. + // When a string is added or updated, an ID is returned which the application + // can use to retrieve the string, using GetString. + TsdStringTable = class(TsdDebugComponent) + private + FByID: TObjectList; + FBySymbol: TObjectList; + FPluralSymbolCount: integer; + function GetSymbolCount: integer; + protected + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + // Clear the string table + procedure Clear; + + // Add a potentially new string S to the table, the function + // returns its string ID. + function AddString(const S: Utf8String): integer; + + // retrieve the string based on its string ID. The string ID is only unique + // within this string table, so do not use IDs from other tables. + function GetString(ID: integer): Utf8String; + + // total number of symbols in the table + property SymbolCount: integer read GetSymbolCount; + + // plural symbols in the table. plural symbols are symbols that have + // a frequency > 1. ie the symbol is found more than once in the app. + // PluralCount is only valid after method SortByFrequency. + property PluralSymbolCount: integer read FPluralSymbolCount; + + + procedure LoadFromFile(const AFileName: string); + procedure LoadFromStream(S: TStream); + function LoadSymbol(S: TStream): Cardinal; + procedure SaveToFile(const AFileName: string); + procedure SaveToStream(S: TStream; ACount: integer); + procedure SaveSymbol(S: TStream; ASymbolID: Cardinal); + + procedure ClearFrequency; + procedure IncrementFrequency(ID: integer); + procedure SortByFrequency(var ANewIDs: array of Cardinal); + end; + +{utility functions} + +// compare two bytes +function sdCompareByte(Byte1, Byte2: byte): integer; + +// compare two integers +function sdCompareInteger(Int1, Int2: integer): integer; + +// unicode UTF8 <> UTF16LE coversion functions +function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer; +function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer; + +// stream methods +function sdStreamReadCardinal(S: TStream): Cardinal; +function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String; +procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal); +procedure sdStreamWriteString(S: TStream; const AString: Utf8String); + +implementation + +type + + // A symbol item used in symbol lists (do not use directly) + TsdString = class + private + FID: integer; + FFreq: Cardinal; + FSymbolStyle: Cardinal; + FFirst: Pbyte; + FCharCount: integer; + public + destructor Destroy; override; + function AsString: Utf8String; + property SymbolStyle: Cardinal read FSymbolStyle; + property CharCount: integer read FCharCount; + end; + + // A list of symbols (do not use directly) + TsdStringList = class(TObjectList) + private + function GetItems(Index: integer): TsdString; + protected + // Assumes list is sorted by refstring + function Find(ASymbol: TsdString; var Index: integer): boolean; + public + property Items[Index: integer]: TsdString read GetItems; default; + end; + + +// compare two symbols. This is NOT an alphabetic compare. symbols are first +// compared by length, then by first byte, then last byte then second, then +// N-1, until all bytes are compared. +function sdCompareSymbol(Symbol1, Symbol2: TsdString): integer; +var + CharCount: integer; + First1, First2, Last1, Last2: Pbyte; + IsEqual: boolean; +begin + // Compare string length first + Result := sdCompareInteger(Symbol1.CharCount, Symbol2.CharCount); + if Result <> 0 then + exit; + + // Compare FFirst + Result := sdCompareByte(Symbol1.FFirst^, Symbol2.FFirst^); + if Result <> 0 then + exit; + + // CharCount of RS1 (and RS2, since they are equal) + CharCount := Symbol1.CharCount; + + // Setup First & Last pointers + First1 := Symbol1.FFirst; + First2 := Symbol2.FFirst; + + // compare memory (boolean op). CompareMem might have optimized code depending + // on memory manager (ASM, MMX, SSE etc) to binary compare the block. + // Since sdCompareRefString may be used to compare relatively large blocks of + // text, which are often exact copies, using CompareMem before special comparison + // is warrented. + IsEqual := CompareMem(First1, First2, CharCount); + if IsEqual then + begin + Result := 0; + exit; + end; + + // finally the special conparison: Compare each time last ptrs then first ptrs, + // until they meet in the middle + Last1 := First1; + inc(Last1, CharCount); + Last2 := First2; + inc(Last2, CharCount); + + repeat + + dec(Last1); + dec(Last2); + if First1 = Last1 then + exit; + + Result := sdCompareByte(Last1^, Last2^); + if Result <> 0 then + exit; + + inc(First1); + inc(First2); + if First1 = Last1 then + exit; + + Result := sdCompareByte(First1^, First2^); + if Result <> 0 then + exit; + + until False; +end; + +{ TsdSymbol } + +function TsdString.AsString: Utf8String; +begin + SetString(Result, PAnsiChar(FFirst), FCharCount); +end; + +destructor TsdString.Destroy; +begin + FreeMem(FFirst); + inherited; +end; + +{ TsdSymbolList } + +function TsdStringList.GetItems(Index: integer): TsdString; +begin + Result := TsdString(Get(Index)); +end; + +function TsdStringList.Find(ASymbol: TsdString; var Index: integer): boolean; +var + AMin, AMax: integer; +begin + Result := False; + + // Find position - binary method + AMin := 0; + AMax := Count; + while AMin < AMax do + begin + Index := (AMin + AMax) div 2; + case sdCompareSymbol(Items[Index], ASymbol) of + -1: AMin := Index + 1; + 0: begin + Result := True; + exit; + end; + 1: AMax := Index; + end; + end; + Index := AMin; +end; + +{ TsdSymbolTable } + +function TsdStringTable.AddString(const S: Utf8String): integer; +var + Found: boolean; + L, BySymbolIndex: integer; + ASymbol, Item: TsdString; +begin + Result := 0; + L := length(S); + + // zero-length string + if L = 0 then + exit; + + ASymbol := TsdString.Create; + try + ASymbol.FFirst := PByte(@S[1]); + ASymbol.FCharCount := L; + + // Try to find the new string + Found := TsdStringList(FBySymbol).Find(ASymbol, BySymbolIndex); + if Found then + begin + // yes it is found + Item := TsdString(FBySymbol[BySymbolIndex]); + Result := Item.FID; + exit; + end; + + // Not found.. must make new item + Item := TsdString.Create; + Item.FCharCount := ASymbol.FCharCount; + + // reallocate memory and copy the string data + ReallocMem(Item.FFirst, Item.FCharCount); + Move(S[1], Item.FFirst^, Item.FCharCount); + + // add to the ByID objectlist + FByID.Add(Item); + Item.FID := FByID.Count; + Result := Item.FID; + + // insert into the ByRS list + FBySymbol.Insert(BySymbolIndex, Item); + + finally + // this ensures we do not deallocate the memory that may be in use elsewhere + ASymbol.FFirst := nil; + ASymbol.Free; + end; + +end; + +procedure TsdStringTable.Clear; +begin + FByID.Clear; + FBySymbol.Clear; +end; + +procedure TsdStringTable.ClearFrequency; +var + i: integer; +begin + for i := 0 to FByID.Count - 1 do + TsdString(FByID[i]).FFreq := 0; +end; + +constructor TsdStringTable.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FByID := TObjectList.Create(True); + FBySymbol := TsdStringList.Create(False); +end; + +destructor TsdStringTable.Destroy; +begin + FreeAndNil(FBySymbol); + FreeAndNil(FByID); + inherited; +end; + +function TsdStringTable.GetSymbolCount: integer; +begin + Result := FByID.Count; +end; + +function TsdStringTable.GetString(ID: integer): Utf8String; +begin + // Find the ID + + // zero string + if ID <= 0 then + begin + Result := ''; + exit; + end; + + // out of bounds? + if ID > FByID.Count then + begin + // output warning + DoDebugOut(Self, wsWarn, 'string ID not found'); + Result := ''; + end; + + Result := TsdString(FByID[ID - 1]).AsString; +end; + +procedure TsdStringTable.IncrementFrequency(ID: integer); +var + RS: TsdString; +begin + RS := TsdString(FByID[ID - 1]); + inc(RS.FFreq); +end; + +procedure TsdStringTable.LoadFromFile(const AFileName: string); +var + S: TMemoryStream; +begin + S := TMemoryStream.Create; + try + S.LoadFromFile(AFileName); + LoadFromStream(S); + finally + S.Free; + end; +end; + +procedure TsdStringTable.LoadFromStream(S: TStream); +var + i: integer; + TableCount: Cardinal; +begin + Clear; + +// DoDebugOut(Self, wsInfo, format('stream position: %d', [S.Position])); + + // table count + TableCount := sdStreamReadCardinal(S); + if TableCount = 0 then + exit; + + for i := 0 to TableCount - 1 do + begin + LoadSymbol(S); + end; +end; + +function TsdStringTable.LoadSymbol(S: TStream): Cardinal; +var + Symbol: TsdString; + BySymbolIndex: integer; + Found: boolean; +begin + Symbol := TsdString.Create; + + // For now, we just use ssString uniquely as symbol style,. + // In updates, different symbol styles can be added. + Symbol.FSymbolStyle := sdStreamReadCardinal(S); + + Symbol.FCharCount := sdStreamReadCardinal(S); + + if Symbol.FCharCount > 0 then + begin + // reallocate memory and copy the string data + ReallocMem(Symbol.FFirst, Symbol.FCharCount); + S.Read(Symbol.FFirst^, Symbol.FCharCount); + end; + + // add to the ByID objectlist + FByID.Add(Symbol); + Symbol.FID := FByID.Count; + Result := Symbol.FID; + + // find the symbol + Found := TsdStringList(FBySymbol).Find(Symbol, BySymbolIndex); + if Found then + begin + DoDebugOut(Self, wsFail, 'duplicate symbol!'); + exit; + end; + + // insert into the ByRS list + FBySymbol.Insert(BySymbolIndex, Symbol); +end; + +procedure TsdStringTable.SaveToFile(const AFileName: string); +var + S: TMemoryStream; +begin + S := TMemoryStream.Create; + try + SaveToStream(S, SymbolCount); + S.SaveToFile(AFileName); + finally + S.Free; + end; +end; + +procedure TsdStringTable.SaveToStream(S: TStream; ACount: integer); +var + i: integer; +begin + // write (part of the) symbol table + sdStreamWriteCardinal(S, ACount); + for i := 0 to ACount - 1 do + begin + SaveSymbol(S, i + 1); + end; +end; + +procedure TsdStringTable.SaveSymbol(S: TStream; ASymbolID: Cardinal); +var + RS: TsdString; + StringVal: Utf8String; + CharCount: Cardinal; +begin + if ASymbolID <= 0 then + DoDebugOut(Self, wsFail, 'symbol ID <= 0'); + RS := TsdString(FByID[ASymbolID - 1]); + + // For now, we just use ssString uniquely as symbol style. + // In updates, different symbol styles can be added. + sdStreamWriteCardinal(S, RS.SymbolStyle); + + StringVal := RS.AsString; + CharCount := length(StringVal); + sdStreamWriteCardinal(S, CharCount); + sdStreamWriteString(S, StringVal); +end; + +procedure TsdStringTable.SortByFrequency(var ANewIDs: array of Cardinal); + // local + function CompareFreq(Pos1, Pos2: integer): integer; + var + RS1, RS2: TsdString; + begin + RS1 := TsdString(FByID[Pos1]); + RS2 := TsdString(FByID[Pos2]); + if RS1.FFreq > RS2.FFreq then + Result := -1 + else + if RS1.FFreq < RS2.FFreq then + Result := 1 + else + Result := 0; + end; + // local + procedure QuickSort(iLo, iHi: Integer); + var + Lo, Hi, Mid: longint; + begin + Lo := iLo; + Hi := iHi; + Mid:= (Lo + Hi) div 2; + repeat + while CompareFreq(Lo, Mid) < 0 do + Inc(Lo); + while CompareFreq(Hi, Mid) > 0 do + Dec(Hi); + if Lo <= Hi then + begin + // Swap pointers; + FByID.Exchange(Lo, Hi); + if Mid = Lo then + Mid := Hi + else + if Mid = Hi then + Mid := Lo; + Inc(Lo); + Dec(Hi); + end; + until Lo > Hi; + + if Hi > iLo then + QuickSort(iLo, Hi); + + if Lo < iHi then + QuickSort(Lo, iHi); + end; +// main +var + i: integer; +begin + // sort by frequency + QuickSort(0, FByID.Count - 1); + + // plural count + FPluralSymbolCount := 0; + i := 0; + while i < FByID.Count do + begin + if TsdString(FByID[i]).FFreq >= 2 then + inc(FPluralSymbolCount) + else + break; + inc(i); + end; + + // tell app about new ID + for i := 0 to FByID.Count - 1 do + begin + ANewIDs[TsdString(FByID[i]).FID] := i + 1; + end; + + // then rename IDs + for i := 0 to FByID.Count - 1 do + begin + TsdString(FByID[i]).FID := i + 1; + end; +end; + +{utility functions} + +function sdCompareByte(Byte1, Byte2: byte): integer; +begin + if Byte1 < Byte2 then + Result := -1 + else + if Byte1 > Byte2 then + Result := 1 + else + Result := 0; +end; + +function sdCompareInteger(Int1, Int2: integer): integer; +begin + if Int1 < Int2 then + Result := -1 + else + if Int1 > Int2 then + Result := 1 + else + Result := 0; +end; + +function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer; +// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process +// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes). +// Therefore, the block at Dst must be at least 1.5 the size of the source block. +// The function returns the number of *bytes* written. +var + W: word; + DStart: Pbyte; +begin + DStart := Dst; + while Count > 0 do + begin + W := Src^; + inc(Src); + if W <= $7F then + begin + Dst^ := byte(W); + inc(Dst); + end else + begin + if W > $7FF then + begin + Dst^ := byte($E0 or (W shr 12)); + inc(Dst); + Dst^ := byte($80 or ((W shr 6) and $3F)); + inc(Dst); + Dst^ := byte($80 or (W and $3F)); + inc(Dst); + end else + begin // $7F < W <= $7FF + Dst^ := byte($C0 or (W shr 6)); + inc(Dst); + Dst^ := byte($80 or (W and $3F)); + inc(Dst); + end; + end; + dec(Count); + end; + Result := integer(Dst) - integer(DStart); +end; + +function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer; +// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process +// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes). +// Therefore, the block at Dst must be at least 2 times the size of Count, since +// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The +// function returns the number of *wide chars* written. Note that the Src block must +// have an exact number of UTF8 characters in it, if Count doesn't match then +// the last character will be converted anyway (going past the block boundary!) +var + W: word; + C: byte; + DStart: Pword; + SClose: Pbyte; +begin + DStart := Dst; + SClose := Src; + inc(SClose, Count); + while integer(Src) < integer(SClose) do + begin + // 1st byte + W := Src^; + inc(Src); + if W and $80 <> 0 then + begin + W := W and $3F; + if W and $20 <> 0 then + begin + // 2nd byte + C := Src^; + inc(Src); + if C and $C0 <> $80 then + // malformed trail byte or out of range char + Continue; + W := (W shl 6) or (C and $3F); + end; + // 2nd or 3rd byte + C := Src^; + inc(Src); + if C and $C0 <> $80 then + // malformed trail byte + Continue; + Dst^ := (W shl 6) or (C and $3F); + inc(Dst); + end else + begin + Dst^ := W; + inc(Dst); + end; + end; + Result := (integer(Dst) - integer(DStart)) div 2; +end; + +{ stream methods } + +function sdStreamReadCardinal(S: TStream): Cardinal; +var + C: byte; + Bits: integer; +begin + Result := 0; + Bits := 0; + repeat + S.Read(C, 1); + if C > 0 then + begin + inc(Result, (C and $7F) shl Bits); + inc(Bits, 7) + end; + until(C and $80) = 0; +end; + +function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String; +begin + SetLength(Result, ACharCount); + if ACharCount = 0 then + exit; + S.Read(Result[1], ACharCount); +end; + +procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal); +var + C: byte; +begin + repeat + if ACardinal <= $7F then + begin + C := ACardinal; + S.Write(C, 1); + exit; + end else + C := (ACardinal and $7F) or $80; + S.Write(C, 1); + ACardinal := ACardinal shr 7; + until ACardinal = 0; +end; + +procedure sdStreamWriteString(S: TStream; const AString: Utf8String); +var + L: integer; +begin + L := Length(AString); + if L > 0 then + begin + S.Write(AString[1], L); + end; +end; + +end. ADDED ZPreview/src/Delphi/Common/NativeXml/simdesign.inc Index: ZPreview/src/Delphi/Common/NativeXml/simdesign.inc ================================================================== --- /dev/null +++ ZPreview/src/Delphi/Common/NativeXml/simdesign.inc @@ -0,0 +1,116 @@ +{ simdesign.inc + + include file for many simdesign projects + default path: \simlib\general + + Author: Nils Haeck M.Sc. + Copyright (c) 2007 - 2013 Simdesign B.V. + +} + +// unicode avoid implicit string cast warning +{$ifdef UNICODE} +{$WARN IMPLICIT_STRING_CAST OFF} +{$endif UNICODE} + +// Delphi and FPC versions + +// Freepascal +{$ifdef FPC} + {$MODE DELPHI} + {$define D7UP} +{$endif FPC} + +// Delphi 5 +{$ifdef VER130} + {$define D5UP} +{$endif} + +//Delphi 6 +{$ifdef VER140} + {$define D5UP} +{$endif} + +//Delphi 7 +{$ifdef VER150} + {$define D7UP} +{$endif} + +//Delphi 8 +{$ifdef VER160} + {$define D7UP} +{$endif} + +// Delphi 2005 / 9 +{$ifdef VER170} + {$define D7UP} +{$endif} + +// Delphi 2006 / 10 +{$ifdef VER180} + {$define D7UP} + // D10 publishes OnMouseEnter / OnMouseLeave + {$define D10UP} +{$endif} + +// Delphi 2007 Rad studio / 11? +{$ifdef VER185} + {$define D7UP} + {$define D10UP} +{$endif} + +// Delphi 2007 - NET / 11? +{$ifdef VER190} + {$define D7UP} + {$define D10UP} +{$endif} + +// Delphi 2009 / 12 +// first UNICODE version, so then directive UNICODE is defined, no need for directive D12UP +{$ifdef VER200} + {$define D7UP} + {$define D10UP} +{$endif} + +// Delphi 2010 / 14? +{$ifdef VER210} + {$define D7UP} + {$define D10UP} +{$endif} + +// Delphi XE / 15 +{$ifdef VER220} + {$define D7UP} + {$define D10UP} + {$define D15UP} +{$endif} + +// Delphi XE2 / 16 +{$ifdef VER230} + {$define D7UP} + {$define D10UP} + {$define D15UP} +{$endif} + +// Delphi XE3 / 17 +{$ifdef VER240} + {$define D7UP} + {$define D10UP} + {$define D15UP} +{$endif} + +// Delphi XE4 / 18 +{$ifdef VER250} + {$define D7UP} + {$define D10UP} + {$define D15UP} +{$endif} + +// Delphi XE5 / 19 +{$ifdef VER260} + {$define D7UP} + {$define D10UP} + {$define D15UP} +{$endif} + + ADDED ZPreview/src/Delphi/F_AutoUpdate.dfm Index: ZPreview/src/Delphi/F_AutoUpdate.dfm ================================================================== --- /dev/null +++ ZPreview/src/Delphi/F_AutoUpdate.dfm @@ -0,0 +1,121 @@ +object frmAutoUpdate: TfrmAutoUpdate + Left = 0 + Top = 0 + Caption = 'Update' + ClientHeight = 448 + ClientWidth = 576 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + Position = poOwnerFormCenter + DesignSize = ( + 576 + 448) + PixelsPerInch = 96 + TextHeight = 13 + object lblVersions: TLabel + Left = 8 + Top = 8 + Width = 90 + Height = 13 + Caption = '&Available versions:' + end + object lvwVersions: TListView + Left = 8 + Top = 27 + Width = 560 + Height = 191 + Anchors = [akLeft, akTop, akRight] + Columns = < + item + Caption = 'Publication date' + Width = 100 + end + item + Caption = 'Author' + Width = 100 + end + item + Caption = 'Title' + Width = 100 + end> + ColumnClick = False + Groups = < + item + Header = 'Newer versions' + GroupID = 0 + State = [lgsNormal] + HeaderAlign = taLeftJustify + FooterAlign = taLeftJustify + TitleImage = -1 + end + item + Header = 'Old versions' + GroupID = 1 + State = [lgsNormal] + HeaderAlign = taLeftJustify + FooterAlign = taLeftJustify + TitleImage = -1 + end> + GroupView = True + ReadOnly = True + RowSelect = True + SortType = stData + TabOrder = 0 + ViewStyle = vsReport + OnCompare = lvwVersionsCompare + OnDblClick = lvwVersionsDblClick + OnSelectItem = lvwVersionsSelectItem + end + object mmoChanges: TMemo + Left = 8 + Top = 224 + Width = 560 + Height = 169 + Anchors = [akLeft, akTop, akRight, akBottom] + Color = clBtnFace + ReadOnly = True + ScrollBars = ssVertical + TabOrder = 1 + end + object btnInstall: TButton + Left = 338 + Top = 408 + Width = 112 + Height = 32 + Anchors = [akRight, akBottom] + Caption = '&Install' + Default = True + ElevationRequired = True + Enabled = False + ModalResult = 1 + TabOrder = 2 + OnClick = btnInstallClick + end + object btnCancel: TButton + Left = 456 + Top = 408 + Width = 112 + Height = 32 + Anchors = [akRight, akBottom] + Cancel = True + Caption = '&Cancel' + ModalResult = 2 + TabOrder = 3 + end + object btnWebpage: TButton + Left = 8 + Top = 408 + Width = 112 + Height = 32 + Anchors = [akLeft, akBottom] + Caption = '&View webpage' + Enabled = False + TabOrder = 4 + OnClick = btnWebpageClick + end +end ADDED ZPreview/src/Delphi/F_AutoUpdate.pas Index: ZPreview/src/Delphi/F_AutoUpdate.pas ================================================================== --- /dev/null +++ ZPreview/src/Delphi/F_AutoUpdate.pas @@ -0,0 +1,512 @@ +unit F_AutoUpdate; + +interface + +uses + System.SysUtils, System.Variants, System.Classes, System.Generics.Collections, + System.Zip, + Winapi.Windows, Winapi.Messages, + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, + NativeXml; + +type + TUpdateChecker = class; + + TfrmAutoUpdate = class(TForm) + lvwVersions: TListView; + mmoChanges: TMemo; + btnInstall: TButton; + btnCancel: TButton; + lblVersions: TLabel; + btnWebpage: TButton; + procedure lvwVersionsSelectItem(Sender: TObject; Item: TListItem; + Selected: Boolean); + procedure btnWebpageClick(Sender: TObject); + procedure lvwVersionsCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; + var Compare: Integer); + procedure btnInstallClick(Sender: TObject); + procedure lvwVersionsDblClick(Sender: TObject); + private + { Private declarations } + FUpdateChecker: TUpdateChecker; + + function UUIDFromItem(const Item: TListItem): string; + function UUIDFromNode(const xmlItem: TXmlNode): string; + public + { Public declarations } + procedure Populate(const UpdateChecker: TUpdateChecker); + end; + + TUpdateChecker = class + private + FBaseURL: string; + FTagName: string; + FXmlFeed: TNativeXml; + FVersions: TDictionary; + FForm: TfrmAutoUpdate; + + procedure LoadFeed; + function DownloadFromURL(const URL: string): TStream; + public + constructor Create(const BaseURL, BranchName: string); + destructor Destroy; override; + + function CheckForUpdate: boolean; + function AskUserForUpdate(out UUID: string): boolean; + procedure UpdateToVersion(const UUID: string); + + property BaseURL: string read FBaseURL; + property TagName: string read FTagName; + property XmlFeed: TNativeXml read FXmlFeed; + property Versions: TDictionary read FVersions; + end; + +implementation +uses + System.RegularExpressions, System.Types, System.IOUtils, System.UITypes, System.DateUtils, + Winapi.ShellAPI, Winapi.WinInet, + REST.Utils, + L_VersionInfoW; + +{$R *.dfm} + +{ ------------------------------------------------------------------------------------------------ } +// http://stackoverflow.com/a/8438985/3092116 +function LinkerTimestamp: TDateTime; overload; +begin + Result := PImageNtHeaders(HInstance + PImageDosHeader(HInstance)^._lfanew)^.FileHeader.TimeDateStamp / SecsPerDay + UnixDateDelta; +end {LinkerTimestamp}; + +{ ================================================================================================ } +{ TUpdateChecker } + +{ ------------------------------------------------------------------------------------------------ } +constructor TUpdateChecker.Create(const BaseURL, BranchName: string); +begin + inherited Create; + FBaseURL := BaseURL; + FTagName := BranchName; +end {TUpdateChecker.Create}; +{ ------------------------------------------------------------------------------------------------ } +destructor TUpdateChecker.Destroy; +begin + FForm.Free; + FVersions.Free; + FXmlFeed.Free; + inherited; +end {TUpdateChecker.Destroy}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TUpdateChecker.LoadFeed; +var + URL: string; +begin + if not Assigned(FXmlFeed) then begin + FVersions := TDictionary.Create; + + FXmlFeed := TNativeXml.Create(nil); + try + URL := FBaseURL + 'timeline.rss?y=ci'; + if FTagName <> '' then + URL := URL + '&tag=' + URIEncode(FTagName); +// URL := URL + '&name=' + ExtractFileName(Application.ExeName); // TODO: URLEncode; + + FXmlFeed.LoadFromURL(UTF8String(URL)); + except + FreeAndNil(FXmlFeed); + raise; + end; + end; +end {TUpdateChecker.LoadFeed}; + +{ ------------------------------------------------------------------------------------------------ } +function TUpdateChecker.CheckForUpdate: boolean; +var + en_US: TFormatSettings; + rexDateTime: TRegEx; + xmlChannel: TXmlNode; + xmlItems: TList; + i, mi: Integer; + xmlItem: TXmlNode; + sPubDate: string; + PubDate: TDateTime; + Match: TMatch; + Day, Month, Year: Integer; +begin + LoadFeed; + + rexDateTime := TRegEx.Create('(\d{1,2})\s+(\w{2,})\s+(\d{4})\s+(\d?\d:\d\d:\d\d)', [roCompiled]); + en_US := TFormatSettings.Create('en-US'); + + Result := False; + xmlChannel := FXmlFeed.Root.NodeByName('channel'); + xmlItems := TList.Create; + try + xmlChannel.NodesByName('item', xmlItems); + for i := 0 to xmlItems.Count - 1 do begin + xmlItem := TXmlNode(xmlItems[i]); + + // Parse the publication date. + sPubDate := xmlItem.ReadUnicodeString('pubDate'); + Match := rexDateTime.Match(sPubDate); + if Match.Success then begin + Day := StrToInt(Match.Groups[1].Value); + Month := 0; + for mi := Low(en_US.ShortMonthNames) to High(en_US.ShortMonthNames) do begin + if SameText(Match.Groups[2].Value, en_US.ShortMonthNames[mi]) then begin + Month := mi; + Break; + end; + end; + Year := StrToInt(Match.Groups[3].Value); + PubDate := EncodeDate(Year, Month, Day) + StrToTime(Match.Groups[4].Value, en_US); + end else begin + PubDate := StrToDateTime(sPubDate, en_US); + end; + + {--- MCO 25-02-2015: If it's more recent than our executable's date, then return true. ---} + {$MESSAGE HINT 'TODO: Better check for version would be to actually compare version numbers. — MCO 25-02-2015'} + if DateOf(PubDate) > DateOf(LinkerTimestamp) then begin + Result := True; + end; + + FVersions.Add(PubDate, xmlItem); + end; + finally + xmlItems.Free; + end; +end {TUpdateChecker.CheckForUpdate}; + +{ ------------------------------------------------------------------------------------------------ } +function TUpdateChecker.AskUserForUpdate(out UUID: string): boolean; +begin + UUID := ''; + + if (not Assigned(FVersions)) or (FVersions.Count = 0) then + CheckForUpdate; + + FForm := TfrmAutoUpdate.Create(Application); + try + // create form, populate list of versions, showmodal, and if the result + // is mrOK, fill UUID with the link of the selected item. + FForm.Populate(Self); + + Result := (FForm.ShowModal = mrOK); + if Result then begin + UUID := FForm.UUIDFromItem(FForm.lvwVersions.Selected); + end; + finally + FreeAndNil(FForm); + end; +end {TUpdateChecker.AskUserForUpdate}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TUpdateChecker.UpdateToVersion(const UUID: string); +var + ExeName, ExeVersion: string; + WorkPath, PathPrefix, BackupPrefix: string; + ZipStream: TStream; + Zip: TZipFile; + i: Integer; + FileName, PathName: string; + SI: TStartupInfo; + PI: TProcessInformation; +begin + ExeName := Application.ExeName; + with TFileVersionInfo.Create(ExeName) do begin + try + if HasVersionInfo then begin + ExeVersion := Format('%d.%d.%d.%d', [MajorVersion, MinorVersion, Revision, Build]); + end; + finally + Free; + end; + end; + + WorkPath := ExtractFilePath(ExeName); + BackupPrefix := '~'; + if ExeVersion <> '' then + BackupPrefix := BackupPrefix + ExeVersion; + + // download the zip from http://fossil.2of4.net/zaap/zip/zpreview.zip?uuid={UUID} + {$MESSAGE HINT 'Pass a routine to update the progress bar? — Martijn 2015-08-11'} + ZipStream := DownloadFromURL(FBaseURL + 'zip/' + URIEncode(FTagName) + '.zip?uuid=' + URIEncode(UUID)); + if not Assigned(ZipStream) then + raise Exception.Create('Failed to download release ' + UUID + '.'); + try + Zip := TZipFile.Create; + try + Zip.Open(ZipStream, zmRead); + + // extract each file, and try to rename an eventual existing file. + PathPrefix := FTagName + '/'; + for i := 0 to Zip.FileCount - 1 do begin + FileName := Zip.FileName[i]; + Assert(FileName.StartsWith(PathPrefix)); + FileName := FileName.Substring(PathPrefix.Length).Replace('/', PathDelim); + PathName := ExtractFilePath(FileName); + FileName := ExtractFileName(FileName); + if FileName <> '' then begin + if PathName <> '' then + ForceDirectories(WorkPath + PathName); + + // Test for existing file, and rename that + {$MESSAGE HINT 'TODO: Save all new files to temp files in the same dir, then afterwards, use ReplaceFile for each of them — MCO 25-02-2015'} + if FileExists(WorkPath + PathName + FileName) then begin + RenameFile(WorkPath + PathName + FileName, WorkPath + PathName + ChangeFileExt(FileName, BackupPrefix + ExtractFileExt(FileName))); + end; + + Zip.Extract(i, WorkPath + PathName, False); + + // adjust the new file's modified time + TFile.SetLastWriteTime(WorkPath + PathName + FileName, FileDateToDateTime(Zip.FileInfo[i].ModifiedDateTime)); + end; + end; + + // TODO: use transacted file operations, so we can roll them back if something fails? + finally + Zip.Free; + end; + finally + ZipStream.Free; + end; + + // Close the current instance... + Application.Tag := -1; // signal for the single-instance algorithm that we're shutting down + Application.OnException := nil; + Application.Terminate; + Application.MainForm.Close; + + // ...and start a new one + if not CreateProcess(nil, PChar(ExeName), nil, nil, True, 0, nil, nil, SI, PI) then + RaiseLastOSError; +end {TUpdateChecker.UpdateToVersion}; + +{ ------------------------------------------------------------------------------------------------ } +function TUpdateChecker.DownloadFromURL(const URL: string): TStream; +var + UserAgent: string; + NetHandle, UrlHandle: HINTERNET; + Buffer: array[0..$400 - 1] of AnsiChar; + BytesRead: cardinal; +begin + Result := nil; + + UserAgent := ChangeFileExt(ExtractFileName(Application.ExeName), '').Replace(' ', ''); + + NetHandle := InternetOpenW(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); + + if not assigned(NetHandle) then begin + // NetHandle is not valid. +// DoDebugOut(Self, wsFail, 'Unable to initialize WinInet'); + exit; + end; + + try + UrlHandle := InternetOpenUrlW(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0); + if not assigned(UrlHandle) then begin + // UrlHandle is not valid. +// DoDebugOut(Self, wsFail, format('Cannot open URL %s', [Url])); + exit; + end; + + // UrlHandle valid? Proceed with download + Result := TMemoryStream.Create; + FillChar(Buffer, SizeOf(Buffer), 0); + repeat + InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead); + if BytesRead > 0 then + Result.Write(Buffer, BytesRead); + until BytesRead = 0; + + InternetCloseHandle(UrlHandle); + + Result.Position := 0; + finally + InternetCloseHandle(NetHandle); + end; +end {TUpdateChecker.DownloadFromURL}; + + + + + +{ ================================================================================================ } +{ TfrmAutoUpdate } + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.Populate(const UpdateChecker: TUpdateChecker); +var + ExeModified, PubDate: TDateTime; + xmlItem: TXmlNode; + ListItem: TListItem; + Title: string; + Index: Integer; + DTI: TDateTimeInfoRec; + bNew: boolean; +begin + FUpdateChecker := UpdateChecker; + + if FileGetDateTimeInfo(Application.ExeName, DTI) then begin + ExeModified := DTI.TimeStamp; + end else begin + ExeModified := 0; + end; + + lvwVersions.Items.BeginUpdate; + try + lvwVersions.Items.Clear; + bNew := False; + for PubDate in UpdateChecker.Versions.Keys do begin + xmlItem := UpdateChecker.Versions.Items[PubDate]; + ListItem := lvwVersions.Items.Add; + ListItem.Data := xmlItem; + ListItem.Caption := DateTimeToStr(PubDate); + ListItem.SubItems.Add(xmlItem.ReadUnicodeString('dc:creator')); + + Title := xmlItem.ReadUnicodeString('title'); + Index := Pos(#10, Title); + if Index > 0 then + Title := Copy(Title, 1, Index - 1); + ListItem.SubItems.Add(Title); + + if PubDate <= ExeModified then begin + ListItem.GroupID := 1; // older versions + ListItem.StateIndex := 1; + end else begin + ListItem.GroupID := 0; // newer versions + ListItem.StateIndex := 0; + bNew := True; + end; + end; + for Index := 0 to lvwVersions.Columns.Count - 1 do + lvwVersions.Columns[Index].Width := -2; // autosize by content + headers + + if not bNew then begin + ListItem := lvwVersions.Items.Add; + ListItem.GroupID := 0; + ListItem.Caption := '(no newer versions)'; + ListItem.StateIndex := -1; + end; + + if lvwVersions.Items.Count > 0 then + lvwVersions.ItemIndex := 0; + finally + lvwVersions.Items.EndUpdate; + end; +end {TfrmAutoUpdate.Populate}; + +{ ------------------------------------------------------------------------------------------------ } +function TfrmAutoUpdate.UUIDFromItem(const Item: TListItem): string; +begin + if Assigned(Item) then + Result := UUIDFromNode(TXmlNode(Item.Data)); +end {TfrmAutoUpdate.UUIDFromItem}; + +{ ------------------------------------------------------------------------------------------------ } +function TfrmAutoUpdate.UUIDFromNode(const xmlItem: TXmlNode): string; +var + Match: TMatch; +begin + if Assigned(xmlItem) then begin + Result := xmlItem.ReadUnicodeString('guid'); + Match := TRegEx.Match(Result, '[0-9a-f]{10,}$', []); + if Match.Success then begin + Result := Match.Groups[0].Value; + end; + end; +end {TfrmAutoUpdate.UUIDFromNode}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.lvwVersionsCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; + var Compare: Integer); +var + D1, D2: TDateTime; +begin + if Item1.Data = nil then + D1 := 0 + else + D1 := StrToDateTime(Item1.Caption); + if Item2.Data = nil then + D2 := 0 + else + D2 := StrToDateTime(Item2.Caption); + if D1 = D2 then + Compare := 0 + else if D1 < D2 then + Compare := 1 + else + Compare := -1; +end {TfrmAutoUpdate.lvwVersionsCompare}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.lvwVersionsDblClick(Sender: TObject); +begin + if Assigned(lvwVersions.Selected) and btnInstall.Enabled then + btnInstall.Click; +end {TfrmAutoUpdate.lvwVersionsDblClick}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.lvwVersionsSelectItem(Sender: TObject; Item: TListItem; + Selected: Boolean); +var + xmlItem: TXmlNode; +begin + if Selected = False then begin + btnInstall.Enabled := False; + btnWebpage.Enabled := False; + mmoChanges.Clear; + end else begin + xmlItem := TXmlNode(Item.Data); + if Assigned(xmlItem) then begin + mmoChanges.Lines.Text := xmlItem.ReadUnicodeString('description', '(no description provided)'); + btnInstall.Enabled := True; + btnWebpage.Enabled := True; + end else begin + btnInstall.Enabled := False; + btnWebpage.Enabled := True; + end; + end; +end {TfrmAutoUpdate.lvwVersionsSelectItem}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.btnInstallClick(Sender: TObject); +begin + // Check if it's an older version + if lvwVersions.Selected.GroupID = 1 then begin + if TaskMessageDlg('Download and install an OLDER version?', + 'You will overwrite the current version of ZPreview with the following version:'#13#10 + + #13#10 + + lvwVersions.Selected.SubItems[1] + #13#10 + + #13#10 + + 'Are you certain you want to do this?', + mtWarning, mbYesNo, 0, mbNo) <> mrYes then begin + Self.ModalResult := mrNone; + end; + end; +end {TfrmAutoUpdate.btnInstallClick}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmAutoUpdate.btnWebpageClick(Sender: TObject); +var + UUID, URL: string; + xmlItem: TXmlNode; +begin + UUID := UUIDFromItem(lvwVersions.Selected); + if UUID <> '' then begin + URL := FUpdateChecker.BaseURL + 'dir?ci=' + URIEncode(UUID) + '&type=tree'; + end else if Assigned(lvwVersions.Selected) then begin + xmlItem := TXmlNode(lvwVersions.Selected.Data); + if Assigned(xmlItem) then begin + URL := xmlItem.ReadUnicodeString('link'); + end else begin + URL := FUpdateChecker.BaseURL + 'timeline?r=' + URIEncode(FUpdateChecker.TagName); + end; + end; + if URL <> '' then + ShellExecute(Handle, nil, PChar(URL), nil, nil, SW_SHOW); +end {TfrmAutoUpdate.btnWebpageClick}; + + + +end. Index: ZPreview/src/Delphi/F_Main.dfm ================================================================== --- ZPreview/src/Delphi/F_Main.dfm +++ ZPreview/src/Delphi/F_Main.dfm @@ -200,10 +200,17 @@ CommandProperties.ButtonType = btDropDown CommandProperties.TextAssociation = taDropdown end item Caption = '-' + end + item + Action = actHelpCheckForUpdates + Caption = '&Check for updates...' + ImageIndex = 22 + ShowCaption = False + ShortCut = 24661 end> ActionBar = acttbMain end item end> @@ -323,7 +330,17 @@ object actEngineManage: TAction Category = 'Engine' Caption = 'Manage...' OnExecute = actEngineManageExecute end + object actHelpCheckForUpdates: TAction + Category = 'Help' + Caption = 'Check for updates...' + Hint = + 'Check for updates|Check online to see if new versions of ZPrevie' + + 'w are available.' + ImageIndex = 22 + ShortCut = 24661 + OnExecute = actHelpCheckForUpdatesExecute + end end end Index: ZPreview/src/Delphi/F_Main.pas ================================================================== --- ZPreview/src/Delphi/F_Main.pas +++ ZPreview/src/Delphi/F_Main.pas @@ -31,10 +31,11 @@ actPreviewEngine: TAction; actEngineManage: TAction; actEngineAutoselect: TAction; actFileProperties: TAction; sbrMain: TStatusBar; + actHelpCheckForUpdates: TAction; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure ApplicationException(Sender: TObject; E: Exception); procedure actAutoRefreshExecute(Sender: TObject); @@ -53,10 +54,11 @@ procedure actFilePropertiesExecute(Sender: TObject); procedure EngineManagerRendererSelected(Sender: TObject); procedure sbrMainDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); procedure actEngineManageExecute(Sender: TObject); procedure ApplicationDeactivate(Sender: TObject); + procedure actHelpCheckForUpdatesExecute(Sender: TObject); private { Private declarations } // FWatcher: TThread; FInitialized: Boolean; FEngineManager: TPreviewEngineUIManager; @@ -77,11 +79,11 @@ uses System.IOUtils, System.Types, System.Masks, System.Generics.Defaults, Winapi.PsApi, Winapi.ShellAPI, Vcl.Imaging.GIFImg, Vcl.Imaging.jpeg, Vcl.Imaging.pngimage, U_ShellItemImage, - F_Sentinel, F_Info, F_ManageEnginesAndRenderers; + F_Sentinel, F_Info, F_ManageEnginesAndRenderers, F_AutoUpdate; {$R *.dfm} { ------------------------------------------------------------------------------------------------ } @@ -279,12 +281,10 @@ frmInfoSentinel.Populate(FSentinel); end {TfrmMain.actViewSentinelExecute}; { ------------------------------------------------------------------------------------------------ } procedure TfrmMain.actViewTopmostExecute(Sender: TObject); -var - i: integer; begin if actViewTopmost.Checked then begin Self.FormStyle := fsStayOnTop; ApplicationDeactivate(Application); end else begin @@ -367,10 +367,38 @@ end else if (Self.FormStyle = fsStayOnTop) and (Screen.MonitorCount = 1) then begin {$MESSAGE HINT 'TODO: Make this behaviour optional? — MCO 13-02-2015'} Self.WindowState := wsMinimized; end; end {TfrmMain.actFilePropertiesExecute}; + +{ ------------------------------------------------------------------------------------------------ } +procedure TfrmMain.actHelpCheckForUpdatesExecute(Sender: TObject); +var + UC: TUpdateChecker; + UUID: string; +begin + UC := TUpdateChecker.Create('http://fossil.2of4.net/zaap/', 'zpreview'); + try + if UC.CheckForUpdate or True then begin + Self.FormStyle := fsNormal; + try + if UC.AskUserForUpdate(UUID) then begin + UC.UpdateToVersion(UUID); + end; + finally + if actViewTopmost.Checked then + Self.FormStyle := fsStayOnTop; + end; + end else begin + MessageDlg('You are running the most recent version of ZPreview!', + mtInformation, + [mbOK], 0); + end; + finally + UC.Free; + end; +end {TfrmMain.actHelpCheckForUpdatesExecute}; { ------------------------------------------------------------------------------------------------ } procedure TfrmMain.actPreviewEngineExecute(Sender: TObject); begin FEngineManager.NextRenderer; Index: ZPreview/src/Delphi/M_Main.dfm ================================================================== --- ZPreview/src/Delphi/M_Main.dfm +++ ZPreview/src/Delphi/M_Main.dfm @@ -5,139 +5,139 @@ object imlMain: TImageList ColorDepth = cd32Bit Left = 115 Top = 118 Bitmap = { - 494C010116001900040010001000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 + 494C010117001900040010001000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000006000000001002000000000000060 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00040000000E0000001B0000002900000034000000340000002B0000001D0000 + 000F000000040000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00020C0C0C2E606664B27E8684E6919998F0919998F0868D8AF0595F5DDB2F33 + 3384000000040000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000002225 + 245E94A29FE7BDD1CDFFBDD1CDFFBDD1CDFFA3B4B0FF95A39EFFA5B6AEFFB1C1 + BAFF525B58BB0101010A00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000050505100C0C0C2900000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000011131354A5B4 + B2F9C9DAD8FFBACFCDFFB0C8C5FF99B3B0FB45514BD590936EFFB3A25FFFA79B + 5DFF808F80FF3A463FA000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000B0B0B22464646E1505050FF28282881000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000003333336C717B7BFC9EB0 + AFFF9DAFADFF9BADACFF98AAA9FE626B66EFB79944F8B58811FFC6A649FFBF94 + 22FFC7A23BFFA79A59FF2B2B2195000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000050505123131 319B1F1F1F650000000000000000000000000000000000000000000000000808 081B323232A11B1B1B5700000000000000000000000000000000000000000000 0000000000000808081D454545DC505050FF505050FF505050FF242424740000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000019191940D2D2D2F9DDDDDDFFD2D2 + D2FFD3D3D3FFC0C0C0FFA7A7A7FF989897FF9B7D31FFB88A11FFCDAD59FFBB90 + 1BFFC39B31FFC8A036FFCAA841FF7A6E3FC60000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000323232A25050 50FF505050FF25252578000000000000000000000000000000000808081D4646 46DB505050FF4F4F4FFC0A0A0A23000000000000000000000000000000000000 00000808081C454545DC505050FF505050FF505050FF505050FF505050FF2424 - 2473000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 247300000000000000000000000000000000747474B3DDDDDDFFD4D4D4FFA4A4 + A4C26868689BB6B5AFDFB3B3B3FFA0A0A0FF99917BFFC29827FFD0B15EFFB588 + 0FFFC1982BFFC59D33FFC8A139FFB29848F00000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000242424735050 50FF505050FF505050FF2626267C00000000000000000909091F474747DE5050 50FF505050FF474747E20404040F000000000000000000000000000000000909 0921464646E0505050FF505050FF454545DC2B2B2B8C505050FF505050FF5050 - 50FF292929800000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 50FF29292980000000000000000000000000979797D8D7D7D7FFDCDCDCFF5B5B + 5B8D0202021C6F6E64C8CCCCCAFFAEAEAEFF9E9B91FFCDA947FFDBC17CFFB78C + 1BFFB88B15FFC1982CFFC59D32FFAF9440F20000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000012F2F 2F97505050FF505050FF505050FF242424740808081D464646DB505050FF5050 50FF494949E80D0D0D2B000000000000000000000000000000000A0A0A204646 46E0505050FF505050FF454545DD0808081D000000002727277E505050FF5050 - 50FF505050FF2727277F00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 50FF505050FF2727277F00000000000000007A7A7AC8C3C3C3FFCCCCCCFF597E + 71D546484786A1A09AD6DCDCDCFFD0D0D0FFAFADA6FFE3DAA9FFD6C77BFFD6C0 + 73FFD3B86DFFBA8F1DFFC09628FFAE923EF40000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000029292984505050FF505050FF505050FF4C4C4CF1505050FF505050FF4646 46E00B0B0B220000000000000000000000000000000000000000353535A95050 50FF505050FF454545DD0909091E0000000000000000000000002727277E5050 - 50FF505050FF505050FF0B0B0B27000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 50FF505050FF505050FF0B0B0B27000000002C2C2C6FAAAAAAFF5D937DFF2BDE + 98FF37B380FD78A391FEC8C8C8FFD6D6D6FFB0AD96FFE0D197FFD5B866FFC8A1 + 37FFBB8D15FFC7A543FFC8A949FFAB903EF10000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000002B2B2B8C505050FF505050FF505050FF505050FF474747E30B0B 0B250000000000000000000000000000000000000000000000001D1D1D5D5050 50FE454545DD0909091E00000000000000000000000000000000000000002727 - 277E505050FF414141D002020209000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 277E505050FF414141D0020202090000000000000005486459D937CE8BFF29D9 + 87FF28D883FF28D57DFF3AA46BFF6D8F77FFCDC586FFD6C374FFDAC37AFFD5B6 + 61FFBF931CFFBA8C12FFBE982BFF665D3AB50000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000002B2B2B8A505050FF505050FF474747E20A0A0A240000 0000000000000000000000000000000000000000000000000000000000000B0B 0B25050505100000000000000000000000000000000000000000000000000000 - 00000C0C0C2A0303030B00000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 00000C0C0C2A0303030B0000000000000000030F0831369A67E96AE1A2FF38D7 + 81FF26D270FF25D06BFF23BE5EFE2E603BD794A076F7D9D493FFD8CC86FFCCB5 + 54FFCEB965FFA3A463FF3B5737C9000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000020202069323232A00808081C000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000103021D00010017348253C47CE1 + A2FF36D06CFF23CA59FF22C855FF0C4B1E9E070B073C678E58FABEC68EFF93AB + 6EFF5D995EFF62AE6BFF09170B59000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000020E052D6AC3 + 84F38EE1A4FF64D680FF3DCA5BFF1EAD39F8124B1BC62B9838FF2A9637FF2B98 + 38FF52AB5CFF19431DA500000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000C2A + 11616CBB7BEFA3E4ADFF9CE2A5FF8CDC93FF4FB157FF1A8125FF20952EFF2094 + 2EFF184E1FB90000000C00000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 0000020C022C3E7B41C45DA25FF45AA65CF757A459F729812DF60B4C10DF0524 + 0876000000020000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000002600000039000000390000003900000039000000390000 @@ -777,15 +777,15 @@ 00B0313100B1646204B7737204B97C7B05BA7E7C08BA777605BA3A3A00B10808 00B0110F00B02E2D018117170023000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 2800000040000000600000000100010000000000000300000000000000000000 - 000000000000000000000000FFFFFF00FFFFFFFF00000000FFFFFFFF00000000 - FFFFFFFF00000000FFFFFE7F00000000FFFFFC3F00000000C7E3F81F00000000 + 000000000000000000000000FFFFFF00FFFFFFFFE0070000FFFFFFFFE0070000 + FFFFFFFFE0030000FFFFFE7FC0030000FFFFFC3F80010000C7E3F81F00000000 C3C1F00F00000000C181E00700000000C003C08300000000F007C1C100000000 - F80FC3E100000000FC1FE7F300000000FE3FFFFF00000000FFFFFFFF00000000 - FFFFFFFF00000000FFFFFFFF00000000FFFFF800FF87F801FFFFFC00FF87F801 + F80FC3E100000000FC1FE7F300010000FE3FFFFF00010000FFFFFFFFC0030000 + FFFFFFFFE0030000FFFFFFFFF0070000FFFFF800FF87F801FFFFFC00FF87F801 000FFC00CFB7F801000F0000C3870001000F8000D1870001000F8000C01F0001 000F8000C01F0001000F8000E01F000100078000FE0F000100008000FF070001 00008000FF03000300008000FF230007C000C000FF31003FE000E01FFF39003F F000F01FFF3F003FFF30F81FFF3FE1FF801F8001C003800F800F8001DFFB8007 80078001DFFB800380038001DFFB800180018001DFFB800180018001DFFB8001 Index: ZPreview/src/Delphi/ZPreview.dproj ================================================================== --- ZPreview/src/Delphi/ZPreview.dproj +++ ZPreview/src/Delphi/ZPreview.dproj @@ -45,11 +45,11 @@ false 2 true true 1033 - ZAAP;FreeImage;Plugins;Common;$(DCC_UnitSearchPath) + ZAAP;FreeImage;Plugins;Common;Common\NativeXml;$(DCC_UnitSearchPath) ZPreview_Icon.ico System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) $(BDS)\bin\default_app.manifest ZPreview CompanyName=Martijn Coppoolse;FileDescription=ZTreeWin Preview Assistant Application;FileVersion=1.0.2.0;InternalName=ZPreview;LegalCopyright=;LegalTrademarks=;OriginalFilename=ZPreview.exe;ProductName=ZPreview;ProductVersion=1.0;Comments=http://fossil.2of4.net/zaap/ @@ -184,11 +184,11 @@ - + ZPreview.exe true @@ -196,11 +196,11 @@ ZPreview.exe true - + ZPreview.exe true