diff --git a/components/codetools/examples/TestNewXMLCfg.lpr b/components/codetools/examples/TestNewXMLCfg.lpr index 553e748b9c..c366dcc62b 100644 --- a/components/codetools/examples/TestNewXMLCfg.lpr +++ b/components/codetools/examples/TestNewXMLCfg.lpr @@ -103,16 +103,13 @@ procedure TMyApplication.Test1; var Filename: String; begin - - // write with old Filename:='test1.xml'; - Test(Filename,true,true); + Test(Filename,true,true); // write with old Test(Filename,true,false); // read old with old Test(Filename,false,false); // read old with new - // write with new Filename:='test2.xml'; - Test(Filename,false,true); + Test(Filename,false,true); // write with new Test(Filename,false,false); // read new with new Test(Filename,true,false); // read new with old end; diff --git a/components/lazutils/laz2_xmlread.pas b/components/lazutils/laz2_xmlread.pas index 4a7cf4da4f..8ecb97e53e 100644 --- a/components/lazutils/laz2_xmlread.pas +++ b/components/lazutils/laz2_xmlread.pas @@ -30,7 +30,7 @@ unit laz2_XMLRead; interface uses - SysUtils, Classes, laz2_DOM; + SysUtils, Classes, laz2_DOM, lazutf8classes; type TErrorSeverity = (esWarning, esError, esFatal); @@ -60,18 +60,21 @@ type procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String; Flags: TXMLReaderFlags = []); overload; procedure ReadXMLFile(out ADoc: TXMLDocument; var f: Text; Flags: TXMLReaderFlags = []); overload; +procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File; Flags: TXMLReaderFlags = []); overload; procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; Flags: TXMLReaderFlags = []); overload; procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload; procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String; Flags: TXMLReaderFlags = []); overload; procedure ReadXMLFragment(AParentNode: TDOMNode; var f: Text; Flags: TXMLReaderFlags = []); overload; -procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; Flags: TXMLReaderFlags = []); overload; -procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload; +procedure ReadXMLFragment(AParentNode: TDOMNode; var f: File; Flags: TXMLReaderFlags = []); overload; +procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; Flags: TXMLReaderFlags = []); overload; +procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags = []); overload; procedure ReadDTDFile(out ADoc: TXMLDocument; const AFilename: String); overload; procedure ReadDTDFile(out ADoc: TXMLDocument; var f: Text); overload; -procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream); overload; -procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream; const ABaseURI: String); overload; +procedure ReadDTDFile(out ADoc: TXMLDocument; var f: File); overload; +procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream); overload; +procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String); overload; type TDOMParseOptions = class(TObject) @@ -4136,6 +4139,29 @@ begin end; end; +procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File; + Flags: TXMLReaderFlags); +var + BufSize: Int64; + ms: TMemoryStream; +begin + ADoc := nil; + BufSize := FileSize(f) + 1; + if BufSize <= 1 then + exit; + + ms:=TMemoryStream.Create; + try + ms.Size:=BufSize; + BlockRead(f, ms.Memory^, BufSize - 1); + PChar(ms.Memory)[BufSize - 1] := #0; + ms.Position:=0; + ReadXMLFile(ADoc,ms,Flags); + finally + ms.Free; + end; +end; + procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; Flags: TXMLReaderFlags); begin ReadXMLFile(ADoc, f, 'stream:', Flags); @@ -4147,7 +4173,7 @@ var FileStream: TStream; begin ADoc := nil; - FileStream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite); + FileStream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite); try ReadXMLFile(ADoc, FileStream, FilenameToURI(AFilename), Flags); finally @@ -4171,7 +4197,7 @@ begin end; end; -procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; +procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; const ABaseURI: String; Flags: TXMLReaderFlags); var Reader: TXMLReader; @@ -4188,7 +4214,29 @@ begin end; end; -procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; +procedure ReadXMLFragment(AParentNode: TDOMNode; var f: File; + Flags: TXMLReaderFlags); +var + BufSize: Int64; + ms: TMemoryStream; +begin + BufSize := FileSize(f) + 1; + if BufSize <= 1 then + exit; + + ms:=TMemoryStream.Create; + try + ms.Size:=BufSize; + BlockRead(f, ms.Memory^, BufSize - 1); + PChar(ms.Memory)[BufSize - 1] := #0; + ms.Position:=0; + ReadXMLFragment(AParentNode,ms,'stream:',Flags); + finally + ms.Free; + end; +end; + +procedure ReadXMLFragment(AParentNode: TDOMNode; f: TStream; Flags: TXMLReaderFlags); begin ReadXMLFragment(AParentNode, f, 'stream:', Flags); @@ -4199,7 +4247,7 @@ procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String; var Stream: TStream; begin - Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite); + Stream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite); try ReadXMLFragment(AParentNode, Stream, FilenameToURI(AFilename), Flags); finally @@ -4224,7 +4272,7 @@ begin end; end; -procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream; const ABaseURI: String); +procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream; const ABaseURI: String); var Reader: TXMLReader; Src: TXMLCharSource; @@ -4241,7 +4289,29 @@ begin end; end; -procedure ReadDTDFile(out ADoc: TXMLDocument; var f: TStream); +procedure ReadDTDFile(out ADoc: TXMLDocument; var f: File); +var + BufSize: Int64; + ms: TMemoryStream; +begin + ADoc := nil; + BufSize := FileSize(f) + 1; + if BufSize <= 1 then + exit; + + ms:=TMemoryStream.Create; + try + ms.Size:=BufSize; + BlockRead(f, ms.Memory^, BufSize - 1); + PChar(ms.Memory)[BufSize - 1] := #0; + ms.Position:=0; + ReadDTDFile(ADoc,ms,'stream:'); + finally + ms.Free; + end; +end; + +procedure ReadDTDFile(out ADoc: TXMLDocument; f: TStream); begin ReadDTDFile(ADoc, f, 'stream:'); end; @@ -4251,7 +4321,7 @@ var Stream: TStream; begin ADoc := nil; - Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead+fmShareDenyWrite); + Stream := TFileStreamUTF8.Create(AFilename, fmOpenRead+fmShareDenyWrite); try ReadDTDFile(ADoc, Stream, FilenameToURI(AFilename)); finally diff --git a/components/lazutils/laz2_xmlwrite.pas b/components/lazutils/laz2_xmlwrite.pas index b74cd3fb29..62e85b529e 100644 --- a/components/lazutils/laz2_xmlwrite.pas +++ b/components/lazutils/laz2_xmlwrite.pas @@ -27,7 +27,7 @@ unit laz2_XMLWrite; interface -uses Classes, laz2_DOM, SysUtils, laz2_xmlutils; +uses Classes, laz2_DOM, SysUtils, laz2_xmlutils, lazutf8classes; type TXMLWriterFlag = ( @@ -868,9 +868,9 @@ end; procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String; Flags: TXMLWriterFlags = []); var - fs: TFileStream; + fs: TFileStreamUTF8; begin - fs := TFileStream.Create(UTF8ToSys(AFileName), fmCreate); + fs := TFileStreamUTF8.Create(AFileName, fmCreate); try WriteXMLFile(doc, fs, Flags); finally diff --git a/components/lazutils/laz_dom.pas b/components/lazutils/laz_dom.pas index 82e5d9e38e..67cdd8671b 100644 --- a/components/lazutils/laz_dom.pas +++ b/components/lazutils/laz_dom.pas @@ -1,1686 +1,38 @@ -{ - This file is part of the Free Component Library - - Implementation of DOM interfaces - Copyright (c) 1999-2000 by Sebastian Guenther, sg@freepascal.org - - See the file COPYING.modifiedLGPL.txt, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - -{ - This unit provides classes which implement the interfaces defined in the - DOM (Document Object Model) specification. - The current state is: - DOM Level 1 - Almost completely implemented - DOM Level 2 - Partially implemented - - - Specification used for this implementation: - - "Document Object Model (DOM) Level 2 Specification Version 1.0 - W3C Candidate Recommendation 07 March, 2000" - http://www.w3.org/TR/2000/CR-DOM-Level-2-20000307 -} - - unit Laz_DOM; -{$MODE objfpc} -{$H+} +{$MODE objfpc}{$H+} interface -{off $DEFINE MEM_CHECK} - uses - {$IFDEF MEM_CHECK}MemCheck,{$ENDIF} - SysUtils, Classes, Avl_Tree; - + SysUtils, Classes, laz2_DOM; type - TDOMImplementation = class; - TDOMDocumentFragment = class; - TDOMDocument = class; - TDOMNode = class; - TDOMNodeList = class; - TDOMNamedNodeMap = class; - TDOMCharacterData = class; - TDOMAttr = class; - TDOMElement = class; - TDOMText = class; - TDOMComment = class; - TDOMCDATASection = class; - TDOMDocumentType = class; - TDOMNotation = class; - TDOMEntity = class; - TDOMEntityReference = class; - TDOMProcessingInstruction = class; - - -// ------------------------------------------------------- -// DOMString -// ------------------------------------------------------- - DOMString = String; - DOMPChar = PChar; -// DOMString = WideString; -// DOMPChar = PWideChar; - - -// ------------------------------------------------------- -// DOMException -// ------------------------------------------------------- - - -const - - // DOM Level 1 exception codes: - - INDEX_SIZE_ERR = 1; // index or size is negative, or greater than the allowed value - DOMSTRING_SIZE_ERR = 2; // Specified range of text does not fit into a DOMString - HIERARCHY_REQUEST_ERR = 3; // node is inserted somewhere it does not belong - WRONG_DOCUMENT_ERR = 4; // node is used in a different document than the one that created it (that does not support it) - INVALID_CHARACTER_ERR = 5; // invalid or illegal character is specified, such as in a name - NO_DATA_ALLOWED_ERR = 6; // data is specified for a node which does not support data - NO_MODIFICATION_ALLOWED_ERR = 7; // an attempt is made to modify an object where modifications are not allowed - NOT_FOUND_ERR = 8; // an attempt is made to reference a node in a context where it does not exist - NOT_SUPPORTED_ERR = 9; // implementation does not support the type of object requested - INUSE_ATTRIBUTE_ERR = 10; // an attempt is made to add an attribute that is already in use elsewhere - - // DOM Level 2 exception codes: - - INVALID_STATE_ERR = 11; // an attempt is made to use an object that is not, or is no longer, usable - SYNTAX_ERR = 12; // invalid or illegal string specified - INVALID_MODIFICATION_ERR = 13; // an attempt is made to modify the type of the underlying object - NAMESPACE_ERR = 14; // an attempt is made to create or change an object in a way which is incorrect with regard to namespaces - INVALID_ACCESS_ERR = 15; // parameter or operation is not supported by the underlying object - - -type - - EDOMError = class(Exception) - public - Code: Integer; - constructor Create(ACode: Integer; const ASituation: String); - end; - - EDOMIndexSize = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMHierarchyRequest = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMWrongDocument = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMNotFound = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMNotSupported = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMInUseAttribute = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMInvalidState = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMSyntax = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMInvalidModification = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMNamespace = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - EDOMInvalidAccess = class(EDOMError) - public - constructor Create(const ASituation: String); - end; - - -// ------------------------------------------------------- -// Node -// ------------------------------------------------------- - -const - - ELEMENT_NODE = 1; - ATTRIBUTE_NODE = 2; - TEXT_NODE = 3; - CDATA_SECTION_NODE = 4; - ENTITY_REFERENCE_NODE = 5; - ENTITY_NODE = 6; - PROCESSING_INSTRUCTION_NODE = 7; - COMMENT_NODE = 8; - DOCUMENT_NODE = 9; - DOCUMENT_TYPE_NODE = 10; - DOCUMENT_FRAGMENT_NODE = 11; - NOTATION_NODE = 12; - - -type - - TRefClass = class - protected - RefCounter: LongInt; - public - constructor Create; - function AddRef: LongInt; virtual; - function Release: LongInt; virtual; - end; - - { TDOMNode } - - TDOMNode = class - protected - FNodeName, FNodeValue: DOMString; - FNodeType: Integer; - FParentNode: TDOMNode; - FPreviousSibling, FNextSibling: TDOMNode; - FOwnerDocument: TDOMDocument; - - function GetNodeValue: DOMString; virtual; - procedure SetNodeValue(const AValue: DOMString); virtual; - function GetFirstChild: TDOMNode; virtual; - function GetLastChild: TDOMNode; virtual; - function GetAttributes: TDOMNamedNodeMap; virtual; - - public - constructor Create(AOwner: TDOMDocument); - - // Free NodeList with TDOMNodeList.Release! - function GetChildNodes: TDOMNodeList; virtual; - - property NodeName: DOMString read FNodeName; - property NodeValue: DOMString read GetNodeValue write SetNodeValue; - property NodeType: Integer read FNodeType; - property ParentNode: TDOMNode read FParentNode; - property FirstChild: TDOMNode read GetFirstChild; - property LastChild: TDOMNode read GetLastChild; - property ChildNodes: TDOMNodeList read GetChildNodes; - property PreviousSibling: TDOMNode read FPreviousSibling; - property NextSibling: TDOMNode read FNextSibling; - property Attributes: TDOMNamedNodeMap read GetAttributes; - property OwnerDocument: TDOMDocument read FOwnerDocument; - - function InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; virtual; - function ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; virtual; - function RemoveChild(OldChild: TDOMNode): TDOMNode; virtual; - function AppendChild(NewChild: TDOMNode): TDOMNode; virtual; - function HasChildNodes: Boolean; virtual; - function CloneNode(deep: Boolean): TDOMNode; overload; - function IsEmpty: Boolean; virtual; - - // Extensions to DOM interface: - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual; - function FindNode(const ANodeName: DOMString): TDOMNode; virtual; - end; - - - { The following class is an implementation specific extension, it is just an - extended implementation of TDOMNode, the generic DOM::Node interface - implementation. (Its main purpose is to save memory in a big node tree) } - - TDOMNode_WithChildren = class(TDOMNode) - protected - FFirstChild, FLastChild: TDOMNode; - FChildNodeTree: TAVLTree;// tree of TDOMNode sorted for Name (=> there can be doubles) - function GetFirstChild: TDOMNode; override; - function GetLastChild: TDOMNode; override; - procedure CloneChildren(ACopy: TDOMNode; ACloneOwner: TDOMDocument); - procedure AddToChildNodeTree(NewNode: TDOMNode); - procedure RemoveFromChildNodeTree(OldNode: TDOMNode); - public - destructor Destroy; override; - function InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; override; - function ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; override; - function RemoveChild(OldChild: TDOMNode): TDOMNode; override; - function AppendChild(NewChild: TDOMNode): TDOMNode; override; - function HasChildNodes: Boolean; override; - function FindNode(const ANodeName: DOMString): TDOMNode; override; - end; - - -// ------------------------------------------------------- -// NodeList -// ------------------------------------------------------- - - TDOMNodeList = class(TRefClass) - protected - node: TDOMNode; - filter: DOMString; - UseFilter: Boolean; - function GetCount: LongInt; - function GetItem(index: LongWord): TDOMNode; - public - constructor Create(ANode: TDOMNode; const AFilter: DOMString); - property Item[index: LongWord]: TDOMNode read GetItem; - property Count: LongInt read GetCount; - end; - - -// ------------------------------------------------------- -// NamedNodeMap -// ------------------------------------------------------- - - TDOMNamedNodeMap = class(TFPList) - protected - OwnerDocument: TDOMDocument; - function GetItem(index: LongWord): TDOMNode; - procedure SetItem(index: LongWord; AItem: TDOMNode); - function GetLength: LongInt; - public - constructor Create(AOwner: TDOMDocument); - - function GetNamedItem(const name: DOMString): TDOMNode; - function SetNamedItem(arg: TDOMNode): TDOMNode; - function RemoveNamedItem(const name: DOMString): TDOMNode; - property Item[index: LongWord]: TDOMNode read GetItem write SetItem; default; - property Length: LongInt read GetLength; - end; - - -// ------------------------------------------------------- -// CharacterData -// ------------------------------------------------------- - - TDOMCharacterData = class(TDOMNode) - protected - function GetLength: LongInt; - public - property Data: DOMString read FNodeValue; - property Length: LongInt read GetLength; - function SubstringData(offset, count: LongWord): DOMString; - procedure AppendData(const arg: DOMString); - procedure InsertData(offset: LongWord; const arg: DOMString); - procedure DeleteData(offset, count: LongWord); - procedure ReplaceData(offset, count: LongWord; const arg: DOMString); - end; - - -// ------------------------------------------------------- -// DOMImplementation -// ------------------------------------------------------- - - TDOMImplementation = class - public - function HasFeature(const feature, version: DOMString): Boolean; - - // Introduced in DOM Level 2: - - function CreateDocumentType(const QualifiedName, PublicID, - SystemID: DOMString): TDOMDocumentType; - function CreateDocument(const NamespaceURI, QualifiedName: DOMString; - doctype: TDOMDocumentType): TDOMDocument; - end; - - -// ------------------------------------------------------- -// DocumentFragment -// ------------------------------------------------------- - - TDOMDocumentFragment = class(TDOMNode_WithChildren) - public - constructor Create(AOwner: TDOMDocument); - end; - - -// ------------------------------------------------------- -// Document -// ------------------------------------------------------- - - TDOMDocument = class(TDOMNode_WithChildren) - protected - FDocType: TDOMDocumentType; - FImplementation: TDOMImplementation; - function GetDocumentElement: TDOMElement; - public - property DocType: TDOMDocumentType read FDocType; - property Impl: TDOMImplementation read FImplementation; - property DocumentElement: TDOMElement read GetDocumentElement; - - function CreateElement(const tagName: DOMString): TDOMElement; virtual; - function CreateDocumentFragment: TDOMDocumentFragment; - function CreateTextNode(const data: DOMString): TDOMText; - function CreateComment(const data: DOMString): TDOMComment; - function CreateCDATASection(const data: DOMString): TDOMCDATASection; - virtual; - function CreateProcessingInstruction(const target, data: DOMString): - TDOMProcessingInstruction; virtual; - function CreateAttribute(const name: DOMString): TDOMAttr; virtual; - function CreateEntityReference(const name: DOMString): TDOMEntityReference; - virtual; - // Free NodeList with TDOMNodeList.Release! - function GetElementsByTagName(const tagname: DOMString): TDOMNodeList; - - // Extensions to DOM interface: - constructor Create; - function CreateEntity(const data: DOMString): TDOMEntity; - end; - - TXMLDocument = class(TDOMDocument) - public - // These fields are extensions to the DOM interface: - XMLVersion, Encoding, StylesheetType, StylesheetHRef: DOMString; - - function CreateCDATASection(const data: DOMString): TDOMCDATASection; override; - function CreateProcessingInstruction(const target, data: DOMString): - TDOMProcessingInstruction; override; - function CreateEntityReference(const name: DOMString): TDOMEntityReference; override; - end; - - -// ------------------------------------------------------- -// Attr -// ------------------------------------------------------- - - TDOMAttr = class(TDOMNode_WithChildren) - protected - FSpecified: Boolean; - AttrOwner: TDOMNamedNodeMap; - function GetNodeValue: DOMString; override; - procedure SetNodeValue(const AValue: DOMString); override; - public - constructor Create(AOwner: TDOMDocument); - - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - property Name: DOMString read FNodeName; - property Specified: Boolean read FSpecified; - property Value: DOMString read GetNodeValue write SetNodeValue; - end; - - -// ------------------------------------------------------- -// Element -// ------------------------------------------------------- - - { TDOMElement } - - TDOMElement = class(TDOMNode_WithChildren) - private - FAttributes: TDOMNamedNodeMap; - protected - function GetAttributes: TDOMNamedNodeMap; override; - public - constructor Create(AOwner: TDOMDocument); - destructor Destroy; override; - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - property TagName: DOMString read FNodeName; - function GetAttribute(const name: DOMString): DOMString; - procedure SetAttribute(const name, value: DOMString); - procedure RemoveAttribute(const name: DOMString); - function GetAttributeNode(const name: DOMString): TDOMAttr; - procedure SetAttributeNode(NewAttr: TDOMAttr); - function RemoveAttributeNode(OldAttr: TDOMAttr): TDOMAttr; - // Free NodeList with TDOMNodeList.Release! - function GetElementsByTagName(const name: DOMString): TDOMNodeList; - function IsEmpty: Boolean; override; - procedure Normalize; - - property AttribStrings[const Name: DOMString]: DOMString - read GetAttribute write SetAttribute; default; - end; - - -// ------------------------------------------------------- -// Text -// ------------------------------------------------------- - - TDOMText = class(TDOMCharacterData) - public - constructor Create(AOwner: TDOMDocument); - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - function SplitText(offset: LongWord): TDOMText; - end; - - -// ------------------------------------------------------- -// Comment -// ------------------------------------------------------- - - TDOMComment = class(TDOMCharacterData) - public - constructor Create(AOwner: TDOMDocument); - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - end; - - -// ------------------------------------------------------- -// CDATASection -// ------------------------------------------------------- - - TDOMCDATASection = class(TDOMText) - public - constructor Create(AOwner: TDOMDocument); - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - end; - - -// ------------------------------------------------------- -// DocumentType -// ------------------------------------------------------- - - TDOMDocumentType = class(TDOMNode) - protected - FEntities, FNotations: TDOMNamedNodeMap; - public - constructor Create(AOwner: TDOMDocument); - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - property Name: DOMString read FNodeName; - property Entities: TDOMNamedNodeMap read FEntities; - property Notations: TDOMNamedNodeMap read FEntities; - end; - - -// ------------------------------------------------------- -// Notation -// ------------------------------------------------------- - - TDOMNotation = class(TDOMNode) - protected - FPublicID, FSystemID: DOMString; - public - constructor Create(AOwner: TDOMDocument); - function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override; - property PublicID: DOMString read FPublicID; - property SystemID: DOMString read FSystemID; - end; - - -// ------------------------------------------------------- -// Entity -// ------------------------------------------------------- - - TDOMEntity = class(TDOMNode_WithChildren) - protected - FPublicID, FSystemID, FNotationName: DOMString; - public - constructor Create(AOwner: TDOMDocument); - property PublicID: DOMString read FPublicID; - property SystemID: DOMString read FSystemID; - property NotationName: DOMString read FNotationName; - end; - - -// ------------------------------------------------------- -// EntityReference -// ------------------------------------------------------- - - TDOMEntityReference = class(TDOMNode_WithChildren) - public - constructor Create(AOwner: TDOMDocument); - end; - - -// ------------------------------------------------------- -// ProcessingInstruction -// ------------------------------------------------------- - - TDOMProcessingInstruction = class(TDOMNode) - public - constructor Create(AOwner: TDOMDocument); - property Target: DOMString read FNodeName; - property Data: DOMString read FNodeValue; - end; - - - - -// ======================================================= -// ======================================================= + TDOMImplementation = laz2_DOM.TDOMImplementation; + TDOMDocumentFragment = laz2_DOM.TDOMDocumentFragment; + TDOMDocument = laz2_DOM.TDOMDocument; + TDOMNode = laz2_DOM.TDOMNode; + TDOMNodeList = laz2_DOM.TDOMNodeList; + TDOMNamedNodeMap = laz2_DOM.TDOMNamedNodeMap; + TDOMCharacterData = laz2_DOM.TDOMCharacterData; + TDOMAttr = laz2_DOM.TDOMAttr; + TDOMElement = laz2_DOM.TDOMElement; + TDOMText = laz2_DOM.TDOMText; + TDOMComment = laz2_DOM.TDOMComment; + TDOMCDATASection = laz2_DOM.TDOMCDATASection; + TDOMDocumentType = laz2_DOM.TDOMDocumentType; + TDOMNotation = laz2_DOM.TDOMNotation; + TDOMEntity = laz2_DOM.TDOMEntity; + TDOMEntityReference = laz2_DOM.TDOMEntityReference; + TDOMProcessingInstruction = laz2_DOM.TDOMProcessingInstruction; + + DOMString = laz2_DOM.DOMString; + DOMPChar = laz2_DOM.DOMPChar; + + EDOMError = laz2_DOM.EDOMError; implementation - -constructor TRefClass.Create; -begin - inherited Create; - RefCounter := 1; -end; - -function TRefClass.AddRef: LongInt; -begin - Inc(RefCounter); - Result := RefCounter; -end; - -function TRefClass.Release: LongInt; -begin - Dec(RefCounter); - Result := RefCounter; - if RefCounter <= 0 then Free; -end; - - -// ------------------------------------------------------- -// DOM Exception -// ------------------------------------------------------- - -constructor EDOMError.Create(ACode: Integer; const ASituation: String); -begin - Code := ACode; - inherited Create(Self.ClassName + ' in ' + ASituation); -end; - -constructor EDOMIndexSize.Create(const ASituation: String); // 1 -begin - inherited Create(INDEX_SIZE_ERR, ASituation); -end; - -constructor EDOMHierarchyRequest.Create(const ASituation: String); // 3 -begin - inherited Create(HIERARCHY_REQUEST_ERR, ASituation); -end; - -constructor EDOMWrongDocument.Create(const ASituation: String); // 4 -begin - inherited Create(WRONG_DOCUMENT_ERR, ASituation); -end; - -constructor EDOMNotFound.Create(const ASituation: String); // 8 -begin - inherited Create(NOT_FOUND_ERR, ASituation); -end; - -constructor EDOMNotSupported.Create(const ASituation: String); // 9 -begin - inherited Create(NOT_SUPPORTED_ERR, ASituation); -end; - -constructor EDOMInUseAttribute.Create(const ASituation: String); // 10 -begin - inherited Create(INUSE_ATTRIBUTE_ERR, ASituation); -end; - -constructor EDOMInvalidState.Create(const ASituation: String); // 11 -begin - inherited Create(INVALID_STATE_ERR, ASituation); -end; - -constructor EDOMSyntax.Create(const ASituation: String); // 12 -begin - inherited Create(SYNTAX_ERR, ASituation); -end; - -constructor EDOMInvalidModification.Create(const ASituation: String); // 13 -begin - inherited Create(INVALID_MODIFICATION_ERR, ASituation); -end; - -constructor EDOMNamespace.Create(const ASituation: String); // 14 -begin - inherited Create(NAMESPACE_ERR, ASituation); -end; - -constructor EDOMInvalidAccess.Create(const ASituation: String); // 15 -begin - inherited Create(INVALID_ACCESS_ERR, ASituation); -end; - - -// ------------------------------------------------------- -// Node -// ------------------------------------------------------- - -constructor TDOMNode.Create(AOwner: TDOMDocument); -begin - FOwnerDocument := AOwner; - inherited Create; -end; - -function TDOMNode.GetNodeValue: DOMString; -begin - Result := FNodeValue; -end; - -procedure TDOMNode.SetNodeValue(const AValue: DOMString); -begin - FNodeValue := AValue; -end; - -function TDOMNode.GetChildNodes: TDOMNodeList; -begin - Result := TDOMNodeList.Create(Self, '*'); -end; - -function TDOMNode.GetFirstChild: TDOMNode; -begin - Result := nil; -end; - -function TDOMNode.GetLastChild: TDOMNode; -begin - Result := nil; -end; - -function TDOMNode.GetAttributes: TDOMNamedNodeMap; -begin - Result := nil; -end; - -function TDOMNode.InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; -begin - raise EDOMHierarchyRequest.Create('Node.InsertBefore'); - if (NewChild=nil) and (RefChild=nil) then ; - Result:=nil; -end; - -function TDOMNode.ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; -begin - raise EDOMHierarchyRequest.Create('Node.ReplaceChild'); - if (NewChild=nil) and (OldChild=nil) then ; - Result:=nil; -end; - -function TDOMNode.RemoveChild(OldChild: TDOMNode): TDOMNode; -begin - raise EDOMHierarchyRequest.Create('Node.RemoveChild'); - if (OldChild=nil) then ; - Result:=nil; -end; - -function TDOMNode.AppendChild(NewChild: TDOMNode): TDOMNode; -begin - raise EDOMHierarchyRequest.Create('Node.AppendChild'); - if (NewChild=nil) then ; - Result:=nil; -end; - -function TDOMNode.HasChildNodes: Boolean; -begin - Result := False; -end; - -function TDOMNode.CloneNode(deep: Boolean): TDOMNode; -begin - if deep then ; - Result:=CloneNode(deep, FOwnerDocument); -end; - -function TDOMNode.IsEmpty: Boolean; -begin - Result:=true; -end; - -function TDOMNode.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - raise EDOMNotSupported.Create('CloneNode not implemented for ' + ClassName); - if (deep) and (ACloneOwner=nil) then ; - Result:=nil; -end; - -function TDOMNode.FindNode(const ANodeName: DOMString): TDOMNode; -var - child: TDOMNode; -begin - child := FirstChild; - while Assigned(child) do - begin - if child.NodeName = ANodeName then - begin - Result := child; - exit; - end; - child := child.NextSibling; - end; - Result := nil; -end; - -//------------------------------------------------------------------------------ - -function CompareDOMStrings(const s1, s2: DOMPChar; l1, l2: integer): integer; -var i: integer; -begin - Result:=l1-l2; - i:=0; - while (inil then begin - FChildNodeTree.Free; - FChildNodeTree:=nil; - end; - child := FirstChild; - while Assigned(child) do - begin - next := child.NextSibling; - child.Free; - child := next; - end; - inherited Destroy; -end; - -function TDOMNode_WithChildren.InsertBefore(NewChild, RefChild: TDOMNode): - TDOMNode; -begin - Result := NewChild; - - if not Assigned(RefChild) then - begin - AppendChild(NewChild); - exit; - end; - - if NewChild.FOwnerDocument <> FOwnerDocument then - raise EDOMWrongDocument.Create('NodeWC.InsertBefore'); - - if RefChild.ParentNode <> Self then - raise EDOMHierarchyRequest.Create('NodeWC.InsertBefore'); - - if NewChild.NodeType = DOCUMENT_FRAGMENT_NODE then - raise EDOMNotSupported.Create('NodeWC.InsertBefore for DocumentFragment'); - - NewChild.FNextSibling := RefChild; - if RefChild = FFirstChild then - FFirstChild := NewChild - else - begin - RefChild.FPreviousSibling.FNextSibling := NewChild; - NewChild.FPreviousSibling := RefChild.FPreviousSibling; - end; - - RefChild.FPreviousSibling := NewChild; - NewChild.FParentNode := Self; - AddToChildNodeTree(NewChild); -end; - -function TDOMNode_WithChildren.ReplaceChild(NewChild, OldChild: TDOMNode): - TDOMNode; -begin - InsertBefore(NewChild, OldChild); - if Assigned(OldChild) then - RemoveChild(OldChild); - Result := NewChild; -end; - -function TDOMNode_WithChildren.RemoveChild(OldChild: TDOMNode): - TDOMNode; -begin - if OldChild.ParentNode <> Self then - raise EDOMHierarchyRequest.Create('NodeWC.RemoveChild'); - - if OldChild = FFirstChild then - FFirstChild := FFirstChild.NextSibling - else - OldChild.FPreviousSibling.FNextSibling := OldChild.FNextSibling; - - if OldChild = FLastChild then - FLastChild := FLastChild.FPreviousSibling - else - OldChild.FNextSibling.FPreviousSibling := OldChild.FPreviousSibling; - - RemoveFromChildNodeTree(OldChild); - OldChild.Free; - Result:=nil; -end; - -function TDOMNode_WithChildren.AppendChild(NewChild: TDOMNode): TDOMNode; -var - Parent: TDOMNode; -begin - //writeln('TDOMNode_WithChildren.AppendChild ',NodeName,' NewChild=',NewChild.NodeName); - if NewChild.FOwnerDocument <> FOwnerDocument then - raise EDOMWrongDocument.Create('NodeWC.AppendChild'); - - Parent := Self; - while Assigned(Parent) do - begin - if Parent = NewChild then - raise EDOMHierarchyRequest.Create('NodeWC.AppendChild (cycle in tree)'); - Parent := Parent.ParentNode; - end; - - if NewChild.FParentNode<>nil then begin - //writeln('TDOMNode_WithChildren.AppendChild old NewChild.FParentNode=',NewChild.FParentNode.NodeName); - NewChild.FParentNode.RemoveChild(NewChild); - end; - - if NewChild.NodeType = DOCUMENT_FRAGMENT_NODE then - raise EDOMNotSupported.Create('NodeWC.AppendChild for DocumentFragments') - else begin - if Assigned(FFirstChild) then - begin - FLastChild.FNextSibling := NewChild; - NewChild.FPreviousSibling := FLastChild; - end else - FFirstChild := NewChild; - FLastChild := NewChild; - NewChild.FParentNode := Self; - end; - AddToChildNodeTree(NewChild); - Result := NewChild; -end; - -function TDOMNode_WithChildren.HasChildNodes: Boolean; -begin - Result := Assigned(FFirstChild); -end; - -function TDOMNode_WithChildren.FindNode(const ANodeName: DOMString): TDOMNode; -var - AVLNode: TAVLTreeNode; -begin - Result:=nil; - if FChildNodeTree<>nil then begin - // use tree for fast search - //if FChildNodeTree.ConsistencyCheck<>0 then - // raise exception.Create('TDOMNode_WithChildren.FindNode'); - AVLNode:=FChildNodeTree.FindKey(DOMPChar(Pointer(ANodeName)), - @CompareDOMStringWithDOMNode); - if AVLNode<>nil then - Result:=TDOMNode(AVLNode.Data); - end else begin - // search in list - Result := FirstChild; - while Assigned(Result) do begin - if CompareDOMStringWithDOMNode(DOMPChar(Pointer(ANodeName)),Result)=0 - then exit; - Result := Result.NextSibling; - end; - end; -end; - -procedure TDOMNode_WithChildren.CloneChildren(ACopy: TDOMNode; - ACloneOwner: TDOMDocument); -var - node: TDOMNode; -begin - node := FirstChild; - while Assigned(node) do - begin - ACopy.AppendChild(node.CloneNode(True, ACloneOwner)); - node := node.NextSibling; - end; -end; - -procedure TDOMNode_WithChildren.AddToChildNodeTree(NewNode: TDOMNode); -var - ChildCount: Integer; - ANode: TDOMNode; - NewNodeAdded: Boolean; -begin - if (FChildNodeTree=nil) then begin - // there is no childnodetree yet - // Most xml trees contains nodes with only a few child nodes. It would be - // overhead to create a tree for only a few children. - ChildCount := 0; - ANode := FirstChild; - while Assigned(ANode) do begin - inc(ChildCount); - ANode := ANode.NextSibling; - end; - if ChildCount>5 then begin - FChildNodeTree:=TAVLTree.Create(@CompareDOMNodeWithDOMNode); - // add all existing children - ANode := FirstChild; - NewNodeAdded:=false; - while Assigned(ANode) do begin - if ANode=NewNode then NewNodeAdded:=true; - FChildNodeTree.Add(ANode); - ANode := ANode.NextSibling; - end; - if not NewNodeAdded then - FChildNodeTree.Add(NewNode); - end; - end else begin - {if (FChildNodeTree.Find(NewNode)<>nil) then begin - writeln('TDOMNode_WithChildren.AddToChildNodeTree adding same value ',NewNOde.NodeName); - CTDumpStack; - end;} - FChildNodeTree.Add(NewNode); - end; - //if FChildNodeTree.ConsistencyCheck<>0 then - // raise exception.Create('TDOMNode_WithChildren.FindNode'); -end; - -procedure TDOMNode_WithChildren.RemoveFromChildNodeTree(OldNode: TDOMNode); -begin - if FChildNodeTree<>nil then - FChildNodeTree.RemovePointer(OldNode);// doubles are allowed, so Remove can not be used - //if (FChildNodeTree<>nil) and (FChildNodeTree.ConsistencyCheck<>0) then - // raise exception.Create('TDOMNode_WithChildren.FindNode'); -end; - - -// ------------------------------------------------------- -// NodeList -// ------------------------------------------------------- - -constructor TDOMNodeList.Create(ANode: TDOMNode; const AFilter: DOMString); -begin - inherited Create; - node := ANode; - filter := AFilter; - UseFilter := filter <> '*'; -end; - -function TDOMNodeList.GetCount: LongInt; -var - child: TDOMNode; -begin - Result := 0; - child := node.FirstChild; - while Assigned(child) do - begin - if (not UseFilter) or (child.NodeName = filter) then - Inc(Result); - child := child.NextSibling; - end; -end; - -function TDOMNodeList.GetItem(index: LongWord): TDOMNode; -var - child: TDOMNode; -begin - Result := nil; - child := node.FirstChild; - while Assigned(child) do - begin - if index = 0 then - begin - Result := child; - break; - end; - if (not UseFilter) or (child.NodeName = filter) then - Dec(index); - child := child.NextSibling; - end; -end; - - -// ------------------------------------------------------- -// NamedNodeMap -// ------------------------------------------------------- - -constructor TDOMNamedNodeMap.Create(AOwner: TDOMDocument); -begin - inherited Create; - OwnerDocument := AOwner; -end; - -function TDOMNamedNodeMap.GetItem(index: LongWord): TDOMNode; -begin - Result := TDOMNode(Items[index]); -end; - -procedure TDOMNamedNodeMap.SetItem(index: LongWord; AItem: TDOMNode); -begin - Items[index] := AItem; -end; - -function TDOMNamedNodeMap.GetLength: LongInt; -begin - Result := Count; -end; - -function TDOMNamedNodeMap.GetNamedItem(const name: DOMString): TDOMNode; -var - i: Integer; -begin - for i := 0 to Count - 1 do - begin - Result := Item[i]; - if Result.NodeName = name then - exit; - end; - Result := nil; -end; - -function TDOMNamedNodeMap.SetNamedItem(arg: TDOMNode): TDOMNode; -var - i: Integer; -begin - if arg.FOwnerDocument <> OwnerDocument then - raise EDOMWrongDocument.Create('NamedNodeMap.SetNamedItem'); - - if arg.NodeType = ATTRIBUTE_NODE then - begin - if Assigned(TDOMAttr(arg).AttrOwner) then - raise EDOMInUseAttribute.Create('NamedNodeMap.SetNamedItem'); - TDOMAttr(arg).AttrOwner := Self; - end; - - for i := 0 to Count - 1 do - if Item[i].NodeName = arg.NodeName then - begin - Result := Item[i]; - Item[i] := arg; - exit; - end; - Add(arg); - Result := nil; -end; - -function TDOMNamedNodeMap.RemoveNamedItem(const name: DOMString): TDOMNode; -var - i: Integer; -begin - for i := 0 to Count - 1 do - if Item[i].NodeName = name then - begin - Result := Item[i]; - Result.FParentNode := nil; - exit; - end; - raise EDOMNotFound.Create('NamedNodeMap.RemoveNamedItem'); -end; - - -// ------------------------------------------------------- -// CharacterData -// ------------------------------------------------------- - -function TDOMCharacterData.GetLength: LongInt; -begin - Result := system.Length(FNodeValue); -end; - -function TDOMCharacterData.SubstringData(offset, count: LongWord): DOMString; -begin - if (longint(offset) > Length) then - raise EDOMIndexSize.Create('CharacterData.SubstringData'); - Result := Copy(FNodeValue, offset + 1, count); -end; - -procedure TDOMCharacterData.AppendData(const arg: DOMString); -begin - FNodeValue := FNodeValue + arg; -end; - -procedure TDOMCharacterData.InsertData(offset: LongWord; const arg: DOMString); -begin - if (longint(offset) > Length) then - raise EDOMIndexSize.Create('CharacterData.InsertData'); - - FNodeValue := Copy(FNodeValue, 1, offset) + arg + - Copy(FNodeValue, offset + 1, Length); -end; - -procedure TDOMCharacterData.DeleteData(offset, count: LongWord); -begin - if (longint(offset) > Length) then - raise EDOMIndexSize.Create('CharacterData.DeleteData'); - - FNodeValue := Copy(FNodeValue, 1, offset) + - Copy(FNodeValue, offset + count + 1, Length); -end; - -procedure TDOMCharacterData.ReplaceData(offset, count: LongWord; const arg: DOMString); -begin - DeleteData(offset, count); - InsertData(offset, arg); -end; - - -// ------------------------------------------------------- -// DocumentFragmet -// ------------------------------------------------------- - -constructor TDOMDocumentFragment.Create(AOwner: TDOMDocument); -begin - FNodeType := DOCUMENT_FRAGMENT_NODE; - FNodeName := '#document-fragment'; - inherited Create(AOwner); -end; - - -// ------------------------------------------------------- -// DOMImplementation -// ------------------------------------------------------- - -function TDOMImplementation.HasFeature(const feature, version: DOMString): - Boolean; -begin - Result := False; - if (feature='') and (version='') then ; -end; - -function TDOMImplementation.CreateDocumentType(const QualifiedName, PublicID, - SystemID: DOMString): TDOMDocumentType; -begin - // !!!: Implement this method (easy to do) - raise EDOMNotSupported.Create('DOMImplementation.CreateDocumentType'); - if (QualifiedName='') and (PublicID='') and (SystemID='') then ; - Result:=nil; -end; - -function TDOMImplementation.CreateDocument(const NamespaceURI, - QualifiedName: DOMString; doctype: TDOMDocumentType): TDOMDocument; -begin - // !!!: Implement this method (easy to do) - raise EDOMNotSupported.Create('DOMImplementation.CreateDocument'); - if (NamespaceURI='') and (QualifiedName='') and (doctype=nil) then ; - Result:=nil; -end; - - -// ------------------------------------------------------- -// Document -// ------------------------------------------------------- - -constructor TDOMDocument.Create; -begin - FNodeType := DOCUMENT_NODE; - FNodeName := '#document'; - inherited Create(nil); - FOwnerDocument := Self; -end; - -function TDOMDocument.GetDocumentElement: TDOMElement; -var - node: TDOMNode; -begin - node := FFirstChild; - while Assigned(node) do - begin - if node.FNodeType = ELEMENT_NODE then - begin - Result := TDOMElement(node); - exit; - end; - node := node.NextSibling; - end; - Result := nil; -end; - -function TDOMDocument.CreateElement(const tagName: DOMString): TDOMElement; -begin - Result := TDOMElement.Create(Self); - Result.FNodeName := tagName; -end; - -function TDOMDocument.CreateDocumentFragment: TDOMDocumentFragment; -begin - Result := TDOMDocumentFragment.Create(Self); -end; - -function TDOMDocument.CreateTextNode(const data: DOMString): TDOMText; -begin - Result := TDOMText.Create(Self); - Result.FNodeValue := data; -end; - -function TDOMDocument.CreateComment(const data: DOMString): TDOMComment; -begin - Result := TDOMComment.Create(Self); - Result.FNodeValue := data; -end; - -function TDOMDocument.CreateCDATASection(const data: DOMString): - TDOMCDATASection; -begin - raise EDOMNotSupported.Create('DOMDocument.CreateCDATASection'); - if data='' then ; - Result:=nil; -end; - -function TDOMDocument.CreateProcessingInstruction(const target, - data: DOMString): TDOMProcessingInstruction; -begin - raise EDOMNotSupported.Create('DOMDocument.CreateProcessingInstruction'); - if (target='') and (data='') then ; - Result:=nil; -end; - -function TDOMDocument.CreateAttribute(const name: DOMString): TDOMAttr; -begin - Result := TDOMAttr.Create(Self); - Result.FNodeName := name; -end; - -function TDOMDocument.CreateEntityReference(const name: DOMString): - TDOMEntityReference; -begin - raise EDOMNotSupported.Create('DOMDocument.CreateEntityReference'); - if name='' then ; - Result:=nil; -end; - -function TDOMDocument.CreateEntity(const data: DOMString): TDOMEntity; -begin - Result := TDOMEntity.Create(Self); - Result.FNodeName := data; -end; - -function TDOMDocument.GetElementsByTagName(const tagname: DOMString): TDOMNodeList; -begin - Result := TDOMNodeList.Create(Self, tagname); -end; - - -function TXMLDocument.CreateCDATASection(const data: DOMString): - TDOMCDATASection; -begin - Result := TDOMCDATASection.Create(Self); - Result.FNodeValue := data; -end; - -function TXMLDocument.CreateProcessingInstruction(const target, - data: DOMString): TDOMProcessingInstruction; -begin - Result := TDOMProcessingInstruction.Create(Self); - Result.FNodeName := target; - Result.FNodeValue := data; -end; - -function TXMLDocument.CreateEntityReference(const name: DOMString): - TDOMEntityReference; -begin - Result := TDOMEntityReference.Create(Self); - Result.FNodeName := name; -end; - - -// ------------------------------------------------------- -// Attr -// ------------------------------------------------------- - -constructor TDOMAttr.Create(AOwner: TDOMDocument); -begin - FNodeType := ATTRIBUTE_NODE; - inherited Create(AOwner); -end; - -function TDOMAttr.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMAttr.Create(ACloneOwner); - Result.FNodeName := FNodeName; - TDOMAttr(Result).FSpecified := FSpecified; - if deep then - CloneChildren(Result, ACloneOwner); -end; - -function TDOMAttr.GetNodeValue: DOMString; -var - child: TDOMNode; -begin - SetLength(Result, 0); - if Assigned(FFirstChild) then - begin - child := FFirstChild; - while Assigned(child) do - begin - if child.NodeType = ENTITY_REFERENCE_NODE then - Result := Result + '&' + child.NodeName + ';' - else - Result := Result + child.NodeValue; - child := child.NextSibling; - end; - end; -end; - -procedure TDOMAttr.SetNodeValue(const AValue: DOMString); -var - tn: TDOMText; -begin - FSpecified := True; - tn := TDOMText.Create(FOwnerDocument); - tn.FNodeValue := AValue; - if Assigned(FFirstChild) then - ReplaceChild(tn, FFirstChild) - else - AppendChild(tn); -end; - - -// ------------------------------------------------------- -// Element -// ------------------------------------------------------- - -constructor TDOMElement.Create(AOwner: TDOMDocument); -begin - FNodeType := ELEMENT_NODE; - inherited Create(AOwner); -end; - -destructor TDOMElement.Destroy; -var - i: Integer; -begin - {As the attributes are _not_ children of the element node, we have to free - them manually here:} - if FAttributes<>nil then begin - for i := 0 to FAttributes.Count - 1 do - FAttributes[i].Free; - FAttributes.Free; - FAttributes:=nil; - end; - inherited Destroy; -end; - -function TDOMElement.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -var - i: Integer; -begin - Result := TDOMElement.Create(ACloneOwner); - Result.FNodeName := FNodeName; - if FAttributes<>nil then begin - TDOMElement(Result).GetAttributes; - for i := 0 to FAttributes.Count - 1 do - TDOMElement(Result).FAttributes.Add(FAttributes[i].CloneNode(True, ACloneOwner)); - end; - if deep then - CloneChildren(Result, ACloneOwner); -end; - -function TDOMElement.GetAttributes: TDOMNamedNodeMap; -begin - if FAttributes=nil then - FAttributes := TDOMNamedNodeMap.Create(FOwnerDocument); - Result := FAttributes; -end; - -function TDOMElement.GetAttribute(const name: DOMString): DOMString; -var - i: Integer; -begin - if FAttributes<>nil then begin - for i := 0 to FAttributes.Count - 1 do - if FAttributes[i].NodeName = name then - begin - Result := FAttributes[i].NodeValue; - exit; - end; - end; - SetLength(Result, 0); -end; - -procedure TDOMElement.SetAttribute(const name, value: DOMString); -var - i: Integer; - attr: TDOMAttr; -begin - GetAttributes; - for i := 0 to FAttributes.Count - 1 do - if FAttributes[i].NodeName = name then - begin - FAttributes[i].NodeValue := value; - exit; - end; - attr := TDOMAttr.Create(FOwnerDocument); - attr.FNodeName := name; - attr.NodeValue := value; - FAttributes.Add(attr); -end; - -procedure TDOMElement.RemoveAttribute(const name: DOMString); -var - i: Integer; -begin - if FAttributes=nil then exit; - for i := 0 to FAttributes.Count - 1 do - if FAttributes[i].NodeName = name then - begin - FAttributes[i].Free; - FAttributes.Delete(i); - exit; - end; -end; - -function TDOMElement.GetAttributeNode(const name: DOMString): TDOMAttr; -var - i: Integer; -begin - if FAttributes<>nil then begin - for i := 0 to FAttributes.Count - 1 do - if FAttributes[i].NodeName = name then - begin - Result := TDOMAttr(FAttributes[i]); - exit; - end; - end; - Result := nil; -end; - -procedure TDOMElement.SetAttributeNode(NewAttr: TDOMAttr); -var - i: Integer; -begin - if FAttributes=nil then exit; - for i := 0 to FAttributes.Count - 1 do - if FAttributes[i].NodeName = NewAttr.NodeName then - begin - FAttributes[i].Free; - FAttributes[i] := NewAttr; - exit; - end; -end; - -function TDOMElement.RemoveAttributeNode(OldAttr: TDOMAttr): TDOMAttr; -var - i: Integer; - node: TDOMNode; -begin - Result:=nil; - if FAttributes=nil then exit; - for i := 0 to FAttributes.Count - 1 do - begin - node := FAttributes[i]; - if node = OldAttr then - begin - FAttributes.Delete(i); - Result := TDOMAttr(node); - exit; - end; - end; -end; - -function TDOMElement.GetElementsByTagName(const name: DOMString): TDOMNodeList; -begin - Result := TDOMNodeList.Create(Self, name); -end; - -function TDOMElement.IsEmpty: Boolean; -begin - Result:=(FAttributes=nil) or (FAttributes.Count=0) -end; - -procedure TDOMElement.Normalize; -begin - // !!!: Not implemented -end; - - -// ------------------------------------------------------- -// Text -// ------------------------------------------------------- - -constructor TDOMText.Create(AOwner: TDOMDocument); -begin - FNodeType := TEXT_NODE; - FNodeName := '#text'; - inherited Create(AOwner); -end; - -function TDOMText.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMText.Create(ACloneOwner); - Result.FNodeValue := FNodeValue; - if deep and (ACloneOwner=nil) then ; -end; - -function TDOMText.SplitText(offset: LongWord): TDOMText; -begin - if longint(offset) > Length then - raise EDOMIndexSize.Create('Text.SplitText'); - - Result := TDOMText.Create(FOwnerDocument); - Result.FNodeValue := Copy(FNodeValue, offset + 1, Length); - FNodeValue := Copy(FNodeValue, 1, offset); - FParentNode.InsertBefore(Result, FNextSibling); -end; - - -// ------------------------------------------------------- -// Comment -// ------------------------------------------------------- - -constructor TDOMComment.Create(AOwner: TDOMDocument); -begin - FNodeType := COMMENT_NODE; - FNodeName := '#comment'; - inherited Create(AOwner); -end; - -function TDOMComment.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMComment.Create(ACloneOwner); - Result.FNodeValue := FNodeValue; - if deep and (ACloneOwner=nil) then ; -end; - - -// ------------------------------------------------------- -// CDATASection -// ------------------------------------------------------- - -constructor TDOMCDATASection.Create(AOwner: TDOMDocument); -begin - inherited Create(AOwner); - FNodeType := CDATA_SECTION_NODE; - FNodeName := '#cdata-section'; -end; - -function TDOMCDATASection.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMCDATASection.Create(ACloneOwner); - Result.FNodeValue := FNodeValue; - if deep and (ACloneOwner=nil) then ; -end; - - -// ------------------------------------------------------- -// DocumentType -// ------------------------------------------------------- - -constructor TDOMDocumentType.Create(AOwner: TDOMDocument); -begin - FNodeType := DOCUMENT_TYPE_NODE; - inherited Create(AOwner); -end; - -function TDOMDocumentType.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMDocumentType.Create(ACloneOwner); - Result.FNodeName := FNodeName; - if deep and (ACloneOwner=nil) then ; -end; - - -// ------------------------------------------------------- -// Notation -// ------------------------------------------------------- - -constructor TDOMNotation.Create(AOwner: TDOMDocument); -begin - FNodeType := NOTATION_NODE; - inherited Create(AOwner); -end; - -function TDOMNotation.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; -begin - Result := TDOMNotation.Create(ACloneOwner); - Result.FNodeName := FNodeName; - if deep and (ACloneOwner=nil) then ; -end; - - -// ------------------------------------------------------- -// Entity -// ------------------------------------------------------- - -constructor TDOMEntity.Create(AOwner: TDOMDocument); -begin - FNodeType := ENTITY_NODE; - inherited Create(AOwner); -end; - - -// ------------------------------------------------------- -// EntityReference -// ------------------------------------------------------- - -constructor TDOMEntityReference.Create(AOwner: TDOMDocument); -begin - FNodeType := ENTITY_REFERENCE_NODE; - inherited Create(AOwner); -end; - - -// ------------------------------------------------------- -// ProcessingInstruction -// ------------------------------------------------------- - -constructor TDOMProcessingInstruction.Create(AOwner: TDOMDocument); -begin - FNodeType := PROCESSING_INSTRUCTION_NODE; - inherited Create(AOwner); -end; - - end. diff --git a/components/lazutils/laz_xmlcfg.pas b/components/lazutils/laz_xmlcfg.pas index b177b54320..5974741827 100644 --- a/components/lazutils/laz_xmlcfg.pas +++ b/components/lazutils/laz_xmlcfg.pas @@ -26,903 +26,13 @@ unit Laz_XMLCfg; interface -{off $DEFINE MEM_CHECK} - -{off $DEFINE OldXMLCfg} - uses - {$IFDEF MEM_CHECK}MemCheck,{$ENDIF} - Classes, sysutils, LazFileCache, - {$IFNDEF OldXMLCfg} - Laz2_DOM, Laz2_XMLRead, Laz2_XMLWrite, - {$ELSE} - Laz_DOM, Laz_XMLRead, Laz_XMLWrite, - {$ENDIF} - typinfo; + Classes, sysutils, Laz2_XMLCfg; type - - {"APath" is the path and name of a value: A XML configuration file is - hierachical. "/" is the path delimiter, the part after the last "/" - is the name of the value. The path components will be mapped to XML - elements, the name will be an element attribute.} - - { TXMLConfig } - - TXMLConfig = class(TComponent) - private - FFilename: String; - {$IFNDEF OldXMLCfg} - FReadFlags: TXMLReaderFlags; - FWriteFlags: TXMLWriterFlags; - {$ENDIF} - procedure SetFilename(const AFilename: String); - protected - doc: TXMLDocument; - FModified: Boolean; - fDoNotLoadFromFile: boolean; - fAutoLoadFromSource: string; - fPathCache: string; - fPathNodeCache: array of TDomNode; // starting with doc.DocumentElement, then first child node of first sub path - procedure Loaded; override; - function ExtendedToStr(const e: extended): string; - function StrToExtended(const s: string; const ADefault: extended): extended; - procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); virtual; - procedure WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); virtual; - procedure FreeDoc; virtual; - procedure SetPathNodeCache(Index: integer; Node: TDomNode); - function GetPathNodeCache(Index: integer): TDomNode; - procedure InvalidateCacheTilEnd(StartIndex: integer); - function InternalFindNode(const APath: String; PathLen: integer; - CreateNodes: boolean = false): TDomNode; - procedure InternalCleanNode(Node: TDomNode); - public - constructor Create(AOwner: TComponent); override; - constructor Create(const AFilename: String); overload; // create and load - constructor CreateClean(const AFilename: String); // create new - constructor CreateWithSource(const AFilename, Source: String); // create new and load from Source - destructor Destroy; override; - procedure Clear; - procedure Flush; // Writes the XML file - procedure ReadFromStream(s: TStream); - procedure WriteToStream(s: TStream); - - function GetValue(const APath, ADefault: String): String; - function GetValue(const APath: String; ADefault: Integer): Integer; - function GetValue(const APath: String; ADefault: Boolean): Boolean; - function GetExtendedValue(const APath: String; - const ADefault: extended): extended; - procedure SetValue(const APath, AValue: String); - procedure SetDeleteValue(const APath, AValue, DefValue: String); - procedure SetValue(const APath: String; AValue: Integer); - procedure SetDeleteValue(const APath: String; AValue, DefValue: Integer); - procedure SetValue(const APath: String; AValue: Boolean); - procedure SetDeleteValue(const APath: String; AValue, DefValue: Boolean); - procedure SetExtendedValue(const APath: String; const AValue: extended); - procedure SetDeleteExtendedValue(const APath: String; - const AValue, DefValue: extended); - procedure DeletePath(const APath: string); - procedure DeleteValue(const APath: string); - function FindNode(const APath: String; PathHasValue: boolean): TDomNode; - function HasPath(const APath: string; PathHasValue: boolean): boolean; // checks if the path has values, set PathHasValue=true to skip the last part - function HasChildPaths(const APath: string): boolean; - property Modified: Boolean read FModified write FModified; - procedure InvalidatePathCache; - published - property Filename: String read FFilename write SetFilename; - property Document: TXMLDocument read doc; - {$IFNDEF OldXMLCfg} - property ReadFlags: TXMLReaderFlags read FReadFlags write FReadFlags; - property WriteFlags: TXMLWriterFlags read FWriteFlags write FWriteFlags; - {$ENDIF} - end; - - { TRttiXMLConfig } - - TRttiXMLConfig = class(TXMLConfig) - protected - procedure WriteProperty(Path: String; Instance: TPersistent; - PropInfo: Pointer; DefInstance: TPersistent = nil; - OnlyProperty: String= ''); - procedure ReadProperty(Path: String; Instance: TPersistent; - PropInfo: Pointer; DefInstance: TPersistent = nil; - OnlyProperty: String= ''); - public - procedure WriteObject(Path: String; Obj: TPersistent; - DefObject: TPersistent= nil; OnlyProperty: String= ''); - procedure ReadObject(Path: String; Obj: TPersistent; - DefObject: TPersistent= nil; OnlyProperty: String= ''); - end; - - -// =================================================================== + TXMLConfig = Laz2_XMLCfg.TXMLConfig; + TRttiXMLConfig = Laz2_XMLCfg.TRttiXMLConfig; implementation -constructor TXMLConfig.Create(AOwner: TComponent); -begin - {$IFNDEF OldXMLCfg} - // for compatibility with old TXMLConfig, which wrote #13 as #13, not as &xD; - FReadFlags:=[xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue]; - // for compatibility with old TXMLConfig, which can not read &xD;, but needs #13 - FWriteFlags:=[xwfSpecialCharsInAttributeValue]; - {$ENDIF} - inherited Create(AOwner); -end; - -constructor TXMLConfig.Create(const AFilename: String); -begin - Create(nil); - SetFilename(AFilename); -end; - -constructor TXMLConfig.CreateClean(const AFilename: String); -begin - //DebugLn(['TXMLConfig.CreateClean ',AFilename]); - fDoNotLoadFromFile:=true; - Create(AFilename); - FModified:=FileExistsCached(AFilename); -end; - -constructor TXMLConfig.CreateWithSource(const AFilename, Source: String); -begin - fAutoLoadFromSource:=Source; - try - CreateClean(AFilename); - finally - fAutoLoadFromSource:=''; - end; -end; - -destructor TXMLConfig.Destroy; -begin - if Assigned(doc) then - begin - Flush; - FreeDoc; - end; - inherited Destroy; -end; - -procedure TXMLConfig.Clear; -var - cfg: TDOMElement; -begin - // free old document - FreeDoc; - // create new document - doc := TXMLDocument.Create; - cfg :=TDOMElement(doc.FindNode('CONFIG')); - if not Assigned(cfg) then begin - cfg := doc.CreateElement('CONFIG'); - doc.AppendChild(cfg); - end; -end; - -procedure TXMLConfig.Flush; -begin - if Modified and (Filename<>'') then - begin - //DebugLn(['TXMLConfig.Flush ',Filename]); - {$IFNDEF OldXMLCfg} - Laz2_XMLWrite.WriteXMLFile(Doc,Filename,WriteFlags); - {$ELSE} - Laz_XMLWrite.WriteXMLFile(Doc,Filename); - {$ENDIF} - InvalidateFileStateCache; - FModified := False; - end; -end; - -procedure TXMLConfig.ReadFromStream(s: TStream); -begin - FreeDoc; - {$IFNDEF OldXMLCfg} - Laz2_XMLRead.ReadXMLFile(Doc,s,ReadFlags); - {$ELSE} - Laz_XMLRead.ReadXMLFile(Doc,s); - {$ENDIF} - if Doc=nil then - Clear; -end; - -procedure TXMLConfig.WriteToStream(s: TStream); -begin - {$IFNDEF OldXMLCfg} - Laz2_XMLWrite.WriteXMLFile(Doc,s,WriteFlags); - {$ELSE} - Laz_XMLWrite.WriteXMLFile(Doc,s); - {$ENDIF} -end; - -function TXMLConfig.GetValue(const APath, ADefault: String): String; -var - Node, Attr: TDOMNode; - NodeName: String; - StartPos: integer; -begin - //CheckHeapWrtMemCnt('TXMLConfig.GetValue A '+APath); - Result:=ADefault; - - StartPos:=length(APath)+1; - while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos); - if StartPos>length(APath) then exit; - Node:=InternalFindNode(APath,StartPos-1); - if Node=nil then - exit; - //CheckHeapWrtMemCnt('TXMLConfig.GetValue E'); - NodeName:=copy(APath,StartPos,length(APath)); - //CheckHeapWrtMemCnt('TXMLConfig.GetValue G'); - Attr := Node.Attributes.GetNamedItem(NodeName); - if Assigned(Attr) then - Result := Attr.NodeValue; - //writeln('TXMLConfig.GetValue END Result="',Result,'"'); -end; - -function TXMLConfig.GetValue(const APath: String; ADefault: Integer): Integer; -begin - Result := StrToIntDef(GetValue(APath, IntToStr(ADefault)),ADefault); -end; - -function TXMLConfig.GetValue(const APath: String; ADefault: Boolean): Boolean; -var - s: String; -begin - if ADefault then - s := 'True' - else - s := 'False'; - - s := GetValue(APath, s); - - if CompareText(s,'TRUE')=0 then - Result := True - else if CompareText(s,'FALSE')=0 then - Result := False - else - Result := ADefault; -end; - -function TXMLConfig.GetExtendedValue(const APath: String; - const ADefault: extended): extended; -begin - Result:=StrToExtended(GetValue(APath,ExtendedToStr(ADefault)),ADefault); -end; - -procedure TXMLConfig.SetValue(const APath, AValue: String); -var - Node: TDOMNode; - NodeName: String; - StartPos: integer; -begin - StartPos:=length(APath)+1; - while (StartPos>1) and (APath[StartPos-1]<>'/') do dec(StartPos); - if StartPos>length(APath) then exit; - Node:=InternalFindNode(APath,StartPos-1,true); - if Node=nil then - exit; - NodeName:=copy(APath,StartPos,length(APath)); - if (not Assigned(TDOMElement(Node).GetAttributeNode(NodeName))) or - (TDOMElement(Node)[NodeName] <> AValue) then - begin - TDOMElement(Node)[NodeName] := AValue; - FModified := True; - end; -end; - -procedure TXMLConfig.SetDeleteValue(const APath, AValue, DefValue: String); -begin - if AValue=DefValue then - DeleteValue(APath) - else - SetValue(APath,AValue); -end; - -procedure TXMLConfig.SetValue(const APath: String; AValue: Integer); -begin - SetValue(APath, IntToStr(AValue)); -end; - -procedure TXMLConfig.SetDeleteValue(const APath: String; AValue, - DefValue: Integer); -begin - if AValue=DefValue then - DeleteValue(APath) - else - SetValue(APath,AValue); -end; - -procedure TXMLConfig.SetValue(const APath: String; AValue: Boolean); -begin - if AValue then - SetValue(APath, 'True') - else - SetValue(APath, 'False'); -end; - -procedure TXMLConfig.SetDeleteValue(const APath: String; AValue, - DefValue: Boolean); -begin - if AValue=DefValue then - DeleteValue(APath) - else - SetValue(APath,AValue); -end; - -procedure TXMLConfig.SetExtendedValue(const APath: String; - const AValue: extended); -begin - SetValue(APath,ExtendedToStr(AValue)); -end; - -procedure TXMLConfig.SetDeleteExtendedValue(const APath: String; const AValue, - DefValue: extended); -begin - if AValue=DefValue then - DeleteValue(APath) - else - SetExtendedValue(APath,AValue); -end; - -procedure TXMLConfig.DeletePath(const APath: string); -var - Node: TDOMNode; - ParentNode: TDOMNode; -begin - Node:=InternalFindNode(APath,length(APath)); - if (Node=nil) or (Node.ParentNode=nil) then exit; - ParentNode:=Node.ParentNode; - ParentNode.RemoveChild(Node); - FModified:=true; - InvalidatePathCache; - InternalCleanNode(ParentNode); -end; - -procedure TXMLConfig.DeleteValue(const APath: string); -var - Node: TDomNode; - StartPos: integer; - NodeName: string; -begin - Node:=FindNode(APath,true); - if (Node=nil) then exit; - StartPos:=length(APath); - while (StartPos>0) and (APath[StartPos]<>'/') do dec(StartPos); - NodeName:=copy(APath,StartPos+1,length(APath)-StartPos); - if Assigned(TDOMElement(Node).GetAttributeNode(NodeName)) then begin - TDOMElement(Node).RemoveAttribute(NodeName); - FModified := True; - end; - InternalCleanNode(Node); -end; - -procedure TXMLConfig.Loaded; -begin - inherited Loaded; - if Length(Filename) > 0 then - SetFilename(Filename); // Load the XML config file -end; - -function TXMLConfig.FindNode(const APath: String; - PathHasValue: boolean): TDomNode; -var - PathLen: Integer; -begin - PathLen:=length(APath); - if PathHasValue then begin - while (PathLen>0) and (APath[PathLen]<>'/') do dec(PathLen); - while (PathLen>0) and (APath[PathLen]='/') do dec(PathLen); - end; - Result:=InternalFindNode(APath,PathLen); -end; - -function TXMLConfig.HasPath(const APath: string; PathHasValue: boolean - ): boolean; -begin - Result:=FindNode(APath,PathHasValue)<>nil; -end; - -function TXMLConfig.HasChildPaths(const APath: string): boolean; -var - Node: TDOMNode; -begin - Node:=FindNode(APath,false); - Result:=(Node<>nil) and Node.HasChildNodes; -end; - -procedure TXMLConfig.InvalidatePathCache; -begin - fPathCache:=''; - InvalidateCacheTilEnd(0); -end; - -function TXMLConfig.ExtendedToStr(const e: extended): string; -var - OldDecimalSeparator: Char; - OldThousandSeparator: Char; -begin - OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator; - OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator; - DefaultFormatSettings.DecimalSeparator:='.'; - DefaultFormatSettings.ThousandSeparator:=','; - Result:=FloatToStr(e); - DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator; - DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator; -end; - -function TXMLConfig.StrToExtended(const s: string; const ADefault: extended): extended; -var - OldDecimalSeparator: Char; - OldThousandSeparator: Char; -begin - OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator; - OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator; - DefaultFormatSettings.DecimalSeparator:='.'; - DefaultFormatSettings.ThousandSeparator:=','; - Result:=StrToFloatDef(s,ADefault); - DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator; - DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator; -end; - -procedure TXMLConfig.ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); -begin - InvalidatePathCache; - {$IFNDEF OldXMLCfg} - Laz2_XMLRead.ReadXMLFile(ADoc,AFilename,ReadFlags); - {$ELSE} - Laz_XMLRead.ReadXMLFile(ADoc,AFilename); - {$ENDIF} -end; - -procedure TXMLConfig.WriteXMLFile(ADoc: TXMLDocument; const AFileName: String); -begin - {$IFNDEF OldXMLCfg} - Laz2_XMLWrite.WriteXMLFile(ADoc,AFileName,WriteFlags); - {$ELSE} - Laz_XMLWrite.WriteXMLFile(ADoc,AFileName); - {$ENDIF} - InvalidateFileStateCache(AFileName); -end; - -procedure TXMLConfig.FreeDoc; -begin - InvalidatePathCache; - FreeAndNil(doc); -end; - -procedure TXMLConfig.SetPathNodeCache(Index: integer; Node: TDomNode); -var - OldLength: Integer; - i: LongInt; - NewSize: Integer; -begin - OldLength:=length(fPathNodeCache); - if OldLength<=Index then begin - NewSize:=OldLength*2+4; - if NewSizenil) do begin - EndPos:=StartPos; - while (EndPos<=PathLen) and (APath[EndPos]<>'/') do inc(EndPos); - NameLen:=EndPos-StartPos; - if NameLen=0 then break; - inc(PathIndex); - Parent:=Result; - Result:=GetPathNodeCache(PathIndex); - if (Result<>nil) and (length(Result.NodeName)=NameLen) - and CompareMem(PChar(Result.NodeName),@APath[StartPos],NameLen) then begin - // cache valid - end else begin - // different path => search - InvalidateCacheTilEnd(PathIndex); - NodePath:=copy(APath,StartPos,NameLen); - Result:=Parent.FindNode(NodePath); - if Result=nil then begin - if not CreateNodes then exit; - // create missing node - Result := Doc.CreateElement(NodePath); - Parent.AppendChild(Result); - if EndPos>PathLen then exit; - end; - SetPathNodeCache(PathIndex,Result); - end; - StartPos:=EndPos+1; - if StartPos>PathLen then exit; - end; - Result:=nil; -end; - -procedure TXMLConfig.InternalCleanNode(Node: TDomNode); -var - ParentNode: TDOMNode; -begin - if (Node=nil) then exit; - while (Node.FirstChild=nil) and (Node.ParentNode<>nil) - and (Node.ParentNode.ParentNode<>nil) do begin - if (Node is TDOMElement) and (not TDOMElement(Node).IsEmpty) then break; - ParentNode:=Node.ParentNode; - ParentNode.RemoveChild(Node); - InvalidatePathCache; - Node:=ParentNode; - FModified := True; - end; -end; - -procedure TXMLConfig.SetFilename(const AFilename: String); -var - cfg: TDOMElement; - ms: TMemoryStream; -begin - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename A '+AFilename);{$ENDIF} - if FFilename = AFilename then exit; - FFilename := AFilename; - InvalidatePathCache; - - if csLoading in ComponentState then - exit; - - if Assigned(doc) then - begin - Flush; - FreeDoc; - end; - - doc:=nil; - //debugln(['TXMLConfig.SetFilename Load=',not fDoNotLoadFromFile,' FileExists=',FileExistsCached(Filename),' File=',Filename]); - if (not fDoNotLoadFromFile) and FileExistsCached(Filename) then - {$IFNDEF OldXMLCfg} - Laz2_XMLRead.ReadXMLFile(doc,Filename,ReadFlags) - {$ELSE} - Laz_XMLRead.ReadXMLFile(doc,Filename) - {$ENDIF} - else if fAutoLoadFromSource<>'' then begin - ms:=TMemoryStream.Create; - try - ms.Write(fAutoLoadFromSource[1],length(fAutoLoadFromSource)); - ms.Position:=0; - {$IFNDEF OldXMLCfg} - Laz2_XMLRead.ReadXMLFile(doc,ms,ReadFlags); - {$ELSE} - Laz_XMLRead.ReadXMLFile(doc,ms); - {$ENDIF} - finally - ms.Free; - end; - end; - - if not Assigned(doc) then - doc := TXMLDocument.Create; - - cfg :=TDOMElement(doc.FindNode('CONFIG')); - //debugln(['TXMLConfig.SetFilename cfg=',DbgSName(cfg),' doc=',DbgSName(doc)]); - if not Assigned(cfg) then begin - cfg := doc.CreateElement('CONFIG'); - doc.AppendChild(cfg); - end; - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLConfig.SetFilename END');{$ENDIF} -end; - -{ TRttiXMLConfig } - -procedure TRttiXMLConfig.WriteObject(Path: String; Obj: TPersistent; - DefObject: TPersistent; OnlyProperty: String = ''); -var - PropCount,i : integer; - PropList : PPropList; -begin - PropCount:=GetPropList(Obj,PropList); - if PropCount>0 then begin - try - for i := 0 to PropCount-1 do - WriteProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty); - finally - Freemem(PropList); - end; - end; -end; - -// based on FPC TWriter -procedure TRttiXMLConfig.WriteProperty(Path: String; Instance: TPersistent; - PropInfo: Pointer; DefInstance: TPersistent; OnlyProperty: String= ''); -type - tset = set of 0..31; -var - i: Integer; - PropType: PTypeInfo; - Value, DefValue: LongInt; - Ident: String; - IntToIdentFn: TIntToIdent; - SetType: Pointer; - FloatValue, DefFloatValue: Extended; - //WStrValue, WDefStrValue: WideString; - StrValue, DefStrValue: String; - //Int64Value, DefInt64Value: Int64; - BoolValue, DefBoolValue: boolean; - -begin - // do not stream properties without getter and setter - if not (Assigned(PPropInfo(PropInfo)^.GetProc) and - Assigned(PPropInfo(PropInfo)^.SetProc)) then - exit; - - PropType := PPropInfo(PropInfo)^.PropType; - Path := Path + PPropInfo(PropInfo)^.Name; - if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then - exit; - - case PropType^.Kind of - tkInteger, tkChar, tkEnumeration, tkSet, tkWChar: - begin - Value := GetOrdProp(Instance, PropInfo); - if (DefInstance <> nil) then - DefValue := GetOrdProp(DefInstance, PropInfo); - if (DefInstance <> nil) and (Value = DefValue) then - DeleteValue(Path) - else begin - case PropType^.Kind of - tkInteger: - begin // Check if this integer has a string identifier - IntToIdentFn := FindIntToIdent(PPropInfo(PropInfo)^.PropType); - if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident{%H-}) then - SetValue(Path, Ident) // Integer can be written a human-readable identifier - else - SetValue(Path, Value); // Integer has to be written just as number - end; - tkChar: - SetValue(Path, Chr(Value)); - tkWChar: - SetValue(Path, Value); - tkSet: - begin - SetType := GetTypeData(PropType)^.CompType; - Ident := ''; - for i := 0 to 31 do - if (i in tset(Value)) then begin - if Ident <> '' then Ident := Ident + ','; - Ident := Ident + GetEnumName(PTypeInfo(SetType), i); - end; - SetValue(Path, Ident); - end; - tkEnumeration: - SetValue(Path, GetEnumName(PropType, Value)); - end; - end; - end; - tkFloat: - begin - FloatValue := GetFloatProp(Instance, PropInfo); - if (DefInstance <> nil) then - DefFloatValue := GetFloatProp(DefInstance, PropInfo); - if (DefInstance <> nil) and (DefFloatValue = FloatValue) then - DeleteValue(Path) - else - SetValue(Path, FloatToStr(FloatValue)); - end; - tkSString, tkLString, tkAString: - begin - StrValue := GetStrProp(Instance, PropInfo); - if (DefInstance <> nil) then - DefStrValue := GetStrProp(DefInstance, PropInfo); - if (DefInstance <> nil) and (DefStrValue = StrValue) then - DeleteValue(Path) - else - SetValue(Path, StrValue); - end; -(* tkWString: - begin - WStrValue := GetWideStrProp(Instance, PropInfo); - if (DefInstance <> nil) then - WDefStrValue := GetWideStrProp(DefInstance, PropInfo); - if (DefInstance <> nil) and (WDefStrValue = WStrValue) then - DeleteValue(Path) - else - SetValue(Path, WStrValue); - end;*) -(* tkInt64, tkQWord: - begin - Int64Value := GetInt64Prop(Instance, PropInfo); - if (DefInstance <> nil) then - DefInt64Value := GetInt64Prop(DefInstance, PropInfo) - if (DefInstance <> nil) and (Int64Value = DefInt64Value) then - DeleteValue(Path, Path) - else - SetValue(StrValue); - end;*) - tkBool: - begin - BoolValue := GetOrdProp(Instance, PropInfo)<>0; - if (DefInstance <> nil) then - DefBoolValue := GetOrdProp(DefInstance, PropInfo)<>0; - if (DefInstance <> nil) and (BoolValue = DefBoolValue) then - DeleteValue(Path) - else - SetValue(Path, BoolValue); - end; - end; -end; - -procedure TRttiXMLConfig.ReadProperty(Path: String; Instance: TPersistent; PropInfo: Pointer; - DefInstance: TPersistent; OnlyProperty: String); -type - tset = set of 0..31; -var - i, j: Integer; - PropType: PTypeInfo; - Value, DefValue: LongInt; - Ident, s: String; - IdentToIntFn: TIdentToInt; - SetType: Pointer; - FloatValue, DefFloatValue: Extended; - //WStrValue, WDefStrValue: WideString; - StrValue, DefStrValue: String; - //Int64Value, DefInt64Value: Int64; - BoolValue, DefBoolValue: boolean; - -begin - // do not stream properties without getter and setter - if not (Assigned(PPropInfo(PropInfo)^.GetProc) and - Assigned(PPropInfo(PropInfo)^.SetProc)) then - exit; - - PropType := PPropInfo(PropInfo)^.PropType; - Path := Path + PPropInfo(PropInfo)^.Name; - if (OnlyProperty <> '') and (OnlyProperty <> PPropInfo(PropInfo)^.Name) then - exit; - if DefInstance = nil then - DefInstance := Instance; - - case PropType^.Kind of - tkInteger, tkChar, tkEnumeration, tkSet, tkWChar: - begin - DefValue := GetOrdProp(DefInstance, PropInfo); - case PropType^.Kind of - tkInteger: - begin // Check if this integer has a string identifier - Ident := GetValue(Path, IntToStr(DefValue)); - IdentToIntFn := FindIdentToInt(PPropInfo(PropInfo)^.PropType); - if TryStrToInt(Ident, Value) then - SetOrdProp(Instance, PropInfo, Value) - else if Assigned(IdentToIntFn) and IdentToIntFn(Ident, Value) then - SetOrdProp(Instance, PropInfo, Value) - else - SetOrdProp(Instance, PropInfo, DefValue) - end; - tkChar: - begin - Ident := GetValue(Path, chr(DefValue)); - if Length(Ident) > 0 then - SetOrdProp(Instance, PropInfo, ord(Ident[1])) - else - SetOrdProp(Instance, PropInfo, DefValue); - end; - tkWChar: - SetOrdProp(Instance, PropInfo, GetValue(Path, DefValue)); - tkSet: - begin - SetType := GetTypeData(PropType)^.CompType; - Ident := GetValue(Path, '-'); - If Ident = '-' then - Value := DefValue - else begin - Value := 0; - while length(Ident) > 0 do begin - i := Pos(',', Ident); - if i < 1 then - i := length(Ident) + 1; - s := copy(Ident, 1, i-1); - Ident := copy(Ident, i+1, length(Ident)); - j := GetEnumValue(PTypeInfo(SetType), s); - if j <> -1 then - include(tset(Value), j) - else Begin - Value := DefValue; - break; - end; - end; - end; - SetOrdProp(Instance, PropInfo, Value); - end; - tkEnumeration: - begin - Ident := GetValue(Path, '-'); - If Ident = '-' then - Value := DefValue - else - Value := GetEnumValue(PropType, Ident); - if Value <> -1 then - SetOrdProp(Instance, PropInfo, Value) - else - SetOrdProp(Instance, PropInfo, DefValue); - end; - end; - end; - tkFloat: - begin - DefFloatValue := GetFloatProp(DefInstance, PropInfo); - Ident := GetValue(Path, FloatToStr(DefFloatValue)); - if TryStrToFloat(Ident, FloatValue) then - SetFloatProp(Instance, PropInfo, FloatValue) - else - SetFloatProp(Instance, PropInfo, DefFloatValue) - end; - tkSString, tkLString, tkAString: - begin - DefStrValue := GetStrProp(DefInstance, PropInfo); - StrValue := GetValue(Path, DefStrValue); - SetStrProp(Instance, PropInfo, StrValue) - end; -(* tkWString: - begin - end;*) -(* tkInt64, tkQWord: - begin - end;*) - tkBool: - begin - DefBoolValue := GetOrdProp(DefInstance, PropInfo) <> 0; - BoolValue := GetValue(Path, DefBoolValue); - SetOrdProp(Instance, PropInfo, ord(BoolValue)); - end; - end; -end; - -procedure TRttiXMLConfig.ReadObject(Path: String; Obj: TPersistent; DefObject: TPersistent; - OnlyProperty: String); -var - PropCount,i : integer; - PropList : PPropList; -begin - PropCount:=GetPropList(Obj,PropList); - if PropCount>0 then begin - try - for i := 0 to PropCount-1 do - ReadProperty(Path, Obj, PropList^[i], DefObject, OnlyProperty); - finally - Freemem(PropList); - end; - end; -end; - end. diff --git a/components/lazutils/laz_xmlread.pas b/components/lazutils/laz_xmlread.pas index 28a1d98073..e2a0ce72d5 100644 --- a/components/lazutils/laz_xmlread.pas +++ b/components/lazutils/laz_xmlread.pas @@ -1,41 +1,17 @@ -{ - This file is part of the Free Component Library - - XML reading routines. - Copyright (c) 1999-2000 by Sebastian Guenther, sg@freepascal.org - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - unit Laz_XMLRead; -{$MODE objfpc} -{$H+} +{$MODE objfpc}{$H+} {$inline on} interface -{off $DEFINE MEM_CHECK} - uses - {$IFDEF MEM_CHECK}MemCheck,{$ENDIF} - SysUtils, Classes, types, LazUTF8, Laz_DOM; + Classes, laz2_XMLRead, laz2_DOM; type - - EXMLReadError = class(Exception) - public - Position: PtrInt; - LineCol: TPoint; - Descr: string; - end; - + EXMLReadError = laz2_XMLRead.EXMLReadError; +const + xrfOldXMLRead = [xrfAllowLowerThanInAttributeValue,xrfAllowSpecialCharsInAttributeValue]; procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); overload; procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File); overload; @@ -52,1498 +28,69 @@ procedure ReadDTDFile(var ADoc: TXMLDocument; var f: File); overload; procedure ReadDTDFile(var ADoc: TXMLDocument; var f: TStream); overload; procedure ReadDTDFile(var ADoc: TXMLDocument; var f: TStream; const AFilename: String); overload; - -// ======================================================= - implementation -const - - Letter = ['A'..'Z', 'a'..'z']; - Digit = ['0'..'9']; - PubidChars: set of Char = [' ', #13, #10, 'a'..'z', 'A'..'Z', '0'..'9', - '-', '''', '(', ')', '+', ',', '.', '/', ':', '=', '?', ';', '!', '*', - '#', '@', '$', '_', '%']; - WhitespaceChars: set of Char = [#9, #10, #13, ' ']; - - NmToken: set of Char = Letter + Digit + ['.', '-', '_', ':']; - -function ComparePChar(p1, p2: PChar): boolean; +procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); begin - if p1<>p2 then begin - if (p1<>nil) and (p2<>nil) then begin - while true do begin - if (p1^=p2^) then begin - if p1^<>#0 then begin - inc(p1); - inc(p2); - end else begin - Result:=true; - exit; - end; - end else begin - Result:=false; - exit; - end; - end; - Result:=true; - end else begin - Result:=false; - end; - end else begin - Result:=true; - end; + laz2_XMLRead.ReadXMLFile(ADoc,AFilename,xrfOldXMLRead); end; -function CompareLPChar(p1, p2: PChar; Max: integer): boolean; -begin - if p1<>p2 then begin - if (p1<>nil) and (p2<>nil) then begin - while Max>0 do begin - if (p1^=p2^) then begin - if (p1^<>#0) then begin - inc(p1); - inc(p2); - dec(Max); - end else begin - Result:=true; - exit; - end; - end else begin - Result:=false; - exit; - end; - end; - Result:=true; - end else begin - Result:=false; - end; - end else begin - Result:=true; - end; -end; - -function CompareIPChar(p1, p2: PChar): boolean; -begin - if p1<>p2 then begin - if (p1<>nil) and (p2<>nil) then begin - while true do begin - if (p1^=p2^) or (upcase(p1^)=upcase(p2^)) then begin - if p1^<>#0 then begin - inc(p1); - inc(p2); - end else begin - Result:=true; - exit; - end; - end else begin - Result:=false; - exit; - end; - end; - Result:=true; - end else begin - Result:=false; - end; - end else begin - Result:=true; - end; -end; - -function CompareLIPChar(p1, p2: PChar; Max: integer): boolean; -begin - if p1<>p2 then begin - if (p1<>nil) and (p2<>nil) then begin - while Max>0 do begin - if (p1^=p2^) or (upcase(p1^)=upcase(p2^)) then begin - if (p1^<>#0) then begin - inc(p1); - inc(p2); - dec(Max); - end else begin - Result:=true; - exit; - end; - end else begin - Result:=false; - exit; - end; - end; - Result:=true; - end else begin - Result:=false; - end; - end else begin - Result:=true; - end; -end; - - -type - TXMLReaderDocument = class(TXMLDocument) - public - procedure SetDocType(ADocType: TDOMDocumentType); - end; - - TXMLReaderDocumentType = class(TDOMDocumentType) - public - constructor Create(ADocument: TXMLReaderDocument); - property Name: DOMString read FNodeName write FNodeName; - end; - - - TSetOfChar = set of Char; - - { TXMLReader } - - TXMLReader = class - protected - buf, BufStart: PChar; - Filename: String; - function BufPosToLineCol(p: PChar): TPoint; - function BufPosToStr(p: PChar): string; - procedure RaiseExc(const descr: String); - procedure RaiseCharNotFound(c : char); - function SkipWhitespace: Boolean; - procedure ExpectWhitespace; inline; - procedure ExpectChar(c: char); inline; - procedure ExpectString(const s: String); - function CheckFor(s: PChar): Boolean; - function CheckForChar(c: Char): Boolean; - procedure SkipString(const ValidChars: TSetOfChar); - function GetString(const ValidChars: TSetOfChar): String; - function GetString(BufPos: PChar; Len: integer): String; - - function CheckName: Boolean; - function GetName(out s: String): Boolean; - function ExpectName: String; // [5] - procedure SkipName; - procedure ExpectAttValue(attr: TDOMAttr); // [10] - function ExpectPubidLiteral: String; // [12] - procedure SkipPubidLiteral; - function ParseComment(AOwner: TDOMNode): Boolean; // [15] - function ParsePI: Boolean; // [16] - procedure ExpectProlog; // [22] - function ParseEq: Boolean; // [25] - procedure ExpectEq; - procedure ParseMisc(AOwner: TDOMNode); // [27] - function ParseMarkupDecl: Boolean; // [29] - function ParseCharData(AOwner: TDOMNode): Boolean; // [14] - function ParseCDSect(AOwner: TDOMNode): Boolean; // [18] - function ParseElement(AOwner: TDOMNode): Boolean; // [39] - procedure ExpectElement(AOwner: TDOMNode); - function ParseReference(AOwner: TDOMNode): Boolean; // [67] - procedure ExpectReference(AOwner: TDOMNode); - function ParsePEReference: Boolean; // [69] - function ParseExternalID: Boolean; // [75] - procedure ExpectExternalID; - function ParseEncodingDecl: String; // [80] - procedure SkipEncodingDecl; - - procedure ResolveEntities(RootNode: TDOMNode); - public - doc: TDOMDocument; - procedure ProcessXML(ABuf: PChar; const AFilename: String); // [1] - procedure ProcessFragment(AOwner: TDOMNode; ABuf: PChar; const AFilename: String); - procedure ProcessDTD(ABuf: PChar; const AFilename: String); // ([29]) - end; - -{ TXMLReaderDocument } - -procedure TXMLReaderDocument.SetDocType(ADocType: TDOMDocumentType); -begin - FDocType := ADocType; -end; - - -constructor TXMLReaderDocumentType.Create(ADocument: TXMLReaderDocument); -begin - inherited Create(ADocument); -end; - -function TXMLReader.BufPosToLineCol(p: PChar): TPoint; -var - apos: PChar; - x: Integer; - y: Integer; -begin - // find out the line in which the error occured - apos := BufStart; - x := 1; - y := 1; - while apos < p do begin - if apos^ in [#10,#13] then begin - Inc(y); - x := 1; - if (apos[1] in [#10,#13]) and (apos[0]<>apos[1]) then - inc(apos); - end else - Inc(x); - Inc(apos); - end; - Result.X:=X; - Result.Y:=Y; -end; - -function TXMLReader.BufPosToStr(p: PChar): string; -var - LineCol: TPoint; -begin - if p c then - RaiseCharNotFound(c); - Inc(buf); -end; - -procedure TXMLReader.ExpectString(const s: String); - - procedure RaiseStringNotFound; - var - s2: PChar; - s3: String; - begin - GetMem(s2, Length(s) + 1); - StrLCopy(s2, buf, Length(s)); - s3 := StrPas(s2); - FreeMem(s2); - RaiseExc('Expected "' + s + '", found "' + s3 + '"'); - end; - -var - i: Integer; -begin - for i := 1 to Length(s) do - if buf[i - 1] <> s[i] then begin - RaiseStringNotFound; - end; - Inc(buf, Length(s)); -end; - -function TXMLReader.CheckFor(s: PChar): Boolean; -begin - if buf[0] <> #0 then begin - if (buf[0]=s[0]) and (CompareLPChar(buf, s, StrLen(s))) then begin - Inc(buf, StrLen(s)); - Result := True; - end else - Result := False; - end else begin - Result := False; - end; -end; - -function TXMLReader.CheckForChar(c: Char): Boolean; -begin - if (buf[0]=c) and (c<>#0) then begin - inc(buf); - Result:=true; - end else begin - Result:=false; - end; -end; - -procedure TXMLReader.SkipString(const ValidChars: TSetOfChar); -begin - while buf[0] in ValidChars do begin - Inc(buf); - end; -end; - -function TXMLReader.GetString(const ValidChars: TSetOfChar): String; -var - OldBuf: PChar; - i, len: integer; -begin - OldBuf:=Buf; - while buf[0] in ValidChars do begin - Inc(buf); - end; - len:=buf-OldBuf; - SetLength(Result, Len); - for i:=1 to len do begin - Result[i]:=OldBuf[0]; - inc(OldBuf); - end; -end; - -function TXMLReader.GetString(BufPos: PChar; Len: integer): string; -var i: integer; -begin - SetLength(Result,Len); - for i:=1 to Len do begin - Result[i]:=BufPos[0]; - inc(BufPos); - end; -end; - -procedure TXMLReader.ProcessXML(ABuf: PChar; const AFilename: String); // [1] -begin - buf := ABuf; - BufStart := ABuf; - Filename := AFilename; - - doc := TXMLReaderDocument.Create; - ExpectProlog; - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLReader.ProcessXML A');{$ENDIF} - ExpectElement(doc); - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLReader.ProcessXML B');{$ENDIF} - ParseMisc(doc); - - // skip end of file characters - while buf^=#26 do inc(buf); - // check if whole document was read - if buf[0] <> #0 then - RaiseExc('Text after end of document element found'); -end; - -procedure TXMLReader.ProcessFragment(AOwner: TDOMNode; ABuf: PChar; const AFilename: String); -begin - buf := ABuf; - BufStart := ABuf; - Filename := AFilename; - - // do not call SkipWhitespace. They are needed by ParseCharData. - while ParseCharData(AOwner) or ParseCDSect(AOwner) or ParsePI or - ParseComment(AOwner) or ParseElement(AOwner) or - ParseReference(AOwner) - do ; -end; - -function TXMLReader.CheckName: Boolean; -var OldBuf: PChar; -begin - if not (buf[0] in (Letter + ['_', ':'])) then begin - Result := False; - exit; - end; - - OldBuf := buf; - Inc(buf); - SkipString(Letter + ['0'..'9', '.', '-', '_', ':']); - buf := OldBuf; - Result := True; -end; - -function TXMLReader.GetName(out s: String): Boolean; // [5] -var OldBuf: PChar; -begin - if not (buf[0] in (Letter + ['_', ':'])) then begin - SetLength(s, 0); - Result := False; - exit; - end; - - OldBuf := buf; - Inc(buf); - SkipString(Letter + ['0'..'9', '.', '-', '_', ':']); - s := GetString(OldBuf,buf-OldBuf); - Result := True; -end; - -function TXMLReader.ExpectName: String; // [5] - - procedure RaiseNameNotFound; - begin - RaiseExc('Expected letter, "_" or ":" for name, found "' + buf[0] + '"'); - end; - -var OldBuf: PChar; -begin - if not (buf[0] in (Letter + ['_', ':'])) then - RaiseNameNotFound; - - OldBuf := buf; - Inc(buf); - SkipString(Letter + ['0'..'9', '.', '-', '_', ':']); - Result:=GetString(OldBuf,buf-OldBuf); -end; - -procedure TXMLReader.SkipName; - - procedure RaiseSkipNameNotFound; - begin - RaiseExc('Expected letter, "_" or ":" for name, found "' + buf[0] + '"'); - end; - -begin - if not (buf[0] in (Letter + ['_', ':'])) then - RaiseSkipNameNotFound; - - Inc(buf); - SkipString(Letter + ['0'..'9', '.', '-', '_', ':']); -end; - -procedure TXMLReader.ExpectAttValue(attr: TDOMAttr); // [10] -var - OldBuf: PChar; - - procedure FlushStringBuffer; - var - s: String; - begin - if OldBuf<>buf then begin - s := GetString(OldBuf,buf-OldBuf); - OldBuf := buf; - attr.AppendChild(doc.CreateTextNode(s)); - SetLength(s, 0); - end; - end; - -var - StrDel: char; -begin - if (buf[0] <> '''') and (buf[0] <> '"') then - RaiseExc('Expected quotation marks'); - StrDel:=buf[0]; - Inc(buf); - OldBuf := buf; - while (buf[0]<>StrDel) and (buf[0]<>#0) do begin - if buf[0] <> '&' then begin - Inc(buf); - end else - begin - if OldBuf<>buf then FlushStringBuffer; - ParseReference(attr); - OldBuf := buf; - end; - end; - if OldBuf<>buf then FlushStringBuffer; - inc(buf); - ResolveEntities(Attr); -end; - -function TXMLReader.ExpectPubidLiteral: String; -begin - SetLength(Result, 0); - if CheckForChar('''') then begin - SkipString(PubidChars - ['''']); - ExpectChar(''''); - end else if CheckForChar('"') then begin - SkipString(PubidChars - ['"']); - ExpectChar('"'); - end else - RaiseExc('Expected quotation marks'); -end; - -procedure TXMLReader.SkipPubidLiteral; -begin - if CheckForChar('''') then begin - SkipString(PubidChars - ['''']); - ExpectChar(''''); - end else if CheckForChar('"') then begin - SkipString(PubidChars - ['"']); - ExpectChar('"'); - end else - RaiseExc('Expected quotation marks'); -end; - -function TXMLReader.ParseComment(AOwner: TDOMNode): Boolean; // [15] -var - comment: String; - OldBuf: PChar; -begin - if CheckFor(''); - Result := True; - end else - Result := False; -end; - -function TXMLReader.ParsePI: Boolean; // [16] -begin - if CheckFor(' #0) and (buf[1] <> #0) and not - ((buf[0] = '?') and (buf[1] = '>')) do Inc(buf); - ExpectString('?>'); - Result := True; - end else - Result := False; -end; - -procedure TXMLReader.ExpectProlog; // [22] - - procedure ParseVersionNum; - begin - if doc.InheritsFrom(TXMLDocument) then - TXMLDocument(doc).XMLVersion := - GetString(['a'..'z', 'A'..'Z', '0'..'9', '_', '.', ':', '-']); - end; - - procedure ParseDoctypeDecls; - begin - repeat - SkipWhitespace; - until not (ParseMarkupDecl or ParsePEReference); - ExpectChar(']'); - end; - - -var - DocType: TXMLReaderDocumentType; - -begin - if CheckFor('' - - // VersionInfo: S 'version' Eq (' VersionNum ' | " VersionNum ") - SkipWhitespace; - ExpectString('version'); - ParseEq; - if buf[0] = '''' then - begin - Inc(buf); - ParseVersionNum; - ExpectChar(''''); - end else if buf[0] = '"' then - begin - Inc(buf); - ParseVersionNum; - ExpectChar('"'); - end else - RaiseExc('Expected single or double quotation mark'); - - // EncodingDecl? - SkipEncodingDecl; - - // SDDecl? - SkipWhitespace; - if CheckFor('standalone') then - begin - ExpectEq; - if buf[0] = '''' then - begin - Inc(buf); - if not (CheckFor('yes''') or CheckFor('no''')) then - RaiseExc('Expected ''yes'' or ''no'''); - end else if buf[0] = '''' then - begin - Inc(buf); - if not (CheckFor('yes"') or CheckFor('no"')) then - RaiseExc('Expected "yes" or "no"'); - end; - SkipWhitespace; - end; - - ExpectString('?>'); - end; - - // Check for "Misc*" - ParseMisc(doc); - - // Check for "(doctypedecl Misc*)?" [28] - if CheckFor(''); - end else if not CheckForChar('>') then - begin - ParseExternalID; - SkipWhitespace; - if CheckForChar('[') then - begin - ParseDoctypeDecls; - SkipWhitespace; - end; - ExpectChar('>'); - end; - ParseMisc(doc); - end; -end; - -function TXMLReader.ParseEq: Boolean; // [25] -var - savedbuf: PChar; -begin - savedbuf := buf; - SkipWhitespace; - if buf[0] = '=' then begin - Inc(buf); - SkipWhitespace; - Result := True; - end else begin - buf := savedbuf; - Result := False; - end; -end; - -procedure TXMLReader.ExpectEq; -begin - if not ParseEq then - RaiseExc('Expected "="'); -end; - - -// Parse "Misc*": -// Misc ::= Comment | PI | S - -procedure TXMLReader.ParseMisc(AOwner: TDOMNode); // [27] -begin - repeat - SkipWhitespace; - until not (ParseComment(AOwner) or ParsePI); -end; - -function TXMLReader.ParseMarkupDecl: Boolean; // [29] - - function ParseElementDecl: Boolean; // [45] - - procedure ExpectChoiceOrSeq; // [49], [50] - - procedure ExpectCP; // [48] - begin - if CheckForChar('(') then - ExpectChoiceOrSeq - else - SkipName; - if CheckForChar('?') then - else if CheckForChar('*') then - else if CheckForChar('+') then; - end; - - var - delimiter: Char; - begin - SkipWhitespace; - ExpectCP; - SkipWhitespace; - delimiter := #0; - while not CheckForChar(')') do begin - if delimiter = #0 then begin - if (buf[0] = '|') or (buf[0] = ',') then - delimiter := buf[0] - else - RaiseExc('Expected "|" or ","'); - Inc(buf); - end else - ExpectChar(delimiter); - SkipWhitespace; - ExpectCP; - end; - end; - - begin - if CheckFor(''); - Result := True; - end else - Result := False; - end; - - function ParseAttlistDecl: Boolean; // [52] - var - attr: TDOMAttr; - begin - if CheckFor('') do begin - SkipName; - ExpectWhitespace; - - // Get AttType [54], [55], [56] - if CheckFor('CDATA') then - else if CheckFor('ID') then - else if CheckFor('IDREF') then - else if CheckFor('IDREFS') then - else if CheckFor('ENTITTY') then - else if CheckFor('ENTITIES') then - else if CheckFor('NMTOKEN') then - else if CheckFor('NMTOKENS') then - else if CheckFor('NOTATION') then begin // [57], [58] - ExpectWhitespace; - ExpectChar('('); - SkipWhitespace; - SkipName; - SkipWhitespace; - while not CheckForChar(')') do begin - ExpectChar('|'); - SkipWhitespace; - SkipName; - SkipWhitespace; - end; - end else if CheckForChar('(') then begin // [59] - SkipWhitespace; - SkipString(Nmtoken); - SkipWhitespace; - while not CheckForChar(')') do begin - ExpectChar('|'); - SkipWhitespace; - SkipString(Nmtoken); - SkipWhitespace; - end; - end else - RaiseExc('Invalid tokenized type'); - - ExpectWhitespace; - - // Get DefaultDecl [60] - if CheckFor('#REQUIRED') then - else if CheckFor('#IMPLIED') then - else begin - if CheckFor('#FIXED') then - SkipWhitespace; - attr := doc.CreateAttribute(''); - ExpectAttValue(attr); - end; - - SkipWhitespace; - end; - Result := True; - end else - Result := False; - end; - - function ParseEntityDecl: Boolean; // [70] - var - NewEntity: TDOMEntity; - - function ParseEntityValue: Boolean; // [9] - var - strdel: Char; - begin - if (buf[0] <> '''') and (buf[0] <> '"') then begin - Result := False; - exit; - end; - strdel := buf[0]; - Inc(buf); - while not CheckForChar(strdel) do - if ParsePEReference then - else if ParseReference(NewEntity) then - else begin - Inc(buf); // Normal haracter - end; - Result := True; - end; - - begin - if CheckFor(''); - Result := True; - end else - Result := False; - end; - - function ParseNotationDecl: Boolean; // [82] - begin - if CheckFor(''); - Result := True; - end else - Result := False; - end; - -begin - Result := False; - while ParseElementDecl or ParseAttlistDecl or ParseEntityDecl or - ParseNotationDecl or ParsePI or ParseComment(doc) or SkipWhitespace do - Result := True; -end; - -procedure TXMLReader.ProcessDTD(ABuf: PChar; const AFilename: String); -begin - buf := ABuf; - BufStart := ABuf; - Filename := AFilename; - - doc := TXMLReaderDocument.Create; - ParseMarkupDecl; - - { - if buf[0] <> #0 then begin - DebugLn('=== Unparsed: ==='); - //DebugLn(buf); - DebugLn(StrLen(buf), ' chars'); - end; - } -end; - -function TXMLReader.ParseCharData(AOwner: TDOMNode): Boolean; // [14] -var - p: PChar; - DataLen: integer; - OldBuf: PChar; -begin - OldBuf := buf; - while not (buf[0] in [#0, '<', '&']) do - begin - Inc(buf); - end; - DataLen:=buf-OldBuf; - if DataLen > 0 then - begin - // Check if chardata has non-whitespace content - p:=OldBuf; - while (p') do - begin - Inc(buf); - end; - AOwner.AppendChild(doc.CreateCDATASection(GetString(OldBuf,buf-OldBuf-3))); { Copy CDATA, discarding terminator } - Result := True; - end - else - Result := False; -end; - -function TXMLReader.ParseElement(AOwner: TDOMNode): Boolean; // [39] [40] [44] -var - NewElem: TDOMElement; - - procedure CreateNameElement; - var - IsEmpty: Boolean; - attr: TDOMAttr; - name: string; - FoundName: String; - StartPos: PChar; - begin - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt(' CreateNameElement A');{$ENDIF} - StartPos:=buf; - GetName(name); - NewElem := doc.CreateElement(name); - AOwner.AppendChild(NewElem); - - SkipWhitespace; - IsEmpty := False; - while True do - begin - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt(' CreateNameElement E');{$ENDIF} - if CheckFor('/>') then - begin - IsEmpty := True; - break; - end; - if CheckForChar('>') then - break; - - // Get Attribute [41] - attr := doc.CreateAttribute(ExpectName); - NewElem.Attributes.SetNamedItem(attr); - ExpectEq; - ExpectAttValue(attr); - - SkipWhitespace; - end; - - if not IsEmpty then - begin - // Get content - SkipWhitespace; - while ParseCharData(NewElem) or ParseCDSect(NewElem) or ParsePI or - ParseComment(NewElem) or ParseElement(NewElem) or - ParseReference(NewElem) do; - - // Get ETag [42] - ExpectString(' name then - RaiseExc('Unmatching element end tag (expected "", found "", start tag at '+BufPosToStr(StartPos)+')'); - SkipWhitespace; - ExpectChar('>'); - end; - - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt(' CreateNameElement END');{$ENDIF} - ResolveEntities(NewElem); - end; - -var - OldBuf: PChar; -begin - OldBuf := Buf; - if CheckForChar('<') then - begin - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLReader.ParseElement A');{$ENDIF} - if not CheckName then - begin - Buf := OldBuf; - Result := False; - end else begin - CreateNameElement; - Result := True; - end; - end else - Result := False; - {$IFDEF MEM_CHECK}CheckHeapWrtMemCnt('TXMLReader.ParseElement END');{$ENDIF} -end; - -procedure TXMLReader.ExpectElement(AOwner: TDOMNode); -begin - if not ParseElement(AOwner) then - RaiseExc('Expected element'); -end; - -function TXMLReader.ParsePEReference: Boolean; // [69] -begin - if CheckForChar('%') then begin - SkipName; - ExpectChar(';'); - Result := True; - end else - Result := False; -end; - -function TXMLReader.ParseReference(AOwner: TDOMNode): Boolean; // [67] [68] -begin - if not CheckForChar('&') then begin - Result := False; - exit; - end; - if CheckForChar('#') then begin // Test for CharRef [66] - if CheckForChar('x') then begin - // !!!: there must be at least one digit - while buf[0] in ['0'..'9', 'a'..'f', 'A'..'F'] do Inc(buf); - end else - // !!!: there must be at least one digit - while buf[0] in ['0'..'9'] do Inc(buf); - end else - AOwner.AppendChild(doc.CreateEntityReference(ExpectName)); - ExpectChar(';'); - Result := True; -end; - -procedure TXMLReader.ExpectReference(AOwner: TDOMNode); -begin - if not ParseReference(AOwner) then - RaiseExc('Expected reference ("&Name;" or "%Name;")'); -end; - - -function TXMLReader.ParseExternalID: Boolean; // [75] - - function GetSystemLiteral: String; - var - OldBuf: PChar; - begin - if buf[0] = '''' then begin - Inc(buf); - OldBuf := buf; - while (buf[0] <> '''') and (buf[0] <> #0) do begin - Inc(buf); - end; - Result := GetString(OldBuf,buf-OldBuf); - ExpectChar(''''); - end else if buf[0] = '"' then begin - Inc(buf); - OldBuf := buf; - while (buf[0] <> '"') and (buf[0] <> #0) do begin - Inc(buf); - end; - Result := GetString(OldBuf,buf-OldBuf); - ExpectChar('"'); - end else - Result:=''; - end; - - procedure SkipSystemLiteral; - begin - if buf[0] = '''' then begin - Inc(buf); - while (buf[0] <> '''') and (buf[0] <> #0) do begin - Inc(buf); - end; - ExpectChar(''''); - end else if buf[0] = '"' then begin - Inc(buf); - while (buf[0] <> '"') and (buf[0] <> #0) do begin - Inc(buf); - end; - ExpectChar('"'); - end; - end; - -begin - if CheckFor('SYSTEM') then begin - ExpectWhitespace; - SkipSystemLiteral; - Result := True; - end else if CheckFor('PUBLIC') then begin - ExpectWhitespace; - SkipPubidLiteral; - ExpectWhitespace; - SkipSystemLiteral; - Result := True; - end else - Result := False; -end; - -procedure TXMLReader.ExpectExternalID; -begin - if not ParseExternalID then - RaiseExc('Expected external ID'); -end; - -function TXMLReader.ParseEncodingDecl: String; // [80] - - function ParseEncName: String; - var OldBuf: PChar; - begin - if not (buf[0] in ['A'..'Z', 'a'..'z']) then - RaiseExc('Expected character (A-Z, a-z)'); - OldBuf := buf; - Inc(buf); - SkipString(['A'..'Z', 'a'..'z', '0'..'9', '.', '_', '-']); - Result := GetString(OldBuf,buf-OldBuf); - end; - -begin - SetLength(Result, 0); - SkipWhitespace; - if CheckFor('encoding') then begin - ExpectEq; - if buf[0] = '''' then begin - Inc(buf); - Result := ParseEncName; - ExpectChar(''''); - end else if buf[0] = '"' then begin - Inc(buf); - Result := ParseEncName; - ExpectChar('"'); - end; - end; -end; - -procedure TXMLReader.SkipEncodingDecl; - - procedure ParseEncName; - begin - if not (buf[0] in ['A'..'Z', 'a'..'z']) then - RaiseExc('Expected character (A-Z, a-z)'); - Inc(buf); - SkipString(['A'..'Z', 'a'..'z', '0'..'9', '.', '_', '-']); - end; - -begin - SkipWhitespace; - if CheckFor('encoding') then begin - ExpectEq; - if buf[0] = '''' then begin - Inc(buf); - ParseEncName; - ExpectChar(''''); - end else if buf[0] = '"' then begin - Inc(buf); - ParseEncName; - ExpectChar('"'); - end; - end; -end; - - -{ Currently, this method will only resolve the entities which are - predefined in XML: } - -procedure TXMLReader.ResolveEntities(RootNode: TDOMNode); -var - Node, NextNode: TDOMNode; - - procedure ReplaceEntityRef(EntityNode: TDOMNode; const Replacement: String); - var - PrevSibling, NextSibling: TDOMNode; - begin - PrevSibling := EntityNode.PreviousSibling; - NextSibling := EntityNode.NextSibling; - if Assigned(PrevSibling) and (PrevSibling.NodeType = TEXT_NODE) then - begin - TDOMCharacterData(PrevSibling).AppendData(Replacement); - RootNode.RemoveChild(EntityNode); - if Assigned(NextSibling) and (NextSibling.NodeType = TEXT_NODE) then - begin - NextNode := NextSibling.NextSibling; - TDOMCharacterData(PrevSibling).AppendData( - TDOMCharacterData(NextSibling).Data); - RootNode.RemoveChild(NextSibling); - end - end else - if Assigned(NextSibling) and (NextSibling.NodeType = TEXT_NODE) then - begin - TDOMCharacterData(NextSibling).InsertData(0, Replacement); - RootNode.RemoveChild(EntityNode); - end else - RootNode.ReplaceChild(Doc.CreateTextNode(Replacement), EntityNode); - end; - -begin - Node := RootNode.FirstChild; - while Assigned(Node) do - begin - NextNode := Node.NextSibling; - if Node.NodeType = ENTITY_REFERENCE_NODE then - if Node.NodeName = 'amp' then - ReplaceEntityRef(Node, '&') - else if Node.NodeName = 'apos' then - ReplaceEntityRef(Node, '''') - else if Node.NodeName = 'gt' then - ReplaceEntityRef(Node, '>') - else if Node.NodeName = 'lt' then - ReplaceEntityRef(Node, '<') - else if Node.NodeName = 'quot' then - ReplaceEntityRef(Node, '"'); - Node := NextNode; - end; -end; - - - procedure ReadXMLFile(out ADoc: TXMLDocument; var f: File); -var - reader: TXMLReader; - buf: PChar; - BufSize: Int64; begin - ADoc := nil; - BufSize := FileSize(f) + 1; - if BufSize <= 1 then - exit; - - GetMem(buf, BufSize); - try - BlockRead(f, buf^, BufSize - 1); - buf[BufSize - 1] := #0; - Reader := TXMLReader.Create; - try - Reader.ProcessXML(buf, TFileRec(f).name); - finally - ADoc := TXMLDocument(Reader.doc); - Reader.Free; - end; - finally - FreeMem(buf); - end; -end; - -procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; const AFilename: String); -var - reader: TXMLReader; - buf: PChar; -begin - ADoc := nil; - if f.Size = 0 then exit; - - GetMem(buf, f.Size + 1); - try - f.Read(buf^, f.Size); - buf[f.Size] := #0; - Reader := TXMLReader.Create; - try - Reader.ProcessXML(buf, AFilename); - finally - ADoc := TXMLDocument(Reader.doc); - Reader.Free; - end; - finally - FreeMem(buf); - end; + laz2_XMLRead.ReadXMLFile(ADoc,f,xrfOldXMLRead); end; procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream); begin - ReadXMLFile(ADoc, f, ''); + laz2_XMLRead.ReadXMLFile(ADoc,f,xrfOldXMLRead); end; -procedure ReadXMLFile(out ADoc: TXMLDocument; const AFilename: String); -var - FileStream: TFileStream; - MemStream: TMemoryStream; +procedure ReadXMLFile(out ADoc: TXMLDocument; f: TStream; + const AFilename: String); begin - ADoc := nil; - FileStream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead or fmShareDenyWrite); - if FileStream = nil then exit; - MemStream := TMemoryStream.Create; - try - MemStream.LoadFromStream(FileStream); - ReadXMLFile(ADoc, MemStream, AFilename); - finally - FileStream.Free; - MemStream.Free; - end; + laz2_XMLRead.ReadXMLFile(ADoc,f,AFilename,xrfOldXMLRead); +end; + +procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String); +begin + laz2_XMLRead.ReadXMLFragment(AParentNode,AFilename,xrfOldXMLRead); end; procedure ReadXMLFragment(AParentNode: TDOMNode; var f: File); -var - Reader: TXMLReader; - buf: PChar; - BufSize: Int64; begin - BufSize := FileSize(f) + 1; - if BufSize <= 1 then - exit; - - GetMem(buf, BufSize); - try - BlockRead(f, buf^, BufSize - 1); - buf[BufSize - 1] := #0; - Reader := TXMLReader.Create; - try - Reader.Doc := AParentNode.OwnerDocument; - Reader.ProcessFragment(AParentNode, buf, TFileRec(f).name); - finally - Reader.Free; - end; - finally - FreeMem(buf); - end; -end; - -procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; const AFilename: String); -var - Reader: TXMLReader; - buf: PChar; -begin - if f.Size = 0 then - exit; - - GetMem(buf, f.Size + 1); - try - f.Read(buf^, f.Size); - buf[f.Size] := #0; - Reader := TXMLReader.Create; - Reader.Doc := AParentNode.OwnerDocument; - try - Reader.ProcessFragment(AParentNode, buf, AFilename); - finally - Reader.Free; - end; - finally - FreeMem(buf); - end; + laz2_XMLRead.ReadXMLFragment(AParentNode,f,xrfOldXMLRead); end; procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream); begin - ReadXMLFragment(AParentNode, f, ''); + laz2_XMLRead.ReadXMLFragment(AParentNode,f,xrfOldXMLRead); end; -procedure ReadXMLFragment(AParentNode: TDOMNode; const AFilename: String); -var - Stream: TStream; +procedure ReadXMLFragment(AParentNode: TDOMNode; var f: TStream; + const AFilename: String); begin - Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead or fmShareDenyWrite); - try - ReadXMLFragment(AParentNode, Stream, AFilename); - finally - Stream.Free; - end; + laz2_XMLRead.ReadXMLFragment(AParentNode,f,AFilename,xrfOldXMLRead); end; +procedure ReadDTDFile(var ADoc: TXMLDocument; const AFilename: String); +begin + laz2_XMLRead.ReadDTDFile(ADoc,AFilename); +end; procedure ReadDTDFile(var ADoc: TXMLDocument; var f: File); -var - Reader: TXMLReader; - buf: PChar; - BufSize: Int64; begin - ADoc := nil; - BufSize := FileSize(f) + 1; - if BufSize <= 1 then - exit; - - GetMem(buf, BufSize); - try - BlockRead(f, buf^, BufSize - 1); - buf[BufSize - 1] := #0; - Reader := TXMLReader.Create; - try - Reader.ProcessDTD(buf, TFileRec(f).name); - ADoc := TXMLDocument(Reader.doc); - finally - Reader.Free; - end; - finally - FreeMem(buf); - end; -end; - -procedure ReadDTDFile(var ADoc: TXMLDocument; var f: TStream; const AFilename: String); -var - Reader: TXMLReader; - buf: PChar; -begin - ADoc := nil; - if f.Size = 0 then - exit; - - GetMem(buf, f.Size + 1); - try - f.Read(buf^, f.Size); - buf[f.Size] := #0; - Reader := TXMLReader.Create; - try - Reader.ProcessDTD(buf, AFilename); - ADoc := TXMLDocument(Reader.doc); - finally - Reader.Free; - end; - finally - FreeMem(buf); - end; + laz2_XMLRead.ReadDTDFile(ADoc,f); end; procedure ReadDTDFile(var ADoc: TXMLDocument; var f: TStream); begin - ReadDTDFile(ADoc, f, ''); + laz2_XMLRead.ReadDTDFile(ADoc,f); end; -procedure ReadDTDFile(var ADoc: TXMLDocument; const AFilename: String); -var - Stream: TStream; +procedure ReadDTDFile(var ADoc: TXMLDocument; var f: TStream; + const AFilename: String); begin - ADoc := nil; - Stream := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead or fmShareDenyWrite); - try - ReadDTDFile(ADoc, Stream, AFilename); - finally - Stream.Free; - end; + laz2_XMLRead.ReadDTDFile(ADoc,f,AFilename); end; - end. diff --git a/components/lazutils/laz_xmlwrite.pas b/components/lazutils/laz_xmlwrite.pas index 50f500385e..8fe7cd57a8 100644 --- a/components/lazutils/laz_xmlwrite.pas +++ b/components/lazutils/laz_xmlwrite.pas @@ -1,28 +1,14 @@ -{ - $Id$ - This file is part of the Free Component Library - - XML writing routines - Copyright (c) 1999-2000 by Sebastian Guenther, sg@freepascal.org - - See the file COPYING.modifiedLGPL.txt, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - - unit Laz_XMLWrite; -{$MODE objfpc} -{$H+} +{$MODE objfpc}{$H+} +{$inline on} interface -uses Classes, LazUTF8, Laz_DOM; +uses Classes, laz2_XMLWrite, laz2_DOM; + +const + xwfOldXMLWrite = [xwfSpecialCharsInAttributeValue]; procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String); overload; procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text); overload; @@ -32,572 +18,36 @@ procedure WriteXML(Element: TDOMNode; const AFileName: String); overload; procedure WriteXML(Element: TDOMNode; var AFile: Text); overload; procedure WriteXML(Element: TDOMNode; AStream: TStream); overload; - -// =================================================================== - implementation -uses SysUtils; - -// ------------------------------------------------------------------- -// Writers for the different node types -// ------------------------------------------------------------------- - -procedure WriteElement(node: TDOMNode); forward; -procedure WriteAttribute(node: TDOMNode); forward; -procedure WriteText(node: TDOMNode); forward; -procedure WriteCDATA(node: TDOMNode); forward; -procedure WriteEntityRef(node: TDOMNode); forward; -procedure WriteEntity(node: TDOMNode); forward; -procedure WritePI(node: TDOMNode); forward; -procedure WriteComment(node: TDOMNode); forward; -procedure WriteDocument(node: TDOMNode); forward; -procedure WriteDocumentType(node: TDOMNode); forward; -procedure WriteDocumentFragment(node: TDOMNode); forward; -procedure WriteNotation(node: TDOMNode); forward; - -function NodeFrontIsText(Node: TDOMNode): boolean; -begin - Result:=(Node is TDOMText) or (Node.ParentNode is TDOMText) - or (Node.PreviousSibling is TDOMText); -end; - -function NodeAfterIsText(Node: TDOMNode): boolean; -begin - Result:=(Node is TDOMText) or (Node.ParentNode is TDOMText) - or (Node.NextSibling is TDOMText); -end; - -type - TWriteNodeProc = procedure(node: TDOMNode); - -const - WriteProcs: array[ELEMENT_NODE..NOTATION_NODE] of TWriteNodeProc = - (@WriteElement, @WriteAttribute, @WriteText, @WriteCDATA, @WriteEntityRef, - @WriteEntity, @WritePI, @WriteComment, @WriteDocument, @WriteDocumentType, - @WriteDocumentFragment, @WriteNotation); - LineEnd: shortstring = LineEnding; - -procedure WriteNode(node: TDOMNode); -begin - WriteProcs[node.NodeType](node); -end; - - -// ------------------------------------------------------------------- -// Text file and TStream support -// ------------------------------------------------------------------- - -type - TOutputProc = procedure(const Buffer; Count: Longint); - -threadvar - f: ^Text; - stream: TStream; - wrt, wrtln: TOutputProc; - -procedure Text_Write(const Buffer; Count: Longint); -var s: string; -begin - if Count>0 then begin - SetLength(s,Count); - System.Move(Buffer,s[1],Count); - Write(f^, s); - end; -end; - -procedure Text_WriteLn(const Buffer; Count: Longint); -var s: string; -begin - if Count>0 then begin - SetLength(s,Count); - System.Move(Buffer,s[1],Count); - writeln(f^, s); - end; -end; - -procedure Stream_Write(const Buffer; Count: Longint); -begin - if Count > 0 then begin - stream.Write(Buffer, Count); - end; -end; - -procedure Stream_WriteLn(const Buffer; Count: Longint); -begin - if Count > 0 then begin - stream.Write(Buffer, Count); - stream.Write(LineEnd[1],length(LineEnd)); - end; -end; - -procedure wrtStr(const s: string); -begin - if s<>'' then - wrt(s[1],length(s)); -end; - -procedure wrtStrLn(const s: string); -begin - if s<>'' then - wrtln(s[1],length(s)); -end; - -procedure wrtChr(c: char); -begin - wrt(c,1); -end; - -procedure wrtLineEnd; -begin - wrt(LineEnd[1],length(LineEnd)); -end; - -// ------------------------------------------------------------------- -// Indent handling -// ------------------------------------------------------------------- - -threadvar - Indent: String; - IndentCount: integer; - -procedure wrtIndent; -var i: integer; -begin - for i:=1 to IndentCount do - wrtStr(Indent); -end; - -procedure IncIndent; -begin - inc(IndentCount); -end; - -procedure DecIndent; -begin - if IndentCount>0 then dec(IndentCount); -end; - - -// ------------------------------------------------------------------- -// String conversion -// ------------------------------------------------------------------- - -type - TCharacters = set of Char; - TSpecialCharCallback = procedure(c: Char); - -const - AttrSpecialChars = ['<', '>', '"', '&']; - TextSpecialChars = ['<', '>', '&']; - - -procedure ConvWrite(const s: String; const SpecialChars: TCharacters; - const SpecialCharCallback: TSpecialCharCallback); -var - StartPos, EndPos: Integer; -begin - StartPos := 1; - EndPos := 1; - while EndPos <= Length(s) do - begin - if s[EndPos] in SpecialChars then - begin - wrt(s[StartPos],EndPos - StartPos); - SpecialCharCallback(s[EndPos]); - StartPos := EndPos + 1; - end; - Inc(EndPos); - end; - if StartPos <= length(s) then - wrt(s[StartPos], EndPos - StartPos); -end; - -procedure AttrSpecialCharCallback(c: Char); -const - QuotStr = '"'; - AmpStr = '&'; -begin - if c = '"' then - wrtStr(QuotStr) - else if c = '&' then - wrtStr(AmpStr) - else - wrt(c,1); -end; - -procedure TextnodeSpecialCharCallback(c: Char); -const - ltStr = '<'; - gtStr = '>'; - AmpStr = '&'; -begin - if c = '<' then - wrtStr(ltStr) - else if c = '>' then - wrtStr(gtStr) - else if c = '&' then - wrtStr(AmpStr) - else - wrt(c,1); -end; - - -// ------------------------------------------------------------------- -// Node writers implementations -// ------------------------------------------------------------------- - -procedure WriteElement(node: TDOMNode); -var - i: Integer; - attr, child: TDOMNode; - s: String; -begin - if not NodeFrontIsText(Node) then - wrtIndent; - wrtChr('<'); - wrtStr(node.NodeName); - if not (node.IsEmpty) then begin - for i := 0 to node.Attributes.Length - 1 do - begin - attr := node.Attributes.Item[i]; - wrtChr(' '); - wrtStr(attr.NodeName); - wrtChr('='); - s := attr.NodeValue; - // !!!: Replace special characters in "s" such as '&', '<', '>' - wrtChr('"'); - ConvWrite(s, AttrSpecialChars, @AttrSpecialCharCallback); - wrtChr('"'); - end; - end; - Child := node.FirstChild; - if Child = nil then begin - wrtChr('/'); - wrtChr('>'); - if not NodeAfterIsText(Node) then - wrtLineEnd; - end else - begin - wrtChr('>'); - if not ((Node is TDOMText) or (Node.ParentNode is TDOMText) or - (Child is TDOMText)) - then - wrtLineEnd; - IncIndent; - repeat - WriteNode(Child); - Child := Child.NextSibling; - until child = nil; - DecIndent; - if not ((Node is TDOMText) or (Node.ParentNode is TDOMText) or - (Node.LastChild is TDOMText)) - then - wrtIndent; - wrtChr('<'); - wrtChr('/'); - wrtStr(node.NodeName); - wrtChr('>'); - if not NodeAfterIsText(Node) then - wrtLineEnd; - end; -end; - -procedure WriteAttribute(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure WriteText(node: TDOMNode); -begin - ConvWrite(node.NodeValue, TextSpecialChars, @TextnodeSpecialCharCallback); - if node=nil then ; -end; - -procedure WriteCDATA(node: TDOMNode); -begin - if not NodeFrontIsText(Node) then - wrtStr('') - else begin - wrtIndent; - wrtStrln('') - end; -end; - -procedure WriteEntityRef(node: TDOMNode); -begin - wrtChr('&'); - wrtStr(node.NodeName); - wrtChr(';'); -end; - -procedure WriteEntity(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure WritePI(node: TDOMNode); -begin - if not NodeFrontIsText(Node) then wrtIndent; - wrtChr('<'); wrtChr('!'); - wrtStr(TDOMProcessingInstruction(node).Target); - wrtChr(' '); - wrtStr(TDOMProcessingInstruction(node).Data); - wrtChr('>'); - if not NodeAfterIsText(Node) then wrtLineEnd; -end; - -procedure WriteComment(node: TDOMNode); -begin - if not NodeFrontIsText(Node) then wrtIndent; - wrtStr(''); - if not NodeAfterIsText(Node) then wrtLineEnd; -end; - -procedure WriteDocument(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure WriteDocumentType(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure WriteDocumentFragment(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure WriteNotation(node: TDOMNode); -begin - if node=nil then ; -end; - -procedure InitWriter; -begin - SetLength(Indent, 0); -end; - -procedure RootWriter(doc: TXMLDocument); -var - Child: TDOMNode; -begin - InitWriter; - wrtStr(' 0 then - ConvWrite(doc.XMLVersion, AttrSpecialChars, @AttrSpecialCharCallback) - else - wrtStr('1.0'); - wrtChr('"'); - if Length(doc.Encoding) > 0 then - begin - wrtStr(' encoding="'); - ConvWrite(doc.Encoding, AttrSpecialChars, @AttrSpecialCharCallback); - wrtStr('"'); - end; - wrtStrln('?>'); - - if Length(doc.StylesheetType) > 0 then - begin - wrtStr(''); - end; - - Indent := ' '; - IndentCount := 0; - - child := doc.FirstChild; - while Assigned(Child) do - begin - WriteNode(Child); - Child := Child.NextSibling; - end; -end; - - -procedure WriteXMLMemStream(doc: TXMLDocument); -// internally used by the WriteXMLFile procedures -begin - Stream:=TMemoryStream.Create; - WriteXMLFile(doc,Stream); - Stream.Position:=0; -end; - -// ------------------------------------------------------------------- -// Interface implementation -// ------------------------------------------------------------------- - -{$IFDEF FPC} - // widestrings ansistring conversion is slow and we only use ansistring anyway - {off $DEFINE UsesFPCWidestrings} -{$ENDIF} - -{$IFDEF UsesFPCWidestrings} - -procedure SimpleWide2AnsiMove(source:pwidechar;dest:pchar;len:sizeint); -var - i : sizeint; -begin - for i:=1 to len do - begin - if word(source^)<256 then - dest^:=char(word(source^)) - else - dest^:='?'; - inc(dest); - inc(source); - end; -end; - -procedure SimpleAnsi2WideMove(source:pchar;dest:pwidechar;len:sizeint); -var - i : sizeint; -begin - for i:=1 to len do - begin - dest^:=widechar(byte(source^)); - inc(dest); - inc(source); - end; -end; - -const - WideStringManager: TWideStringManager = ( - Wide2AnsiMove: @SimpleWide2AnsiMove; - Ansi2WideMove: @SimpleAnsi2WideMove - ); - -{$ENDIF} - procedure WriteXMLFile(doc: TXMLDocument; const AFileName: String); -var - fs: TFileStream; begin - // write first to memory buffer and then as one whole block to file - WriteXMLMemStream(doc); - try - fs := TFileStream.Create(UTF8ToSys(AFileName), fmCreate); - fs.CopyFrom(Stream,Stream.Size); - fs.Free; - finally - Stream.Free; - end; + laz2_XMLWrite.WriteXMLFile(doc,AFileName,xwfOldXMLWrite); end; procedure WriteXMLFile(doc: TXMLDocument; var AFile: Text); -{$IFDEF UsesFPCWidestrings} -var - OldWideStringManager: TWideStringManager; -{$ENDIF} begin - {$IFDEF UsesFPCWidestrings} - SetWideStringManager(WideStringManager, OldWideStringManager); - try - {$ENDIF} - f := @AFile; - wrt := @Text_Write; - wrtln := @Text_WriteLn; - RootWriter(doc); - {$IFDEF UsesFPCWidestrings} - finally - SetWideStringManager(OldWideStringManager); - end; - {$ENDIF} + laz2_XMLWrite.WriteXMLFile(doc,AFile,xwfOldXMLWrite); end; procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream); -{$IFDEF UsesFPCWidestrings} -var - OldWideStringManager: TWideStringManager; -{$ENDIF} begin - {$IFDEF UsesFPCWidestrings} - SetWideStringManager(WideStringManager, OldWideStringManager); - try - {$ENDIF} - Stream := AStream; - wrt := @Stream_Write; - wrtln := @Stream_WriteLn; - RootWriter(doc); - {$IFDEF UsesFPCWidestrings} - finally - SetWideStringManager(OldWideStringManager); - end; - {$ENDIF} + laz2_XMLWrite.WriteXMLFile(doc,AStream,xwfOldXMLWrite); end; - procedure WriteXML(Element: TDOMNode; const AFileName: String); -{$IFDEF UsesFPCWidestrings} -var - OldWideStringManager: TWideStringManager; -{$ENDIF} begin - {$IFDEF UsesFPCWidestrings} - SetWideStringManager(WideStringManager, OldWideStringManager); - try - {$ENDIF} - Stream := TFileStream.Create(UTF8ToSys(AFileName), fmCreate); - wrt := @Stream_Write; - wrtln := @Stream_WriteLn; - InitWriter; - WriteNode(Element); - Stream.Free; - {$IFDEF UsesFPCWidestrings} - finally - SetWideStringManager(OldWideStringManager); - end; - {$ENDIF} + laz2_XMLWrite.WriteXML(Element,AFileName,xwfOldXMLWrite); end; procedure WriteXML(Element: TDOMNode; var AFile: Text); -{$IFDEF UsesFPCWidestrings} -var - OldWideStringManager: TWideStringManager; -{$ENDIF} begin - {$IFDEF UsesFPCWidestrings} - SetWideStringManager(WideStringManager, OldWideStringManager); - try - {$ENDIF} - f := @AFile; - wrt := @Text_Write; - wrtln := @Text_WriteLn; - InitWriter; - WriteNode(Element); - {$IFDEF UsesFPCWidestrings} - finally - SetWideStringManager(OldWideStringManager); - end; - {$ENDIF} + laz2_XMLWrite.WriteXML(Element,AFile,xwfOldXMLWrite); end; procedure WriteXML(Element: TDOMNode; AStream: TStream); -{$IFDEF UsesFPCWidestrings} -var - OldWideStringManager: TWideStringManager; -{$ENDIF} begin - {$IFDEF UsesFPCWidestrings} - SetWideStringManager(WideStringManager, OldWideStringManager); - try - {$ENDIF} - stream := AStream; - wrt := @Stream_Write; - wrtln := @Stream_WriteLn; - InitWriter; - WriteNode(Element); - {$IFDEF UsesFPCWidestrings} - finally - SetWideStringManager(OldWideStringManager); - end; - {$ENDIF} + laz2_XMLWrite.WriteXML(Element,AStream,xwfOldXMLWrite); end; end.