ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/branches/udr/client/IBUtils.pas

Comparing:
ibx/trunk/fbintf/IBUtils.pas (file contents), Revision 311 by tony, Mon Aug 24 09:32:58 2020 UTC vs.
ibx/branches/journaling/fbintf/IBUtils.pas (file contents), Revision 363 by tony, Tue Dec 7 13:30:05 2021 UTC

#	Line 39 | Line 39 | unit IBUtils;
39		{$IFDEF FPC}
40		{$Mode Delphi}
41		{$codepage UTF8}
42	–	{$define HASREQEX}
42		{$ENDIF}
43
44	+	{ $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45	+	{ $define HASDELPHIREQEX}
46	+	{ $IFEND}
47
48		interface
49
50		uses Classes, SysUtils, IB;
51
52	+	{$IF not defined(LineEnding)}
53	+	const
54	+	{$IFDEF WINDOWS}
55	+	LineEnding = #$0D#$0A;
56	+	{$ELSE}
57	+	LineEnding = #$0A;
58	+	{$ENDIF}
59	+	{$IFEND}
60	+
61		type
62		TSQLTokens = (
63
#	Line 299 | Line 310 | const
310		TAB  = #9;
311		NULL_TERMINATOR = #0;
312
302	–	{$IFNDEF FPC}
303	–	LineEnding = CRLF;
304	–	{$ENDIF}
305	–
313		{SQL Reserved words in alphabetical order}
314
315		sqlReservedWords: array [TSQLReservedWords] of string = (
#	Line 556 | Line 563 | type
563		function TokenFound(var token: TSQLTokens): boolean; virtual;
564		function InternalGetNextToken: TSQLTokens; virtual;
565		procedure Reset; virtual;
566	+	function ReadCharacters(NumOfChars: integer): AnsiString;
567
568		{Token stack}
569		procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
#	Line 612 | Line 620 | type
620		var slNames: TStrings): AnsiString;
621		end;
622
623	+	TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
624	+
625	+	{ TSQLXMLReader - used to save and read back blob and array data in a pseudo XML format}
626	+
627	+	TSQLXMLReader = class(TSQLTokeniser)
628	+	private
629	+	type
630	+	TXMLStates =  (stNoXML, stInTag,stInTagBody,
631	+	stAttribute,stAttributeValue,stQuotedAttributeValue,
632	+	stInEndTag, stInEndTagBody,
633	+	stXMLData);
634	+
635	+	TXMLTag    =   (xtNone,xtBlob,xtArray,xtElt);
636	+
637	+	TXMLTagDef = record
638	+	XMLTag: TXMLTag;
639	+	TagValue: string;
640	+	end;
641	+
642	+	const
643	+	XMLTagDefs: array [xtBlob..xtElt] of TXMLTagDef = (
644	+	(XMLTag: xtBlob;   TagValue: 'blob'),
645	+	(XMLTag: xtArray;  TagValue: 'array'),
646	+	(XMLTag: xtElt;    TagValue: 'elt')
647	+	);
648	+	MaxXMLTags = 20;
649	+	BlobLineLength = 40;
650	+
651	+	public
652	+	const
653	+	ibx_blob = 'IBX_BLOB';
654	+	ibx_array = 'IBX_ARRAY';
655	+
656	+	type
657	+	TBlobData = record
658	+	BlobIntf: IBlob;
659	+	SubType: cardinal;
660	+	end;
661	+
662	+	TArrayData = record
663	+	ArrayIntf: IArray;
664	+	SQLType: cardinal;
665	+	relationName: string;
666	+	columnName: string;
667	+	dim: cardinal;
668	+	Size: cardinal;
669	+	Scale: integer;
670	+	CharSet: string;
671	+	bounds: TArrayBounds;
672	+	CurrentRow: integer;
673	+	Index: array of integer;
674	+	end;
675	+
676	+	private
677	+	FOnProgressEvent: TOnProgressEvent;
678	+	FXMLState: TXMLStates;
679	+	FXMLTagStack: array [1..MaxXMLTags] of TXMLTag;
680	+	FXMLTagIndex: integer;
681	+	FAttributeName: string;
682	+	FBlobData: array of TBlobData;
683	+	FCurrentBlob: integer;
684	+	FBlobBuffer: PByte;
685	+	FArrayData: array of TArrayData;
686	+	FCurrentArray: integer;
687	+	FXMLString: string;
688	+	function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
689	+	function GetArrayData(index: integer): TArrayData;
690	+	function GetArrayDataCount: integer;
691	+	function GetBlobData(index: integer): TBlobData;
692	+	function GetBlobDataCount: integer;
693	+	function GetTagName(xmltag: TXMLTag): string;
694	+	procedure ProcessAttributeValue(attrValue: string);
695	+	procedure ProcessBoundsList(boundsList: string);
696	+	procedure ProcessTagValue(tagValue: string);
697	+	procedure XMLTagInit(xmltag: TXMLTag);
698	+	function XMLTagEnd(var xmltag: TXMLTag): boolean;
699	+	procedure XMLTagEnter;
700	+	protected
701	+	function GetAttachment: IAttachment; virtual; abstract;
702	+	function GetTransaction: ITransaction; virtual; abstract;
703	+	function GetErrorPrefix: string; virtual; abstract;
704	+	function TokenFound(var token: TSQLTokens): boolean; override;
705	+	procedure Reset; override;
706	+	procedure ShowError(msg: string; params: array of const); overload; virtual;
707	+	procedure ShowError(msg: string); overload;
708	+	public
709	+	constructor Create;
710	+	procedure FreeDataObjects;
711	+	class function FormatBlob(Field: ISQLData): string; overload;
712	+	class function FormatBlob(contents: string; subtype:integer): string; overload;
713	+	class function FormatArray(ar: IArray): string;
714	+	property BlobData[index: integer]: TBlobData read GetBlobData;
715	+	property BlobDataCount: integer read GetBlobDataCount;
716	+	property ArrayData[index: integer]: TArrayData read GetArrayData;
717	+	property ArrayDataCount: integer read GetArrayDataCount;
718	+	property Attachment: IAttachment read GetAttachment;
719	+	property Transaction: ITransaction read GetTransaction;
720	+	property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
721	+	end;
722	+
723	+	TJnlEntryType = (jeTransStart, jeTransCommit, jeTransCommitRet, jeTransRollback,
724	+	jeTransRollbackRet, jeTransEnd, jeQuery,jeUnknown);
725	+
726	+	TJnlEntry = record
727	+	JnlEntryType: TJnlEntryType;
728	+	Timestamp: TDateTime;
729	+	SessionID: integer;
730	+	TransactionID: integer;
731	+	OldTransactionID: integer;
732	+	TransactionName: AnsiString;
733	+	TPB: ITPB;
734	+	DefaultCompletion: TTransactionCompletion;
735	+	QueryText: AnsiString;
736	+	end;
737	+
738	+	TOnNextJournalEntry = procedure(JnlEntry: TJnlEntry) of object;
739	+
740	+	{ TJournalProcessor - used to parse a client side journal}
741	+
742	+	TJournalProcessor = class(TSQLTokeniser)
743	+	private
744	+	type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,  lsGotSessionID,
745	+	lsGotTransactionID,  lsGotOldTransactionID, lsGotText1Length,
746	+	lsGotText1, lsGotText2Length, lsGotText2);
747	+	private
748	+	FOnNextJournalEntry: TOnNextJournalEntry;
749	+	FInStream: TStream;
750	+	FFirebirdClientAPI: IFirebirdAPI;
751	+	procedure DoExecute;
752	+	function IdentifyJnlEntry(aTokenText: AnsiString): TJnlEntryType;
753	+	protected
754	+	function GetChar: AnsiChar; override;
755	+	property OnNextJournalEntry: TOnNextJournalEntry read FOnNextJournalEntry write FOnNextJournalEntry;
756	+	public
757	+	destructor Destroy; override;
758	+	class procedure Execute( aFileName: string; api: IFirebirdAPI; aOnNextJournalEntry: TOnNextJournalEntry);
759	+	class function JnlEntryText(je: TJnlEntryType): string;
760	+	end;
761	+
762
763		function Max(n1, n2: Integer): Integer;
764		function Min(n1, n2: Integer): Integer;
#	Line 634 | Line 781 | function ParseConnectString(ConnectStrin
781		var PortNo: AnsiString): boolean;
782		function GetProtocol(ConnectString: AnsiString): TProtocolAll;
783
784	+	{$IF declared(TFormatSettings)}
785	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
786	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
787	+	{$IFEND}
788	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
789	+	var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
790	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
791	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
792	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
793	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
794	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
795	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
796	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
797	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
798	+	function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
799	+	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
800	+
801	+
802		implementation
803
804	<	uses FBMessages
804	>	uses FBMessages, Math
805
806	<	{$IFDEF HASREQEX}
806	>	{$IFDEF FPC}
807		,RegExpr
808	+	{$ELSE}
809	+	{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
810	+	, RegularExpressions
811	+	{$IFEND}
812		{$ENDIF};
813
814	+	resourcestring
815	+	sXMLStackUnderflow = 'XML Stack Underflow';
816	+	sInvalidEndTag = 'XML End Tag Mismatch - %s';
817	+	sBadEndTagClosing = 'XML End Tag incorrectly closed';
818	+	sXMLStackOverFlow = 'XML Stack Overflow';
819	+	sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
820	+	sInvalidBoundsList = 'Invalid array bounds list - "%s"';
821	+	sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
822	+	sArrayIndexError = 'Array Index Error (%d)';
823	+	sBlobIndexError = 'Blob Index Error (%d)';
824	+	sNoDatabase = 'Missing database for xml tag import';
825	+	sNoTransaction = 'Missing transaction for xml tag import';
826	+
827	+
828		function Max(n1, n2: Integer): Integer;
829		begin
830		if (n1 > n2) then
#	Line 759 | Line 942 | begin
942		Result := true;
943		end;
944
945	+	function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
946	+	begin
947	+	scheme := AnsiUpperCase(scheme);
948	+	if scheme = 'INET' then
949	+	Result := inet
950	+	else
951	+	if scheme = 'INET4' then
952	+	Result := inet4
953	+	else
954	+	if scheme = 'INET6' then
955	+	Result := inet6
956	+	else
957	+	if scheme = 'XNET' then
958	+	Result := xnet
959	+	else
960	+	if scheme = 'WNET' then
961	+	Result := wnet
962	+	end;
963	+
964		{Extracts the Database Connect string from a Create Database Statement}
965
966	<	{$IFDEF HASREQEX}
966	>	{$IF declared(TRegexpr)}
967		function ExtractConnectString(const CreateSQL: AnsiString;
968		var ConnectString: AnsiString): boolean;
969		var RegexObj: TRegExpr;
#	Line 784 | Line 986 | function ParseConnectString(ConnectStrin
986		DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
987		): boolean;
988
787	–	function GetProtocol(scheme: AnsiString): TProtocolAll;
788	–	begin
789	–	scheme := AnsiUpperCase(scheme);
790	–	if scheme = 'INET' then
791	–	Result := inet
792	–	else
793	–	if scheme = 'INET4' then
794	–	Result := inet4
795	–	else
796	–	if scheme = 'INET6' then
797	–	Result := inet6
798	–	else
799	–	if scheme = 'XNET' then
800	–	Result := xnet
801	–	else
802	–	if scheme = 'WNET' then
803	–	Result := wnet
804	–	end;
805	–
989		var RegexObj: TRegExpr;
990		begin
991		ServerName := '';
#	Line 818 | Line 1001 | begin
1001		if Result then
1002		begin
1003		{URL type connect string}
1004	<	Protocol := GetProtocol(RegexObj.Match[1]);
1004	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
1005		ServerName := RegexObj.Match[2];
1006		if RegexObj.MatchLen[3] > 0 then
1007		PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
#	Line 833 | Line 1016 | begin
1016		Result := RegexObj.Exec(ConnectString);
1017		if Result then
1018		begin
1019	<	Protocol := GetProtocol(RegexObj.Match[1]);
1019	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
1020		DatabaseName := RegexObj.Match[2];
1021		end
1022		else
#	Line 882 | Line 1065 | begin
1065		end;
1066		end;
1067
1068	<	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1069	<	var ServerName,
1070	<	DatabaseName: AnsiString;
1071	<	PortNo: AnsiString;
1068	>	{$ELSE}
1069	>	{$IF declared(TRegex)}
1070	>	function ExtractConnectString(const CreateSQL: AnsiString;
1071	>	var ConnectString: AnsiString): boolean;
1072	>	var Regex: TRegEx;
1073	>	Match: TMatch;
1074		begin
1075	<	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
1075	>	Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
1076	>	{extact database file spec}
1077	>	Match := Regex.Match(CreateSQL);
1078	>	Result := Match.Success and (Match.Groups.Count = 3);
1079	>	if Result then
1080	>	ConnectString := Match.Groups[2].Value;
1081		end;
1082
1083	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
1084	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
1085	+	): boolean;
1086	+
1087	+	var Regex: TRegEx;
1088	+	Match: TMatch;
1089	+	begin
1090	+	ServerName := '';
1091	+	DatabaseName := ConnectString;
1092	+	PortNo := '';
1093	+	Protocol := unknownProtocol;
1094	+	{extact database file spec}
1095	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
1096	+	Result := Match.Success and (Match.Groups.Count = 5);
1097	+	if Result then
1098	+	begin
1099	+	{URL type connect string}
1100	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
1101	+	ServerName := Match.Groups[2].Value;
1102	+	PortNo := Match.Groups[3].Value;
1103	+	DatabaseName := Match.Groups[4].Value;
1104	+	if ServerName = '' then
1105	+	DatabaseName := '/' + DatabaseName;
1106	+	end
1107	+	else
1108	+	begin
1109	+	{URL type connect string - local loop}
1110	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
1111	+	Result := Match.Success and (Match.Groups.Count = 3);
1112	+	if Result then
1113	+	begin
1114	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
1115	+	DatabaseName := Match.Groups[2].Value;
1116	+	end
1117	+	else
1118	+	begin
1119	+	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
1120	+	Result := Match.Success;
1121	+	if Result then
1122	+	Protocol := Local {Windows with leading drive ID}
1123	+	else
1124	+	begin
1125	+	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
1126	+	Result := Match.Success and (Match.Groups.Count = 4);
1127	+	if Result then
1128	+	begin
1129	+	{Legacy TCP Format}
1130	+	ServerName := Match.Groups[1].Value;
1131	+	PortNo := Match.Groups[2].Value;
1132	+	DatabaseName := Match.Groups[3].Value;
1133	+	Protocol := TCP;
1134	+	end
1135	+	else
1136	+	begin
1137	+	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
1138	+	Result := Match.Success and (Match.Groups.Count = 4);
1139	+	if Result then
1140	+	begin
1141	+	{Netbui}
1142	+	ServerName := Match.Groups[1].Value;
1143	+	PortNo := Match.Groups[2].Value;
1144	+	DatabaseName := Match.Groups[3].Value;
1145	+	Protocol := NamedPipe
1146	+	end
1147	+	else
1148	+	begin
1149	+	Result := true;
1150	+	Protocol := Local; {Assume local}
1151	+	end;
1152	+	end;
1153	+	end;
1154	+	end;
1155	+	end;
1156	+	end;
1157		{$ELSE}
1158	<	{cruder version of above for Delphi. Older versions lack regular expression
1158	>	{cruder version of above for Delphi < XE. Older versions lack regular expression
1159		handling.}
1160		function ExtractConnectString(const CreateSQL: AnsiString;
1161		var ConnectString: AnsiString): boolean;
#	Line 912 | Line 1176 | begin
1176		end;
1177		end;
1178
915	–	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
916	–	begin
917	–	Result := unknownProtocol; {not implemented for Delphi}
918	–	end;
919	–
1179		function ParseConnectString(ConnectString: AnsiString;
1180		var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1181		var PortNo: AnsiString): boolean;
#	Line 924 | Line 1183 | begin
1183		Result := false;
1184		end;
1185
1186	<	{$ENDIF}
1186	>	{$IFEND}
1187	>	{$IFEND}
1188	>
1189	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1190	>	var ServerName,
1191	>	DatabaseName: AnsiString;
1192	>	PortNo: AnsiString;
1193	>	begin
1194	>	if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1195	>	Result := unknownProtocol;
1196	>	end;
1197
1198		{Make a connect string in format appropriate protocol}
1199
#	Line 940 | Line 1209 | function MakeConnectString(ServerName, D
1209		end;
1210
1211		begin
1212	+	if ServerName = '' then ServerName := 'localhost';
1213		if PortNo <> '' then
1214		case Protocol of
1215		NamedPipe:
#	Line 1142 | Line 1412 | begin
1412		stInBlock:
1413		begin
1414		case token of
1415	<	sqltBegin:
1415	>	sqltBegin,
1416	>	sqltCase:
1417		Inc(FNested);
1418
1419		sqltEnd:
#	Line 1340 | Line 1611 | begin
1611		ResetQueue;
1612		end;
1613
1614	+	function TSQLTokeniser.ReadCharacters(NumOfChars: integer): AnsiString;
1615	+	var i: integer;
1616	+	begin
1617	+	Result := FLastChar;
1618	+	for i := 2 to NumOfChars do
1619	+	begin
1620	+	if GetNext = sqltEOF then Exit;
1621	+	Result := Result + FLastChar;
1622	+	end;
1623	+	GetNext;
1624	+	end;
1625	+
1626		function TSQLTokeniser.GetNextToken: TSQLTokens;
1627		begin
1628		if FQueueState = tsRelease then
#	Line 1364 | Line 1647 | begin
1647		GetNext;
1648
1649		repeat
1650	+	if FSkipNext then
1651	+	begin
1652	+	FSkipNext := false;
1653	+	GetNext;
1654	+	end;
1655	+
1656		Result := FNextToken;
1657		C := FLastChar;
1658		GetNext;
1659
1660	<	if FSkipNext then
1660	>	if (Result = sqltCR) and (FNextToken = sqltEOL) then
1661		begin
1662	<	FSkipNext := false;
1663	<	continue;
1662	>	FSkipNext := true;
1663	>	Result := sqltEOL;
1664	>	C := LF;
1665		end;
1666
1667		case FState of
#	Line 1384 | Line 1674 | begin
1674		GetNext;
1675		end
1676		else
1677	+	if Result = sqltEOL then
1678	+	FString := FString + LineEnding
1679	+	else
1680		FString := FString + C;
1681		end;
1682
#	Line 1396 | Line 1689 | begin
1689		Result := sqltCommentLine;
1690		end;
1691
1399	–	sqltCR: {ignore};
1400	–
1692		else
1693		FString := FString + C;
1694		end;
#	Line 1419 | Line 1710 | begin
1710		end;
1711		end
1712		else
1713	+	if Result = sqltEOL then
1714	+	FString := FString + LineEnding
1715	+	else
1716		FString := FString + C;
1717		end;
1718
#	Line 1438 | Line 1732 | begin
1732		end;
1733		end
1734		else
1735	+	if Result = sqltEOL then
1736	+	FString := FString + LineEnding
1737	+	else
1738		FString := FString + C;
1739		end;
1740
#	Line 1518 | Line 1815 | begin
1815		sqltNumberString:
1816		if FNextToken in [sqltNumberString,sqltPeriod] then
1817		FState := stInNumeric;
1818	+
1819	+	sqltEOL:
1820	+	FString := LineEnding;
1821		end;
1822		end;
1823		end;
#	Line 1527 | Line 1827 | begin
1827		until TokenFound(Result) or EOF;
1828		end;
1829
1830	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1831	+	var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1832	+	{$IF declared(TFormatSettings)}
1833	+	begin
1834	+	{$IF declared(DefaultFormatSettings)}
1835	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1836	+	{$ELSE}
1837	+	{$IF declared(FormatSettings)}
1838	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1839	+	{$IFEND} {$IFEND}
1840	+	end;
1841	+
1842	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1843	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1844	+	{$IFEND}
1845	+	const
1846	+	whitespacechars = [' ',#$09,#$0A,#$0D];
1847	+	var i,j,l: integer;
1848	+	aTime: TDateTime;
1849	+	DMs: longint;
1850	+	begin
1851	+	Result := false;
1852	+	aTimezone := '';
1853	+	if aDateTimeStr <> '' then
1854	+	{$if declared(TFormatSettings)}
1855	+	with aFormatSettings do
1856	+	{$IFEND}
1857	+	begin
1858	+	aDateTime := 0;
1859	+	{Parse to get time zone info}
1860	+	i := 1;
1861	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1862	+	if not TimeOnly then
1863	+	begin
1864	+	{decode date}
1865	+	j := i;
1866	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1867	+	if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1868	+	i := j; {otherwise start again i.e. assume time only}
1869	+	end;
1870	+
1871	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1872	+	{decode time}
1873	+	j := i;
1874	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1875	+	Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1876	+	if not Result then Exit;
1877	+	aDateTime := aDateTime + aTime;
1878	+	i := j;
1879	+
1880	+	{is there a factional second part}
1881	+	if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1882	+	begin
1883	+	inc(i);
1884	+	inc(j);
1885	+	while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1886	+	if j > i then
1887	+	begin
1888	+	l := j-i;
1889	+	if l > 4 then l := 4;
1890	+	Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1891	+	if not Result then Exit;
1892	+
1893	+	{adjust for number of significant digits}
1894	+	case l of
1895	+	3:   DMs := DMs * 10;
1896	+	2:   DMs := DMs * 100;
1897	+	1:   DMs := DMs * 1000;
1898	+	end;
1899	+	aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1900	+	end;
1901	+	end;
1902	+	i := j;
1903	+
1904	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1905	+	{decode time zone}
1906	+	if i < length(aDateTimeStr) then
1907	+	begin
1908	+	j := i;
1909	+	while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1910	+	aTimezone := system.copy(aDateTimeStr,i,j-i);
1911	+	end;
1912	+	Result := true;
1913	+	end
1914	+	end;
1915	+
1916	+	{The following is similar to FPC DecodeTime except that the Firebird standard
1917	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1918	+
1919	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1920	+	var DeciMillisecond: cardinal);
1921	+	var D : Double;
1922	+	l : cardinal;
1923	+	begin
1924	+	{conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1925	+	D := aTime * MSecsPerDay *10;
1926	+	if D < 0 then
1927	+	D := D - 0.5
1928	+	else
1929	+	D := D + 0.5;
1930	+	{rest hacked from FPC DecodeTIme}
1931	+	l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1932	+	Hour   := l div 36000000;
1933	+	l := l mod 36000000;
1934	+	Minute := l div 600000;
1935	+	l := l mod 600000;
1936	+	Second := l div 10000;
1937	+	DeciMillisecond := l mod 10000;
1938	+	end;
1939	+
1940	+	{The following is similar to FPC EncodeTime except that the Firebird standard
1941	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1942	+
1943	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1944	+	const DMSecsPerDay = MSecsPerDay*10;
1945	+	var DMs: cardinal;
1946	+	D: Double;
1947	+	begin
1948	+	if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1949	+	begin
1950	+	DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1951	+	D := DMs/DMSecsPerDay;
1952	+	Result:=TDateTime(d)
1953	+	end
1954	+	else
1955	+	IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1956	+	end;
1957	+
1958	+	{The following is similar to FPC FormatDateTime except that it additionally
1959	+	allows the timstamp to have a fractional seconds component with a resolution
1960	+	of four decimal places. This is appended to the result for FormatDateTime
1961	+	if the format string contains a "zzzz' string.}
1962	+
1963	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1964	+	var Hour, Minute, Second: word;
1965	+	DeciMillisecond: cardinal;
1966	+	begin
1967	+	if Pos('zzzz',fmt) > 0 then
1968	+	begin
1969	+	FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1970	+	fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1971	+	end;
1972	+	Result := FormatDateTime(fmt,aDateTime);
1973	+	end;
1974	+
1975	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1976	+	begin
1977	+	if EffectiveTimeOffsetMins > 0 then
1978	+	Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1979	+	else
1980	+	Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1981	+	end;
1982	+
1983	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1984	+	var i: integer;
1985	+	begin
1986	+	Result := false;
1987	+	TZOffset := Trim(TZOffset);
1988	+	for i := 1 to Length(TZOffset) do
1989	+	if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1990	+
1991	+	Result := true;
1992	+	i := Pos(':',TZOffset);
1993	+	if i > 0 then
1994	+	dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1995	+	else
1996	+	dstOffset := StrToInt(TZOffset) * 60;
1997	+	end;
1998	+
1999	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
2000	+	var i: Integer;
2001	+	start: integer;
2002	+	begin
2003	+	Result := '';
2004	+	start := 1;
2005	+	if (Length(Value) > 0) and (Value[1] = '-') then
2006	+	begin
2007	+	Result := '-';
2008	+	start := 2;
2009	+	end;
2010	+	for i := start to Length(Value) do
2011	+	if Value[i] <> '0' then
2012	+	begin
2013	+	Result := Result + system.copy(Value, i, MaxInt);
2014	+	Exit;
2015	+	end;
2016	+	end;
2017	+
2018	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
2019	+	var i: integer;
2020	+	ds: integer;
2021	+	exponent: integer;
2022	+	begin
2023	+	Result := false;
2024	+	ds := 0;
2025	+	exponent := 0;
2026	+	S := Trim(S);
2027	+	Value := 0;
2028	+	scale := 0;
2029	+	if Length(S) = 0 then
2030	+	Exit;
2031	+	{$IF declared(DefaultFormatSettings)}
2032	+	with DefaultFormatSettings do
2033	+	{$ELSE}
2034	+	{$IF declared(FormatSettings)}
2035	+	with FormatSettings do
2036	+	{$IFEND}
2037	+	{$IFEND}
2038	+	begin
2039	+	for i := length(S) downto 1 do
2040	+	begin
2041	+	if S[i] = AnsiChar(DecimalSeparator) then
2042	+	begin
2043	+	if ds <> 0 then Exit; {only one allowed}
2044	+	ds := i;
2045	+	dec(exponent);
2046	+	system.Delete(S,i,1);
2047	+	end
2048	+	else
2049	+	if S[i] in ['+','-'] then
2050	+	begin
2051	+	if (i > 1) and not (S[i-1] in ['e','E']) then
2052	+	Exit; {malformed}
2053	+	end
2054	+	else
2055	+	if S[i] in ['e','E'] then {scientific notation}
2056	+	begin
2057	+	if ds <> 0 then Exit; {not permitted in exponent}
2058	+	if exponent <> 0 then Exit; {only one allowed}
2059	+	exponent := i;
2060	+	end
2061	+	else
2062	+	if not (S[i] in ['0'..'9']) then
2063	+	{Note: ThousandSeparator not allowed by Delphi specs}
2064	+	Exit; {bad character}
2065	+	end;
2066	+
2067	+	if exponent > 0 then
2068	+	begin
2069	+	Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
2070	+	if Result then
2071	+	begin
2072	+	{adjust scale for decimal point}
2073	+	if ds <> 0 then
2074	+	Scale := Scale - (exponent - ds);
2075	+	Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
2076	+	end;
2077	+	end
2078	+	else
2079	+	begin
2080	+	if ds <> 0 then
2081	+	scale := ds - Length(S) - 1;
2082	+	Result := TryStrToInt64(S,Value);
2083	+	end;
2084	+	end;
2085	+	end;
2086	+
2087	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
2088	+	begin
2089	+	Result := aValue * IntPower(10,aScale)
2090	+	end;
2091	+
2092	+
2093	+	function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
2094	+
2095	+	function ToHex(aValue: byte): string;
2096	+	const
2097	+	HexChars: array [0..15] of char = '0123456789ABCDEF';
2098	+	begin
2099	+	Result := HexChars[aValue shr 4] +
2100	+	HexChars[(aValue and $0F)];
2101	+	end;
2102	+
2103	+	var i, j: integer;
2104	+	begin
2105	+	i := 1;
2106	+	Result := '';
2107	+	if MaxLineLength = 0 then
2108	+	while i <= Length(octetString) do
2109	+	begin
2110	+	Result := Result +  ToHex(byte(octetString[i]));
2111	+	Inc(i);
2112	+	end
2113	+	else
2114	+	while i <= Length(octetString) do
2115	+	begin
2116	+	for j := 1 to MaxLineLength do
2117	+	begin
2118	+	if i > Length(octetString) then
2119	+	Exit
2120	+	else
2121	+	Result := Result + ToHex(byte(octetString[i]));
2122	+	inc(i);
2123	+	end;
2124	+	Result := Result + LineEnding;
2125	+	end;
2126	+	end;
2127	+
2128	+	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
2129	+	begin
2130	+	TextOut.Add(StringToHex(octetString,MaxLineLength));
2131	+	end;
2132	+
2133	+	{ TSQLXMLReader }
2134	+
2135	+	function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
2136	+	var i: TXMLTag;
2137	+	begin
2138	+	Result := false;
2139	+	for i := xtBlob to xtElt do
2140	+	if XMLTagDefs[i].TagValue = tag then
2141	+	begin
2142	+	xmlTag := XMLTagDefs[i].XMLTag;
2143	+	Result := true;
2144	+	break;
2145	+	end;
2146	+	end;
2147	+
2148	+	function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
2149	+	begin
2150	+	if (index < 0) or (index > ArrayDataCount) then
2151	+	ShowError(sArrayIndexError,[index]);
2152	+	Result := FArrayData[index];
2153	+	end;
2154	+
2155	+	function TSQLXMLReader.GetArrayDataCount: integer;
2156	+	begin
2157	+	Result := Length(FArrayData);
2158	+	end;
2159	+
2160	+	function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
2161	+	begin
2162	+	if (index < 0) or (index > BlobDataCount) then
2163	+	ShowError(sBlobIndexError,[index]);
2164	+	Result := FBlobData[index];
2165	+	end;
2166	+
2167	+	function TSQLXMLReader.GetBlobDataCount: integer;
2168	+	begin
2169	+	Result := Length(FBlobData);
2170	+	end;
2171	+
2172	+	function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
2173	+	var i: TXMLTag;
2174	+	begin
2175	+	Result := 'unknown';
2176	+	for i := xtBlob to xtElt do
2177	+	if XMLTagDefs[i].XMLTag = xmltag then
2178	+	begin
2179	+	Result := XMLTagDefs[i].TagValue;
2180	+	Exit;
2181	+	end;
2182	+	end;
2183	+
2184	+	procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
2185	+	begin
2186	+	case FXMLTagStack[FXMLTagIndex] of
2187	+	xtBlob:
2188	+	if FAttributeName = 'subtype' then
2189	+	FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
2190	+	else
2191	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2192	+
2193	+	xtArray:
2194	+	if FAttributeName = 'sqltype' then
2195	+	FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
2196	+	else
2197	+	if FAttributeName = 'relation_name' then
2198	+	FArrayData[FCurrentArray].relationName := attrValue
2199	+	else
2200	+	if FAttributeName = 'column_name' then
2201	+	FArrayData[FCurrentArray].columnName := attrValue
2202	+	else
2203	+	if FAttributeName = 'dim' then
2204	+	FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
2205	+	else
2206	+	if FAttributeName = 'length' then
2207	+	FArrayData[FCurrentArray].Size := StrToInt(attrValue)
2208	+	else
2209	+	if FAttributeName = 'scale' then
2210	+	FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
2211	+	else
2212	+	if FAttributeName = 'charset' then
2213	+	FArrayData[FCurrentArray].CharSet := attrValue
2214	+	else
2215	+	if FAttributeName = 'bounds' then
2216	+	ProcessBoundsList(attrValue)
2217	+	else
2218	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2219	+
2220	+	xtElt:
2221	+	if FAttributeName = 'ix' then
2222	+	with FArrayData[FCurrentArray] do
2223	+	Index[CurrentRow] :=  StrToInt(attrValue)
2224	+	else
2225	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2226	+	end;
2227	+	end;
2228	+
2229	+	procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
2230	+	var list: TStringList;
2231	+	i,j: integer;
2232	+	begin
2233	+	list := TStringList.Create;
2234	+	try
2235	+	list.Delimiter := ',';
2236	+	list.DelimitedText := boundsList;
2237	+	with FArrayData[FCurrentArray] do
2238	+	begin
2239	+	if dim <> list.Count then
2240	+	ShowError(sInvalidBoundsList,[boundsList]);
2241	+	SetLength(bounds,dim);
2242	+	for i := 0 to list.Count - 1 do
2243	+	begin
2244	+	j := Pos(':',list[i]);
2245	+	if j = 0 then
2246	+	raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
2247	+	bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
2248	+	bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
2249	+	end;
2250	+	end;
2251	+	finally
2252	+	list.Free;
2253	+	end;
2254	+	end;
2255	+
2256	+	procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
2257	+
2258	+	function nibble(hex: char): byte;
2259	+	begin
2260	+	case hex of
2261	+	'0': Result := 0;
2262	+	'1': Result := 1;
2263	+	'2': Result := 2;
2264	+	'3': Result := 3;
2265	+	'4': Result := 4;
2266	+	'5': Result := 5;
2267	+	'6': Result := 6;
2268	+	'7': Result := 7;
2269	+	'8': Result := 8;
2270	+	'9': Result := 9;
2271	+	'a','A': Result := 10;
2272	+	'b','B': Result := 11;
2273	+	'c','C': Result := 12;
2274	+	'd','D': Result := 13;
2275	+	'e','E': Result := 14;
2276	+	'f','F': Result := 15;
2277	+	end;
2278	+	end;
2279	+
2280	+	procedure RemoveWhiteSpace(var hexData: string);
2281	+	var i: integer;
2282	+	begin
2283	+	{Remove White Space}
2284	+	i := 1;
2285	+	while i <= length(hexData) do
2286	+	begin
2287	+	case hexData[i] of
2288	+	' ',#9,#10,#13:
2289	+	begin
2290	+	if i < Length(hexData) then
2291	+	Move(hexData[i+1],hexData[i],Length(hexData)-i);
2292	+	SetLength(hexData,Length(hexData)-1);
2293	+	end;
2294	+	else
2295	+	Inc(i);
2296	+	end;
2297	+	end;
2298	+	end;
2299	+
2300	+	procedure WriteToBlob(hexData: string);
2301	+	var i,j : integer;
2302	+	blength: integer;
2303	+	P: PByte;
2304	+	begin
2305	+	RemoveWhiteSpace(hexData);
2306	+	if odd(length(hexData)) then
2307	+	ShowError(sBinaryBlockMustbeEven,[nil]);
2308	+	blength := Length(hexData) div 2;
2309	+	ReallocMem(FBlobBuffer,blength);
2310	+	j := 1;
2311	+	P := FBlobBuffer;
2312	+	for i := 1 to blength do
2313	+	begin
2314	+	P^ := (nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]);
2315	+	Inc(j,2);
2316	+	Inc(P);
2317	+	end;
2318	+	FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
2319	+	end;
2320	+
2321	+	begin
2322	+	if tagValue = '' then Exit;
2323	+	case FXMLTagStack[FXMLTagIndex] of
2324	+	xtBlob:
2325	+	WriteToBlob(tagValue);
2326	+
2327	+	xtElt:
2328	+	with FArrayData[FCurrentArray] do
2329	+	ArrayIntf.SetAsString(index,tagValue);
2330	+
2331	+	end;
2332	+	end;
2333	+
2334	+	procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
2335	+	begin
2336	+	if FXMLTagIndex > MaxXMLTags then
2337	+	ShowError(sXMLStackOverFlow,[nil]);
2338	+	Inc(FXMLTagIndex);
2339	+	FXMLTagStack[FXMLTagIndex] := xmltag;
2340	+	FXMLString := '';
2341	+
2342	+	case xmltag of
2343	+	xtBlob:
2344	+	begin
2345	+	Inc(FCurrentBlob);
2346	+	SetLength(FBlobData,FCurrentBlob+1);
2347	+	FBlobData[FCurrentBlob].BlobIntf := nil;
2348	+	FBlobData[FCurrentBlob].SubType := 0;
2349	+	end;
2350	+
2351	+	xtArray:
2352	+	begin
2353	+	Inc(FCurrentArray);
2354	+	SetLength(FArrayData,FCurrentArray+1);
2355	+	with FArrayData[FCurrentArray] do
2356	+	begin
2357	+	ArrayIntf := nil;
2358	+	SQLType := 0;
2359	+	dim := 0;
2360	+	Size := 0;
2361	+	Scale := 0;
2362	+	CharSet := 'NONE';
2363	+	SetLength(Index,0);
2364	+	CurrentRow := -1;
2365	+	end;
2366	+	end;
2367	+
2368	+	xtElt:
2369	+	with FArrayData[FCurrentArray] do
2370	+	Inc(CurrentRow)
2371	+	end;
2372	+	end;
2373	+
2374	+	function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
2375	+	begin
2376	+	if FXMLTagIndex = 0 then
2377	+	ShowError(sXMLStackUnderflow,[nil]);
2378	+
2379	+	xmlTag := FXMLTagStack[FXMLTagIndex];
2380	+	case FXMLTagStack[FXMLTagIndex] of
2381	+	xtBlob:
2382	+	FBlobData[FCurrentBlob].BlobIntf.Close;
2383	+
2384	+	xtArray:
2385	+	FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
2386	+
2387	+	xtElt:
2388	+	Dec(FArrayData[FCurrentArray].CurrentRow);
2389	+	end;
2390	+	Dec(FXMLTagIndex);
2391	+	Result := FXMLTagIndex = 0;
2392	+	end;
2393	+
2394	+	procedure TSQLXMLReader.XMLTagEnter;
2395	+	var aCharSetID: integer;
2396	+	begin
2397	+	if (Attachment = nil) or not Attachment.IsConnected then
2398	+	ShowError(sNoDatabase);
2399	+	if Transaction = nil then
2400	+	ShowError(sNoTransaction);
2401	+	case FXMLTagStack[FXMLTagIndex] of
2402	+	xtBlob:
2403	+	begin
2404	+	if not Transaction.InTransaction then
2405	+	Transaction.Start;
2406	+	FBlobData[FCurrentBlob].BlobIntf := Attachment.CreateBlob(
2407	+	Transaction,FBlobData[FCurrentBlob].SubType);
2408	+	end;
2409	+
2410	+	xtArray:
2411	+	with FArrayData[FCurrentArray] do
2412	+	begin
2413	+	if not Transaction.InTransaction then
2414	+	Transaction.Start;
2415	+	Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
2416	+	SetLength(Index,dim);
2417	+	ArrayIntf := Attachment.CreateArray(
2418	+	Transaction,
2419	+	Attachment.CreateArrayMetaData(SQLType,
2420	+	relationName,columnName,Scale,Size,
2421	+	aCharSetID,dim,bounds)
2422	+	);
2423	+	end;
2424	+	end;
2425	+	end;
2426	+
2427	+	{This is where the XML tags are identified and the token stream modified in
2428	+	consequence}
2429	+
2430	+	function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
2431	+
2432	+	procedure NotAnXMLTag;
2433	+	begin
2434	+	begin
2435	+	if FXMLTagIndex = 0 then
2436	+	{nothing to do with XML so go back to processing SQL}
2437	+	begin
2438	+	QueueToken(token);
2439	+	ReleaseQueue(token);
2440	+	FXMLState := stNoXML
2441	+	end
2442	+	else
2443	+	begin
2444	+	{Not an XML tag, so just push back to XML Data}
2445	+	FXMLState := stXMLData;
2446	+	FXMLString := FXMLString + GetQueuedText;
2447	+	ResetQueue;
2448	+	end;
2449	+	end;
2450	+	end;
2451	+
2452	+	var XMLTag: TXMLTag;
2453	+	begin
2454	+	Result := inherited TokenFound(token);
2455	+	if not Result then Exit;
2456	+
2457	+	case FXMLState of
2458	+	stNoXML:
2459	+	if token = sqltLT then
2460	+	begin
2461	+	ResetQueue;
2462	+	QueueToken(token); {save in case this is not XML}
2463	+	FXMLState := stInTag;
2464	+	end;
2465	+
2466	+	stInTag:
2467	+	{Opening '<' found, now looking for tag name or end tag marker}
2468	+	case token of
2469	+	sqltIdentifier:
2470	+	begin
2471	+	if FindTag(TokenText,XMLTag) then
2472	+	begin
2473	+	XMLTagInit(XMLTag);
2474	+	QueueToken(token);
2475	+	FXMLState := stInTagBody;
2476	+	end
2477	+	else
2478	+	NotAnXMLTag;
2479	+	end;
2480	+
2481	+	sqltForwardSlash:
2482	+	FXMLState := stInEndTag;
2483	+
2484	+	else
2485	+	NotAnXMLTag;
2486	+	end {case token};
2487	+
2488	+	stInTagBody:
2489	+	{Tag name found. Now looking for attribute or closing '>'}
2490	+	case token of
2491	+	sqltIdentifier:
2492	+	begin
2493	+	FAttributeName := TokenText;
2494	+	QueueToken(token);
2495	+	FXMLState := stAttribute;
2496	+	end;
2497	+
2498	+	sqltGT:
2499	+	begin
2500	+	ResetQueue;
2501	+	XMLTagEnter;
2502	+	FXMLState := stXMLData;
2503	+	end;
2504	+
2505	+	sqltSpace,
2506	+	sqltEOL:
2507	+	QueueToken(token);
2508	+
2509	+	else
2510	+	NotAnXMLTag;
2511	+	end {case token};
2512	+
2513	+	stAttribute:
2514	+	{Attribute name found. Must be followed by an '=', a '>' or another tag name}
2515	+	case token of
2516	+	sqltEquals:
2517	+	begin
2518	+	QueueToken(token);
2519	+	FXMLState := stAttributeValue;
2520	+	end;
2521	+
2522	+	sqltSpace,
2523	+	sqltEOL:
2524	+	QueueToken(token);
2525	+
2526	+	sqltIdentifier:
2527	+	begin
2528	+	ProcessAttributeValue('');
2529	+	FAttributeName := TokenText;
2530	+	QueueToken(token);
2531	+	FXMLState := stAttribute;
2532	+	end;
2533	+
2534	+	sqltGT:
2535	+	begin
2536	+	ProcessAttributeValue('');
2537	+	ResetQueue;
2538	+	XMLTagEnter;
2539	+	FXMLState := stXMLData;
2540	+	end;
2541	+
2542	+	else
2543	+	NotAnXMLTag;
2544	+	end; {case token}
2545	+
2546	+	stAttributeValue:
2547	+	{Looking for attribute value as a single identifier or a double quoted value}
2548	+	case token of
2549	+	sqltIdentifier,sqltIdentifierInDoubleQuotes:
2550	+	begin
2551	+	ProcessAttributeValue(TokenText);
2552	+	QueueToken(token);
2553	+	FXMLState := stInTagBody;
2554	+	end;
2555	+
2556	+	sqltSpace,
2557	+	sqltEOL:
2558	+	QueueToken(token);
2559	+
2560	+	else
2561	+	NotAnXMLTag;
2562	+	end; {case token}
2563	+
2564	+	stXMLData:
2565	+	if token = sqltLT then
2566	+	begin
2567	+	QueueToken(token); {save in case this is not XML}
2568	+	FXMLState := stInTag;
2569	+	end
2570	+	else
2571	+	FXMLString := FXMLString + TokenText;
2572	+
2573	+	stInEndTag:
2574	+	{Opening '</' found, now looking for tag name}
2575	+	case token of
2576	+	sqltIdentifier:
2577	+	begin
2578	+	if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
2579	+	begin
2580	+	QueueToken(token);
2581	+	FXMLState := stInEndTagBody;
2582	+	end
2583	+	else
2584	+	ShowError(sInvalidEndTag,[TokenText]);
2585	+	end;
2586	+	else
2587	+	NotAnXMLTag;
2588	+	end {case token};
2589	+
2590	+	stInEndTagBody:
2591	+	{End tag name found, now looping for closing '>'}
2592	+	case Token of
2593	+	sqltGT:
2594	+	begin
2595	+	ProcessTagValue(FXMLString);
2596	+	if XMLTagEnd(XMLTag) then
2597	+	begin
2598	+	ResetQueue;
2599	+	QueueToken(sqltColon,':');
2600	+	case XMLTag of
2601	+	xtBlob:
2602	+	QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
2603	+
2604	+	xtArray:
2605	+	QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
2606	+	end;
2607	+	ReleaseQueue(token);
2608	+	FXMLState := stNoXML;
2609	+	end
2610	+	else
2611	+	FXMLState := stXMLData;
2612	+	end;
2613	+
2614	+	sqltSpace,
2615	+	sqltEOL:
2616	+	QueueToken(token);
2617	+
2618	+	else
2619	+	ShowError(sBadEndTagClosing);
2620	+	end; {case token}
2621	+
2622	+	end {Case FState};
2623	+
2624	+	{Only allow token to be returned if not processing an XML tag}
2625	+
2626	+	Result := FXMLState = stNoXML;
2627	+	end;
2628	+
2629	+	procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
2630	+	begin
2631	+	raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
2632	+	end;
2633	+
2634	+	procedure TSQLXMLReader.ShowError(msg: string);
2635	+	begin
2636	+	ShowError(msg,[nil]);
2637	+	end;
2638	+
2639	+	constructor TSQLXMLReader.Create;
2640	+	begin
2641	+	inherited;
2642	+	FXMLState := stNoXML;
2643	+	end;
2644	+
2645	+	procedure TSQLXMLReader.FreeDataObjects;
2646	+	begin
2647	+	FXMLTagIndex := 0;
2648	+	SetLength(FBlobData,0);
2649	+	FCurrentBlob := -1;
2650	+	SetLength(FArrayData,0);
2651	+	FCurrentArray := -1;
2652	+	end;
2653	+
2654	+	class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
2655	+	begin
2656	+	Result := FormatBlob(Field.AsString,Field.getSubtype);
2657	+	end;
2658	+
2659	+	class function TSQLXMLReader.FormatBlob(contents: string; subtype: integer
2660	+	): string;
2661	+	var TextOut: TStrings;
2662	+	begin
2663	+	TextOut := TStringList.Create;
2664	+	try
2665	+	TextOut.Add(Format('<blob subtype="%d">',[subtype]));
2666	+	StringToHex(contents,TextOut,BlobLineLength);
2667	+	TextOut.Add('</blob>');
2668	+	Result := TextOut.Text;
2669	+	finally
2670	+	TextOut.Free;
2671	+	end;
2672	+	end;
2673	+
2674	+
2675	+	class function TSQLXMLReader.FormatArray(ar: IArray
2676	+	): string;
2677	+	var index: array of integer;
2678	+	TextOut: TStrings;
2679	+
2680	+	procedure AddElements(dim: integer; indent:string = ' ');
2681	+	var i: integer;
2682	+	recurse: boolean;
2683	+	begin
2684	+	SetLength(index,dim+1);
2685	+	recurse := dim < ar.GetDimensions - 1;
2686	+	with ar.GetBounds[dim] do
2687	+	for i := LowerBound to UpperBound do
2688	+	begin
2689	+	index[dim] := i;
2690	+	if recurse then
2691	+	begin
2692	+	TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
2693	+	AddElements(dim+1,indent + ' ');
2694	+	TextOut.Add('</elt>');
2695	+	end
2696	+	else
2697	+	if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
2698	+	(ar.GetCharSetID = 1) then
2699	+	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
2700	+	else
2701	+	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
2702	+	end;
2703	+	end;
2704	+
2705	+	var
2706	+	s: string;
2707	+	bounds: TArrayBounds;
2708	+	i: integer;
2709	+	boundsList: string;
2710	+	begin
2711	+	TextOut := TStringList.Create;
2712	+	try
2713	+	if ar.GetCharSetWidth = 0 then
2714	+	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2715	+	[ar.GetDimensions,ar.GetSQLType,ar.GetSize,
2716	+	ar.GetTableName,ar.GetColumnName])
2717	+	else
2718	+	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2719	+	[ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
2720	+	ar.GetTableName,ar.GetColumnName]);
2721	+	case ar.GetSQLType of
2722	+	SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
2723	+	s := s + Format(' scale = "%d"',[ ar.GetScale]);
2724	+	SQL_TEXT,
2725	+	SQL_VARYING:
2726	+	s := s + Format(' charset = "%s"',[ar.GetAttachment.GetCharsetName(ar.GetCharSetID)]);
2727	+	end;
2728	+	bounds := ar.GetBounds;
2729	+	boundsList := '';
2730	+	for i := 0 to length(bounds) - 1 do
2731	+	begin
2732	+	if i <> 0 then boundsList := boundsList + ',';
2733	+	boundsList := boundsList + Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
2734	+	end;
2735	+	s := s + Format(' bounds="%s"',[boundsList]);
2736	+	s := s + '>';
2737	+	TextOut.Add(s);
2738	+
2739	+	SetLength(index,0);
2740	+	AddElements(0);
2741	+	TextOut.Add('</array>');
2742	+	Result := TextOut.Text;
2743	+	finally
2744	+	TextOut.Free;
2745	+	end;
2746	+	end;
2747	+
2748	+	procedure TSQLXMLReader.Reset;
2749	+	begin
2750	+	inherited Reset;
2751	+	FreeDataObjects;
2752	+	FXMLString := '';
2753	+	FreeMem(FBlobBuffer);
2754	+	end;
2755	+
2756	+	{ TJournalProcessor }
2757	+
2758	+	procedure TJournalProcessor.DoExecute;
2759	+	var token: TSQLTokens;
2760	+	LineState: TLineState;
2761	+	JnlEntry: TJnlEntry;
2762	+	Len: integer;
2763	+	tz: AnsiString;
2764	+
2765	+	procedure ClearJnlEntry;
2766	+	begin
2767	+	with JnlEntry do
2768	+	begin
2769	+	TransactionName := '';
2770	+	TPB := nil;
2771	+	QueryText :='';
2772	+	JnlEntryType := jeUnknown;
2773	+	SessionID := 0;
2774	+	TransactionID := 0;
2775	+	DefaultCompletion := taCommit;
2776	+	end;
2777	+	end;
2778	+
2779	+	function CreateTPB(TPBText: AnsiString): ITPB;
2780	+	var index: integer;
2781	+	begin
2782	+	Result := nil;
2783	+	if Length(TPBText) = 0 then
2784	+	Exit;
2785	+	Result := FFirebirdClientAPI.AllocateTPB;
2786	+	try
2787	+	index := Pos('[',TPBText);
2788	+	if index > 0 then
2789	+	system.Delete(TPBText,1,index);
2790	+	repeat
2791	+	index := Pos(',',TPBText);
2792	+	if index = 0 then
2793	+	begin
2794	+	index := Pos(']',TPBText);
2795	+	if index <> 0 then
2796	+	system.Delete(TPBText,index,1);
2797	+	Result.AddByTypeName(TPBText);
2798	+	break;
2799	+	end;
2800	+	Result.AddByTypeName(system.copy(TPBText,1,index-1));
2801	+	system.Delete(TPBText,1,index);
2802	+	until false;
2803	+	except
2804	+	Result := nil;
2805	+	raise;
2806	+	end;
2807	+	end;
2808	+
2809	+	begin
2810	+	LineState := lsInit;
2811	+	JnlEntry.JnlEntryType := jeUnknown;
2812	+	while not EOF do
2813	+	begin
2814	+	if LineState = lsInit then
2815	+	ClearJnlEntry;
2816	+	token := GetNextToken;
2817	+	with JnlEntry do
2818	+	case token of
2819	+	sqltAsterisk:
2820	+	if LineState = lsInit then
2821	+	LineState := lsJnlFound;
2822	+
2823	+	sqltIdentifier:
2824	+	if LineState = lsJnlFound then
2825	+	begin
2826	+	JnlEntryType := IdentifyJnlEntry(TokenText);
2827	+	LineState := lsGotJnlType;
2828	+	end
2829	+	else
2830	+	LineState := lsInit;
2831	+
2832	+	sqltQuotedString:
2833	+	if (LineState = lsGotJnlType)
2834	+	and ParseDateTimeTZString(TokenText,TimeStamp,tz) then
2835	+	LineState := lsGotTimestamp
2836	+	else
2837	+	LineState := lsInit;
2838	+
2839	+	sqltColon:
2840	+	case LineState of
2841	+	lsGotText1Length:
2842	+	begin
2843	+	if Len > 0 then
2844	+	begin
2845	+	if JnlEntryType = jeTransStart then
2846	+	TransactionName := ReadCharacters(Len)
2847	+	else
2848	+	QueryText := ReadCharacters(Len)
2849	+	end;
2850	+	if JnlEntryType = jeTransStart then
2851	+	LineState := lsGotText1
2852	+	else
2853	+	begin
2854	+	if assigned(FOnNextJournalEntry) then
2855	+	OnNextJournalEntry(JnlEntry);
2856	+	LineState := lsInit;
2857	+	end
2858	+	end;
2859	+
2860	+	lsGotText2Length:
2861	+	begin
2862	+	if Len > 0 then
2863	+	TPB :=  CreateTPB(ReadCharacters(Len));
2864	+	LineState := lsGotText2;
2865	+	end;
2866	+
2867	+	else
2868	+	if LineState <> lsGotJnlType then
2869	+	LineState := lsInit;
2870	+	end;
2871	+
2872	+	sqltComma:
2873	+	if not (LineState in [lsGotTimestamp,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2874	+	LineState := lsInit;
2875	+
2876	+	sqltNumberString:
2877	+	case LineState of
2878	+	lsGotTimestamp:
2879	+	begin
2880	+	SessionID := StrToInt(TokenText);
2881	+	LineState := lsGotSessionID;
2882	+	end;
2883	+
2884	+	lsGotSessionID:
2885	+	begin
2886	+	TransactionID := StrToInt(TokenText);
2887	+	if JnlEntryType in [jeTransCommit, jeTransRollback] then
2888	+	begin
2889	+	if assigned(FOnNextJournalEntry) then
2890	+	OnNextJournalEntry(JnlEntry);
2891	+	LineState := lsInit;
2892	+	end
2893	+	else
2894	+	LineState := lsGotTransactionID;
2895	+	end;
2896	+
2897	+	lsGotTransactionID:
2898	+	begin
2899	+	case JnlEntryType of
2900	+	jeTransStart:
2901	+	begin
2902	+	len := StrToInt(TokenText);
2903	+	LineState := lsGotText1Length;
2904	+	end;
2905	+
2906	+	jeQuery:
2907	+	begin
2908	+	len :=  StrToInt(TokenText);
2909	+	LineState := lsGotText1Length;
2910	+	end;
2911	+
2912	+	jeTransCommitRet,
2913	+	jeTransRollbackRet:
2914	+	begin
2915	+	OldTransactionID := StrToInt(TokenText);
2916	+	if assigned(FOnNextJournalEntry) then
2917	+	OnNextJournalEntry(JnlEntry);
2918	+	LineState := lsInit;
2919	+	end;
2920	+
2921	+	else
2922	+	LineState := lsInit;
2923	+	end; {case JnlEntryType}
2924	+
2925	+	end;
2926	+
2927	+	lsGotText1:
2928	+	begin
2929	+	len := StrToInt(TokenText);
2930	+	LineState := lsGotText2Length;
2931	+	end;
2932	+
2933	+	lsGotText2:
2934	+	begin
2935	+	if JnlEntryType = jeTransStart then
2936	+	begin
2937	+	DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2938	+	if assigned(FOnNextJournalEntry) then
2939	+	OnNextJournalEntry(JnlEntry);
2940	+	end;
2941	+	LineState := lsInit;
2942	+	end;
2943	+	end; {case LineState}
2944	+	end; {case token}
2945	+	end; {while}
2946	+	ClearJnlEntry;
2947	+	end;
2948	+
2949	+	function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2950	+	): TJnlEntryType;
2951	+	begin
2952	+	Result := jeUnknown;
2953	+	if Length(aTokenText) > 0 then
2954	+	case aTokenText[1] of
2955	+	'S':
2956	+	Result := jeTransStart;
2957	+	'C':
2958	+	Result := jeTransCommit;
2959	+	'c':
2960	+	Result := jeTransCommitRet;
2961	+	'R':
2962	+	Result := jeTransRollback;
2963	+	'r':
2964	+	Result := jeTransRollbackRet;
2965	+	'E':
2966	+	Result := jeTransEnd;
2967	+	'Q':
2968	+	Result := jeQuery;
2969	+	end;
2970	+	end;
2971	+
2972	+	class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2973	+	begin
2974	+	case je of
2975	+	jeTransStart:
2976	+	Result := 'Transaction Start';
2977	+	jeTransCommit:
2978	+	Result := 'Commit';
2979	+	jeTransCommitRet:
2980	+	Result := 'Commit Retaining';
2981	+	jeTransRollback:
2982	+	Result := 'Rollback';
2983	+	jeTransRollbackRet:
2984	+	Result := 'Rollback Retaining';
2985	+	jeTransEnd:
2986	+	Result := 'Transaction End';
2987	+	jeQuery:
2988	+	Result := 'Query';
2989	+	jeUnknown:
2990	+	Result := 'Unknown';
2991	+	end;
2992	+	end;
2993	+
2994	+	function TJournalProcessor.GetChar: AnsiChar;
2995	+	begin
2996	+	if FInStream.Read(Result,1) = 0 then
2997	+	Result := #0;
2998	+	end;
2999	+
3000	+	destructor TJournalProcessor.Destroy;
3001	+	begin
3002	+	FInStream.Free;
3003	+	inherited Destroy;
3004	+	end;
3005	+
3006	+	class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
3007	+	aOnNextJournalEntry: TOnNextJournalEntry);
3008	+	begin
3009	+	with TJournalProcessor.Create do
3010	+	try
3011	+	FInStream := TFileStream.Create(aFileName,fmOpenRead);
3012	+	FFirebirdClientAPI := api;
3013	+	OnNextJournalEntry := aOnNextJournalEntry;
3014	+	DoExecute;
3015	+	finally
3016	+	Free
3017	+	end;
3018	+	end;
3019	+
3020	+
3021		end.

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines