simplexml.pas

delphi 环境下 XML解析引擎, 支持SAX,速度飞快,共享出来了

unit SimpleXML;

interface

uses
	Windows, SysUtils, Classes,Variants;

const
	BinXmlSignatureSize = Length('< binary-xml >');
	BinXmlSignature: String = '< binary-xml >';

	BINXML_USE_WIDE_CHARS = 1;
	BINXML_COMPRESSED = 2;

	XSTR_NULL = '{{null}}';
	
	NODE_INVALID = $00000000;
	NODE_ELEMENT = $00000001;
	NODE_ATTRIBUTE = $00000002;
	NODE_TEXT = $00000003;
	NODE_CDATA_SECTION = $00000004;
	NODE_ENTITY_REFERENCE = $00000005;
	NODE_ENTITY = $00000006;
	NODE_PROCESSING_INSTRUCTION = $00000007;
	NODE_COMMENT = $00000008;
	NODE_DOCUMENT = $00000009;
	NODE_DOCUMENT_TYPE = $0000000A;
	NODE_DOCUMENT_FRAGMENT = $0000000B;
	NODE_NOTATION = $0000000C;

type
	{ $DEFINE XML_WIDE_CHARS}

	{$IFDEF XML_WIDE_CHARS}
	PXmlChar = PWideChar;
	TXmlChar = WideChar;
	TXmlString = WideString;
	{$ELSE}
	PXmlChar = PChar;
	TXmlChar = Char;
	TXmlString = String;
	{$ENDIF}

	IXmlDocument = interface;
	IXmlElement = interface;
	IXmlText = interface;
	IXmlCDATASection = interface;
	IXmlComment = interface;
	IXmlProcessingInstruction = interface;


	IXmlBase = interface
		function GetObject: TObject;
	end;

	IXmlNameTable = interface(IXmlBase)
		function GetID(const aName: TXmlString): Integer;
		function GetName(anID: Integer): TXmlString;
	end;

	IXmlNode = interface;
	IXmlNodeList = interface(IXmlBase)
 		function Get_Count: Integer;
 		function Get_Item(anIndex: Integer): IXmlNode;
 		function Get_XML: TXmlString;

		property Count: Integer read Get_Count;
		property Item[anIndex: Integer]: IXmlNode read Get_Item; default;
		property XML: TXmlString read Get_XML;
	end;

 	IXmlNode = interface(IXmlBase)
 		function Get_NameTable: IXmlNameTable;
 		function Get_NodeName: TXmlString;
 		function Get_NodeNameID: Integer;
 		function Get_NodeType: Integer;
 		function Get_Text: TXmlString;
 		procedure Set_Text(const aValue: TXmlString);
 		function Get_DataType: Integer;
 		function Get_TypedValue: Variant;
 		procedure Set_TypedValue(const aValue: Variant);
    function Get_XML: TXmlString;
		function CloneNode(aDeep: Boolean = True): IXmlNode;

		function Get_ParentNode: IXmlNode;
		function Get_OwnerDocument: IXmlDocument;

		function Get_ChildNodes: IXmlNodeList;
		procedure AppendChild(const aChild: IXmlNode);
		procedure InsertBefore(const aChild, aBefore: IXmlNode);
		procedure ReplaceChild(const aNewChild, anOldChild: IXmlNode);
		procedure RemoveChild(const aChild: IXmlNode);

		function AppendElement(aNameID: Integer): IXmlElement; overload;
		function AppendElement(const aName: TxmlString): IXmlElement; overload;

		function AppendText(const aData: TXmlString): IXmlText;

		function AppendCDATA(const aData: TXmlString): IXmlCDATASection;

		function AppendComment(const aData: TXmlString): IXmlComment;

		function AppendProcessingInstruction(aTargetID: Integer;
			const aData: TXmlString): IXmlProcessingInstruction; overload;
		function AppendProcessingInstruction(const aTarget: TXmlString;
			const aData: TXmlString): IXmlProcessingInstruction; overload;

		function GetChildText(const aName: TXmlString; const aDefault: TXmlString = ''): TXmlString; overload;
		function GetChildText(aNameID: Integer; const aDefault: TXmlString = ''): TXmlString; overload;
		procedure SetChildText(const aName, aValue: TXmlString); overload;
		procedure SetChildText(aNameID: Integer; const aValue: TXmlString); overload;

		function NeedChild(aNameID: Integer): IXmlNode; overload;
		function NeedChild(const aName: TXmlString): IXmlNode; overload;

		function EnsureChild(aNameID: Integer): IXmlNode; overload;
		function EnsureChild(const aName: TXmlString): IXmlNode; overload;

		procedure RemoveAllChilds;

		function SelectNodes(const anExpression: TXmlString): IXmlNodeList;
		function SelectSingleNode(const anExpression: TXmlString): IXmlNode;
		function FindElement(const anElementName, anAttrName: String; const anAttrValue: Variant): IXmlElement;

		function Get_AttrCount: Integer;
		function Get_AttrNameID(anIndex: Integer): Integer;
		function Get_AttrName(anIndex: Integer): TXmlString;
		procedure RemoveAttr(const aName: TXmlString); overload;
		procedure RemoveAttr(aNameID: Integer); overload;
		procedure RemoveAllAttrs;

		function AttrExists(aNameID: Integer): Boolean; overload;
		function AttrExists(const aName: TXmlString): Boolean; overload;

		function GetAttrType(aNameID: Integer): Integer; overload;
		function GetAttrType(const aName: TXmlString): Integer; overload;

		function GetVarAttr(aNameID: Integer; const aDefault: Variant): Variant; overload;
		function GetVarAttr(const aName: TXmlString; const aDefault: Variant): Variant; overload;
		procedure SetVarAttr(aNameID: Integer; const aValue: Variant); overload;
		procedure SetVarAttr(const aName: TXmlString; aValue: Variant); overload;

		function NeedAttr(aNameID: Integer): TXmlString; overload;
		function NeedAttr(const aName: TXmlString): TXmlString; overload;

		function GetAttr(aNameID: Integer; const aDefault: TXmlString = ''): TXmlString; overload;
		function GetAttr(const aName: TXmlString; const aDefault: TXmlString = ''): TXmlString; overload;
		procedure SetAttr(aNameID: Integer; const aValue: TXmlString); overload;
		procedure SetAttr(const aName, aValue: TXmlString); overload;

		function GetBoolAttr(aNameID: Integer; aDefault: Boolean = False): Boolean; overload;
		function GetBoolAttr(const aName: TXmlString; aDefault: Boolean = False): Boolean; overload;
		procedure SetBoolAttr(aNameID: Integer; aValue: Boolean = False); overload;
		procedure SetBoolAttr(const aName: TXmlString; aValue: Boolean); overload;

		function GetIntAttr(aNameID: Integer; aDefault: Integer = 0): Integer; overload;
		function GetIntAttr(const aName: TXmlString; aDefault: Integer = 0): Integer; overload;
		procedure SetIntAttr(aNameID: Integer; aValue: Integer); overload;
		procedure SetIntAttr(const aName: TXmlString; aValue: Integer); overload;

		function GetDateTimeAttr(aNameID: Integer; aDefault: TDateTime = 0): TDateTime; overload;
		function GetDateTimeAttr(const aName: TXmlString; aDefault: TDateTime = 0): TDateTime; overload;
		procedure SetDateTimeAttr(aNameID: Integer; aValue: TDateTime); overload;
		procedure SetDateTimeAttr(const aName: TXmlString; aValue: TDateTime); overload;

		function GetFloatAttr(aNameID: Integer; aDefault: Double = 0): Double; overload;
		function GetFloatAttr(const aName: TXmlString; aDefault: Double = 0): Double; overload;
		procedure SetFloatAttr(aNameID: Integer; aValue: Double); overload;
		procedure SetFloatAttr(const aName: TXmlString; aValue: Double); overload;

		function GetHexAttr(const aName: TXmlString; aDefault: Integer = 0): Integer; overload;
		function GetHexAttr(aNameID: Integer; aDefault: Integer = 0): Integer; overload;
		procedure SetHexAttr(const aName: TXmlString; aValue: Integer; aDigits: Integer = 8); overload;
		procedure SetHexAttr(aNameID: Integer; aValue: Integer; aDigits: Integer = 8); overload;

		function GetEnumAttr(const aName: TXmlString;
			const aValues: array of TXmlString; aDefault: Integer = 0): Integer; overload;
		function GetEnumAttr(aNameID: Integer;
			const aValues: array of TXmlString; aDefault: Integer = 0): Integer; overload;

		function NeedEnumAttr(const aName: TXmlString;
			const aValues: array of TXmlString): Integer; overload;
		function NeedEnumAttr(aNameID: Integer;
			const aValues: array of TXmlString): Integer; overload;

		function Get_Values(const aName: String): Variant;
		procedure Set_Values(const aName: String; const aValue: Variant);

		function AsElement: IXmlElement;
		function AsText: IXmlText;
		function AsCDATASection: IXmlCDATASection;
		function AsComment: IXmlComment;
		function AsProcessingInstruction: IXmlProcessingInstruction;

		property NodeName: TXmlString read Get_NodeName;
		property NodeNameID: Integer read Get_NodeNameID;
		property NodeType: Integer read Get_NodeType;
		property ParentNode: IXmlNode read Get_ParentNode;
		property OwnerDocument: IXmlDocument read Get_OwnerDocument;
		property NameTable: IXmlNameTable read Get_NameTable;
		property ChildNodes: IXmlNodeList read Get_ChildNodes;
		property AttrCount: Integer read Get_AttrCount;
		property AttrNames[anIndex: Integer]: TXmlString read Get_AttrName;
		property AttrNameIDs[anIndex: Integer]: Integer read Get_AttrNameID;
		property Text: TXmlString read Get_Text write Set_Text;
		property DataType: Integer read Get_DataType;
		property TypedValue: Variant read Get_TypedValue write Set_TypedValue;
		property XML: TXmlString read Get_XML;
		property Values[const aName: String]: Variant read Get_Values write Set_Values; default;
	end;

	IXmlElement = interface(IXmlNode)
		procedure ReplaceTextByCDATASection(const aText: TXmlString);

		procedure ReplaceTextByBynaryData(const aData; aSize: Integer;
			aMaxLineLength: Integer);

		function GetTextAsBynaryData: TXmlString;

	end;

	IXmlCharacterData = interface(IXmlNode)
	end;

	IXmlText = interface(IXmlCharacterData)
	end;

	IXmlCDATASection = interface(IXmlCharacterData)
	end;

	IXmlComment = interface(IXmlCharacterData)
	end;

	IXmlProcessingInstruction = interface(IXmlNode)
	end;

	IXmlDocument = interface(IXmlNode)
		function Get_DocumentElement: IXmlElement;
		function Get_BinaryXML: String;
		function Get_PreserveWhiteSpace: Boolean;
		procedure Set_PreserveWhiteSpace(aValue: Boolean);

		function NewDocument(const aVersion, anEncoding: TXmlString;
			aRootElementNameID: Integer): IXmlElement; overload;
		function NewDocument(const aVersion, anEncoding,
			aRootElementName: TXmlString): IXmlElement; overload;

		function CreateElement(aNameID: Integer): IXmlElement; overload;
		function CreateElement(const aName: TXmlString): IXmlElement; overload;
		function CreateText(const aData: TXmlString): IXmlText;
		function CreateCDATASection(const aData: TXmlString): IXmlCDATASection;
		function CreateComment(const aData: TXmlString): IXmlComment;
		function CreateProcessingInstruction(const aTarget,
			aData: TXmlString): IXmlProcessingInstruction; overload;
		function CreateProcessingInstruction(aTargetID: Integer;
			const aData: TXmlString): IXmlProcessingInstruction; overload;

		procedure LoadXML(const aXML: TXmlString);
		procedure LoadBinaryXML(const aXML: String);

		procedure Load(aStream: TStream); overload;
		procedure Load(const aFileName: TXmlString); overload;

		procedure LoadResource(aType, aName: PChar);

		procedure Save(aStream: TStream); overload;
		procedure Save(const aFileName: TXmlString); overload;

		procedure SaveBinary(aStream: TStream; anOptions: LongWord = 0); overload;
		procedure SaveBinary(const aFileName: TXmlString; anOptions: LongWord = 0); overload;

		property PreserveWhiteSpace: Boolean read Get_PreserveWhiteSpace write Set_PreserveWhiteSpace;
		property DocumentElement: IXmlElement read Get_DocumentElement;
		property BinaryXML: String read Get_BinaryXML;
	end;

function CreateNameTable(aHashTableSize: Integer = 4096): IXmlNameTable;
function CreateXmlDocument(
	const aRootElementName: String = '';
	const aVersion: String = '1.0';
	const anEncoding: String = ''; // SimpleXmlDefaultEncoding
	const aNames: IXmlNameTable = nil): IXmlDocument;

function CreateXmlElement(const aName: TXmlString; const aNameTable: IXmlNameTable = nil): IXmlElement;
function LoadXmlDocumentFromXML(const aXML: TXmlString): IXmlDocument;
function LoadXmlDocumentFromBinaryXML(const aXML: String): IXmlDocument;

function LoadXmlDocument(aStream: TStream): IXmlDocument; overload;
function LoadXmlDocument(const aFileName: TXmlString): IXmlDocument; overload;
function LoadXmlDocument(aResType, aResName: PChar): IXmlDocument; overload;


var
	DefaultNameTable: IXmlNameTable = nil;
	DefaultPreserveWhiteSpace: Boolean = False;
	DefaultEncoding: String = 'windows-1251';
	DefaultIndentText: String = ^I;

resourcestring
	SSimpleXmlError1 = 'Error1';
	SSimpleXmlError2 = 'Error2';
	SSimpleXmlError3 = 'Error3';
	SSimpleXmlError4 = 'Error4';
	SSimpleXmlError5 = 'Error5';
	SSimpleXmlError6 = '%s%s".'^M^J +^M^J +'%s';
	SSimpleXmlError7 = 'Error07,"%s"';
	SSimpleXmlError8 = 'Error08 ,"%s"';
	SSimpleXmlError9 = 'Error09';
	SSimpleXmlError10 ='Error10';
	SSimpleXmlError11 ='不是XML格式的文件';
	SSimpleXmlError12 = 'Error12';
	SSimpleXmlError13 = 'Error13';
	SSimpleXmlError14 = 'Error14';
	SSimpleXmlError15 = 'Error15';
	SSimpleXmlError16 = '存在非法字符 "%c"';
	SSimpleXmlError17 = '不是有效的XML文件';
	SSimpleXmlError18 = 'Error18';
	SimpleXmlError19 =  'Error19 "%s"';
	SSimpleXmlError20 = 'Error20';
	SSimpleXmlError21 = 'Error21';
	SimpleXmlError22 =  'Error22';
	SSimpleXmlError23 = 'Error23';
	SSimpleXmlError24 = 'Error24';
	SSimpleXmlError25 = 'Error25';

function XSTRToFloat(s: TXmlString): Double;
function FloatToXSTR(v: Double): TXmlString;
function DateTimeToXSTR(v: TDateTime): TXmlString;
function VarToXSTR(const v: TVarData): TXmlString;

function TextToXML(const aText: TXmlString): TXmlString;
function BinToBase64(const aBin; aSize, aMaxLineLength: Integer): String;
function Base64ToBin(const aBase64: String): String;
function IsXmlDataString(const aData: String): Boolean;
function XmlIsInBinaryFormat(const aData: String): Boolean;
procedure PrepareToSaveXml(var anElem: IXmlElement; const aChildName: String);
function PrepareToLoadXml(var anElem: IXmlElement; const aChildName: String): Boolean;

implementation

uses
	Emulate;

function TextToXML(const aText: TXmlString): TXmlString;
var
	i, j: Integer;
begin
	j := 0;
	for i := 1 to Length(aText) do
		case aText[i] of
			'<', '>': Inc(j, 4);
			'&': Inc(j, 5);
			'"': Inc(j, 6);
			else
				Inc(j);
		end;
	if j = Length(aText) then
		Result := aText
	else begin
		SetLength(Result, j);
		j := 1;
		for i := 1 to Length(aText) do
			case aText[i] of
				'<': begin Move(PChar('&lt;')^, Result[j], 4); Inc(j, 4) end;
				'>': begin Move(PChar('&gt;')^, Result[j], 4); Inc(j, 4) end;
				'&': begin Move(PChar('&amp;')^, Result[j], 5); Inc(j, 5) end;
				'"': begin Move(PChar('&quot;')^, Result[j], 6); Inc(j, 6) end;
				else begin Result[j] := aText[i]; Inc(j) end;
			end;
	end;
end;

function XSTRToFloat(s: TXmlString): Double;
var
	aPos: Integer;
begin
	if '.' = DecimalSeparator then
		aPos := Pos(',', s)
	else if ',' = DecimalSeparator then
		aPos := Pos('.', s)
	else begin
		aPos := Pos(',', s);
		if aPos = 0 then
			aPos := Pos('.', s);
	end;

	if aPos <> 0 then
		s[aPos] := TXmlChar(DecimalSeparator);
	Result := StrToFloat(s);
end;

function FloatToXSTR(v: Double): TXmlString;
var
	aPos: Integer;
begin
	Result := FloatToStr(v);
	aPos := Pos(DecimalSeparator, Result);
	if aPos <> 0 then
		Result[aPos] := '.';
end;

function XSTRToDateTime(const s: String): TDateTime;
var
	aPos: Integer;

	function FetchTo(aStop: Char): Integer;
	var
		i: Integer;
	begin
		i := aPos;
		while (i <= Length(s)) and (s[i] in ['0'..'9']) do
			Inc(i);
		if i > aPos then
			Result := StrToInt(Copy(s, aPos, i - aPos))
		else
			Result := 0;
		if (i <= Length(s)) and (s[i] = aStop) then
			aPos := i + 1
		else
			aPos := Length(s) + 1;
	end;

var
	y, m, d, h, n, ss: Integer;
begin
	aPos := 1;
	y := FetchTo('-'); m := FetchTo('-'); d := FetchTo('T');
	h := FetchTo('-'); n := FetchTo('-'); ss := FetchTo('-');
	Result := EncodeDateTime(y, m, d, h, n, ss, 0);
end;

function DateTimeToXSTR(v: TDateTime): TXmlString;
var
	y, m, d, h, n, s, ms: Word;
begin
	DecodeDateTime(v, y, m, d, h, n, s, ms);
	Result := Format('%.4d-%.2d-%.2dT%.2d-%.2d-%.2d', [y, m, d, h, n, s])
end;

function VarToXSTR(const v: TVarData): TXmlString;
const
	BoolStr: array[Boolean] of TXmlString = ('0', '1');
var
	p: Pointer;
begin
	case v.VType of
		varNull: Result := XSTR_NULL;
		varSmallint: Result := IntToStr(v.VSmallInt);
		varInteger: Result := IntToStr(v.VInteger);
		varSingle: Result := FloatToXSTR(v.VSingle);
		varDouble: Result := FloatToXSTR(v.VDouble);
		varCurrency: Result := FloatToXSTR(v.VCurrency);
		varDate: Result := DateTimeToXSTR(v.VDate);