simplexml.pas

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

		varOleStr: Result := v.VOleStr;
		varBoolean: Result := BoolStr[v.VBoolean = True];
		varByte: Result := IntToStr(v.VByte);
 { TODO -oErik -cNot Define : Remov }
{
		varShortInt: Result := IntToStr(v.VShortInt);
		varWord: Result := IntToStr(v.VWord);
		varLongWord: Result := IntToStr(v.VLongWord);
		varInt64: Result := IntToStr(v.VInt64);
}
		varString: Result := String(v.VString);
		varArray + varByte:
			begin
				p := VarArrayLock(Variant(v));
				try
					Result := BinToBase64(p^, VarArrayHighBound(Variant(v), 1) - VarArrayLowBound(Variant(v), 1) + 1, 0);
				finally
					VarArrayUnlock(Variant(v))
				end
			end;
		else
			Result := Variant(v)
	end;
end;

procedure PrepareToSaveXml(var anElem: IXmlElement; const aChildName: String);
begin
	if aChildName <> '' then
		anElem := anElem.AppendElement(aChildName);
end;

function PrepareToLoadXml(var anElem: IXmlElement; const aChildName: String): Boolean;
begin
	if (aChildName <> '') and Assigned(anElem) then
		anElem := anElem.selectSingleNode(aChildName).AsElement;
	Result := Assigned(anElem);
end;

function LoadXMLResource(aModule: HMODULE; aName, aType: PChar; const aXMLDoc: IXmlDocument): boolean;
var
	aRSRC: HRSRC;
	aGlobal: HGLOBAL;
	aSize: DWORD;
	aPointer: Pointer;

	aStream: TStringStream;
begin
	Result := false;

	aRSRC := FindResource(aModule, aName, aType);
	if aRSRC <> 0 then begin
		aGlobal := LoadResource(aModule, aRSRC);
		aSize := SizeofResource(aModule, aRSRC);
		if (aGlobal <> 0) and (aSize <> 0) then begin
			aPointer := LockResource(aGlobal);
			if Assigned(aPointer) then begin
				aStream := TStringStream.Create('');
				try
					aStream.WriteBuffer(aPointer^, aSize);
					aXMLDoc.LoadXML(aStream.DataString);
					Result := true;
				finally
					aStream.Free;
				end;
			end;
		end;
	end;
end;

function IsXmlDataString(const aData: String): Boolean;
var
	i: Integer;
begin
	Result := Copy(aData, 1, BinXmlSignatureSize) = BinXmlSignature;
	if not Result then begin
		i := 1;
		while (i <= Length(aData)) and (aData[i] in [#10, #13, #9, ' ']) do
			Inc(i);
		Result := Copy(aData, i, Length('<?xml ')) = '<?xml ';
	end;
end;

function XmlIsInBinaryFormat(const aData: String): Boolean;
begin
	Result := Copy(aData, 1, BinXmlSignatureSize) = BinXmlSignature
end;

var
	Base64Map: array [0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

type
	PChars = ^TChars;
	TChars = packed record a, b, c, d: Char end;
	POctet = ^TOctet;
	TOctet = packed record a, b, c: Byte; end;

procedure OctetToChars(po: POctet; aCount: Integer; pc: PChars);
var
	o: Integer;
begin
	if aCount = 1 then begin
		o := po.a shl 16;
		LongWord(pc^) := $3D3D3D3D;
		pc.a := Base64Map[(o shr 18) and $3F];
		pc.b := Base64Map[(o shr 12) and $3F];
	end
	else if aCount = 2 then begin
		o := po.a shl 16 or po.b shl 8;
		LongWord(pc^) := $3D3D3D3D;
		pc.a := Base64Map[(o shr 18) and $3F];
		pc.b := Base64Map[(o shr 12) and $3F];
		pc.c := Base64Map[(o shr 6) and $3F];
	end
	else if aCount > 2 then begin
		o := po.a shl 16 or po.b shl 8 or po.c;
		LongWord(pc^) := $3D3D3D3D;
		pc.a := Base64Map[(o shr 18) and $3F];
		pc.b := Base64Map[(o shr 12) and $3F];
		pc.c := Base64Map[(o shr 6) and $3F];
		pc.d := Base64Map[o and $3F];
	end;
end;

function BinToBase64(const aBin; aSize, aMaxLineLength: Integer): String;
var
	o: POctet;
	c: PChars;
	aCount: Integer;
	i: Integer;
begin
	o := @aBin;
	aCount := aSize;
	SetLength(Result, ((aCount + 2) div 3)*4);
	c := PChars(Result);
	while aCount > 0 do begin
		OctetToChars(o, aCount, c);
		Inc(o);
		Inc(c);
		Dec(aCount, 3);
	end;
	if aMaxLineLength > 0 then begin
		i := aMaxLineLength;
		while i <= Length(Result) do begin
			Insert(#13#10, Result, i);
			Inc(i, 2 + aMaxLineLength);
		end
	end;
end;

function CharTo6Bit(c: Char): Byte;
begin
	if (c >= 'A') and (c <= 'Z') then
		Result := Ord(c) - Ord('A')
	else if (c >= 'a') and (c <= 'z') then
		Result := Ord(c) - Ord('a') + 26
	else if (c >= '0') and (c <= '9') then
		Result := Ord(c) - Ord('0') + 52
	else if c = '+' then
		Result := 62
	else if c = '/' then
		Result := 63
	else
		Result := 0
end;

procedure CharsToOctet(c: PChars; o: POctet);
var
	i: Integer;
begin
	if c.c = '=' then begin // 1 byte
		i := CharTo6Bit(c.a) shl 18 or CharTo6Bit(c.b) shl 12;
		o.a := (i shr 16) and $FF;
	end
	else if c.d = '=' then begin // 2 bytes
		i := CharTo6Bit(c.a) shl 18 or CharTo6Bit(c.b) shl 12 or CharTo6Bit(c.c) shl 6;
		o.a := (i shr 16) and $FF;
		o.b := (i shr 8) and $FF;
	end
	else begin // 3 bytes
		i := CharTo6Bit(c.a) shl 18 or CharTo6Bit(c.b) shl 12 or CharTo6Bit(c.c) shl 6 or CharTo6Bit(c.d);
		o.a := (i shr 16) and $FF;
		o.b := (i shr 8) and $FF;
		o.c := i and $FF;
	end;
end;

function Base64ToBin(const aBase64: String): String;
var
	o: POctet;
	c: PChars;
	aCount: Integer;
	s: String;
	i, j: Integer;
begin
	s := aBase64;
	i := 1;
	while i <= Length(s) do begin
		while (i <= Length(s)) and (s[i] > ' ') do
			Inc(i);
		if i <= Length(s) then begin
			j := i;
			while (j <= Length(s)) and (s[j] <= ' ') do
				Inc(j);
			Delete(s, i, j - i);
		end;
	end;

	if Length(s) < 4 then
		Result := ''
	else begin
		aCount := ((Length(s) + 3) div 4)*3;
		if aCount > 0 then begin
			if s[Length(s) - 1] = '=' then
				Dec(aCount, 2)
			else if s[Length(s)] = '=' then
				Dec(aCount);
			SetLength(Result, aCount);
			FillChar(Result[1], aCount, '*');
			c := @s[1];
			o := @Result[1];
			while aCount > 0 do begin
				CharsToOctet(c, o);
				Inc(o);
				Inc(c);
				Dec(aCount, 3);
			end;
		end;
	end;
end;


type
	TBinXmlReader = class
	private
		FOptions: LongWord;
	public
		procedure Read(var aBuf; aSize: Integer); virtual; abstract;
		 
		function ReadLongint: Longint;
		function ReadAnsiString: String;
		function ReadWideString: WideString;
		function ReadXmlString: TXmlString;
		procedure ReadVariant(var v: TVarData);
	end;

	TStmXmlReader = class(TBinXmlReader)
	private
		FStream: TStream;
		FOptions: LongWord;
		FBufStart,
		FBufEnd,
		FBufPtr: PChar;
		FBufSize,
		FRestSize: Integer;
	public
		constructor Create(aStream: TStream; aBufSize: Integer);
		destructor Destroy; override;

		procedure Read(var aBuf; aSize: Integer); override;
	end;

	TStrXmlReader = class(TBinXmlReader)
	private
		FString: String;
		FOptions: LongWord;
		FPtr: PChar;
		FRestSize: Integer;
	public
		constructor Create(const aStr: String);

		procedure Read(var aBuf; aSize: Integer); override;
	end;

	TBinXmlWriter = class
	private
		FOptions: LongWord;
	public
		procedure Write(const aBuf; aSize: Integer); virtual; abstract;
		
		procedure WriteLongint(aValue: Longint);
		procedure WriteAnsiString(const aValue: String);
		procedure WriteWideString(const aValue: WideString);
		procedure WriteXmlString(const aValue: TXmlString);
		procedure WriteVariant(const v: TVarData);
	end;

	TStmXmlWriter = class(TBinXmlWriter)
	private
		FStream: TStream;
		FBufStart,
		FBufEnd,
		FBufPtr: PChar;
		FBufSize: Integer;
	public
		constructor Create(aStream: TStream; anOptions: LongWord; aBufSize: Integer);
		destructor Destroy; override;

		procedure Write(const aBuf; aSize: Integer); override;
	end;

	TStrXmlWriter = class(TBinXmlWriter)
	private
		FData: String;
		FBufStart,
		FBufEnd,
		FBufPtr: PChar;
		FBufSize: Integer;
    procedure FlushBuf;
	public
		constructor Create(anOptions: LongWord; aBufSize: Integer);
		destructor Destroy; override;

		procedure Write(const aBuf; aSize: Integer); override;
	end;
	
	TXmlBase = class(TInterfacedObject, IXmlBase)
	protected
 		function GetObject: TObject;
	public
	end;

	PNameIndexArray = ^TNameIndexArray;
	TNameIndexArray = array of Longint;
	TXmlNameTable = class(TXmlBase, IXmlNameTable)
	private
		FNames: array of TXmlString;
		FHashTable: array of TNameIndexArray;

		FXmlTextNameID: Integer;
		FXmlCDATASectionNameID: Integer;
		FXmlCommentNameID: Integer;
		FXmlDocumentNameID: Integer;
		FXmlID: Integer;
	protected
		function GetID(const aName: TXmlString): Integer;
		function GetName(anID: Integer): TXmlString;
	public
		constructor Create(aHashTableSize: Integer);

		procedure LoadBinXml(aReader: TBinXmlReader);
		procedure SaveBinXml(aWriter: TBinXmlWriter);
	end;

{ TXmlBase }

function TXmlBase.GetObject: TObject;
begin
	Result := Self;
end;

{ TXmlNameTable }

constructor TXmlNameTable.Create(aHashTableSize: Integer);
begin
	inherited Create;
	SetLength(FHashTable, aHashTableSize);
	FXmlTextNameID := GetID('#text');
	FXmlCDATASectionNameID := GetID('#cdata-section');
	FXmlCommentNameID := GetID('#comment');
	FXmlDocumentNameID := GetID('#document');
	FXmlID := GetID('xml');
end;

procedure TXmlNameTable.LoadBinXml(aReader: TBinXmlReader);
var
	aCount: LongInt;
	anIndex, i: Integer;
begin
	// 痒栩囹?爨耨桠 桁屙
	aCount := aReader.ReadLongint;
	SetLength(FNames, aCount);
	for i := 0 to aCount - 1 do 
		FNames[i] := aReader.ReadXmlString;

	// 痒栩囹?觚?蜞犭桷?
	SetLength(FHashTable, aReader.ReadLongint);
	for i := 0 to Length(FHashTable) - 1 do
		SetLength(FHashTable[i], 0);
	aCount := aReader.ReadLongint;
	for i := 0 to aCount - 1 do begin
		anIndex := aReader.ReadLongInt;
		SetLength(FHashTable[anIndex], aReader.ReadLongInt);
		aReader.Read(FHashTable[anIndex][0], Length(FHashTable[anIndex])*sizeof(Longint));
	end;
end;

procedure TXmlNameTable.SaveBinXml(aWriter: TBinXmlWriter);
var
	aCount: LongInt;
	i: Integer;
begin
	// 青镨襦螯 爨耨桠 桁屙
	aCount := Length(FNames);
	aWriter.WriteLongint(aCount);
	for i := 0 to aCount - 1 do 
		aWriter.WriteXmlString(FNames[i]);

	// 青镨襦螯 觚?蜞犭桷?
	aWriter.WriteLongint(Length(FHashTable));
	aCount := 0;
	for i := 0 to Length(FHashTable) - 1 do 
		if Length(FHashTable[i]) > 0 then
			Inc(aCount);
	aWriter.WriteLongint(aCount);
	for i := 0 to Length(FHashTable) - 1 do begin
		aCount := Length(FHashTable[i]);
		if aCount > 0 then begin
			aWriter.WriteLongint(i);
			aWriter.WriteLongint(aCount);
			aWriter.Write(FHashTable[i][0], aCount*sizeof(Longint));
		end
	end;
end;

function TXmlNameTable.GetID(const aName: TXmlString): Integer;

	function NameHashKey(const aName: TXmlString): UINT;
	var
		i: Integer;
	begin
		Result := 0;
		for i := 1 to Length(aName) do
			Result := UINT((int64(Result) shl 5) + Result + Ord(aName[i]));
	end;
	
var
	i: Integer;
	aNameIndexes: PNameIndexArray;
begin
	if aName = '' then
		Result := -1
	else begin
		aNameIndexes := @FHashTable[NameHashKey(aName) mod UINT(Length(FHashTable))];
		for i := 0 to Length(aNameIndexes^) - 1 do begin
			Result := aNameIndexes^[i];
			if FNames[Result] = aName then
				Exit
		end;
		Result := Length(FNames);
		SetLength(FNames, Result + 1);
		FNames[Result] := aName;

		SetLength(aNameIndexes^, Length(aNameIndexes^) + 1);
		aNameIndexes^[Length(aNameIndexes^) - 1] := Result;
	end;
end;

function TXmlNameTable.GetName(anID: Integer): TXmlString;
begin
	if anID < 0 then
		Result := ''
	else
		Result := FNames[anID]