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/udr/client/IBUtils.pas (file contents), Revision 387 by tony, Wed Jan 19 13:34:42 2022 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, jeTransCommitFail, jeTransCommitRet, jeTransRollback,
724	+	jeTransRollbackFail, jeTransRollbackRet, jeTransEnd, jeQuery,jeUnknown);
725	+
726	+	TJnlEntry = record
727	+	JnlEntryType: TJnlEntryType;
728	+	Timestamp: TDateTime;
729	+	AttachmentID: cardinal;
730	+	SessionID: cardinal;
731	+	TransactionID: cardinal;
732	+	OldTransactionID: cardinal;
733	+	TransactionName: AnsiString;
734	+	TPB: ITPB;
735	+	DefaultCompletion: TTransactionCompletion;
736	+	QueryText: AnsiString;
737	+	end;
738	+
739	+	TOnNextJournalEntry = procedure(JnlEntry: TJnlEntry) of object;
740	+
741	+	{ TJournalProcessor - used to parse a client side journal}
742	+
743	+	TJournalProcessor = class(TSQLTokeniser)
744	+	private
745	+	type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,
746	+	lsGotAttachmentID, lsGotSessionID,
747	+	lsGotTransactionID,  lsGotOldTransactionID, lsGotText1Length,
748	+	lsGotText1, lsGotText2Length, lsGotText2);
749	+	private
750	+	FOnNextJournalEntry: TOnNextJournalEntry;
751	+	FInStream: TStream;
752	+	FFirebirdClientAPI: IFirebirdAPI;
753	+	procedure DoExecute;
754	+	function IdentifyJnlEntry(aTokenText: AnsiString): TJnlEntryType;
755	+	protected
756	+	function GetChar: AnsiChar; override;
757	+	property OnNextJournalEntry: TOnNextJournalEntry read FOnNextJournalEntry write FOnNextJournalEntry;
758	+	public
759	+	destructor Destroy; override;
760	+	class procedure Execute( aFileName: string; api: IFirebirdAPI; aOnNextJournalEntry: TOnNextJournalEntry);
761	+	class function JnlEntryText(je: TJnlEntryType): string;
762	+	end;
763	+
764
765		function Max(n1, n2: Integer): Integer;
766		function Min(n1, n2: Integer): Integer;
#	Line 634 | Line 783 | function ParseConnectString(ConnectStrin
783		var PortNo: AnsiString): boolean;
784		function GetProtocol(ConnectString: AnsiString): TProtocolAll;
785
786	+	{$IF declared(TFormatSettings)}
787	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
788	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
789	+	{$IFEND}
790	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
791	+	var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
792	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
793	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
794	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
795	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
796	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
797	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
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 StringToHex(octetString: string; MaxLineLength: integer): string; overload;
2019	+
2020	+	function ToHex(aValue: byte): string;
2021	+	const
2022	+	HexChars: array [0..15] of char = '0123456789ABCDEF';
2023	+	begin
2024	+	Result := HexChars[aValue shr 4] +
2025	+	HexChars[(aValue and $0F)];
2026	+	end;
2027	+
2028	+	var i, j: integer;
2029	+	begin
2030	+	i := 1;
2031	+	Result := '';
2032	+	if MaxLineLength = 0 then
2033	+	while i <= Length(octetString) do
2034	+	begin
2035	+	Result := Result +  ToHex(byte(octetString[i]));
2036	+	Inc(i);
2037	+	end
2038	+	else
2039	+	while i <= Length(octetString) do
2040	+	begin
2041	+	for j := 1 to MaxLineLength do
2042	+	begin
2043	+	if i > Length(octetString) then
2044	+	Exit
2045	+	else
2046	+	Result := Result + ToHex(byte(octetString[i]));
2047	+	inc(i);
2048	+	end;
2049	+	Result := Result + LineEnding;
2050	+	end;
2051	+	end;
2052	+
2053	+	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
2054	+	begin
2055	+	TextOut.Add(StringToHex(octetString,MaxLineLength));
2056	+	end;
2057	+
2058	+	{ TSQLXMLReader }
2059	+
2060	+	function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
2061	+	var i: TXMLTag;
2062	+	begin
2063	+	Result := false;
2064	+	for i := xtBlob to xtElt do
2065	+	if XMLTagDefs[i].TagValue = tag then
2066	+	begin
2067	+	xmlTag := XMLTagDefs[i].XMLTag;
2068	+	Result := true;
2069	+	break;
2070	+	end;
2071	+	end;
2072	+
2073	+	function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
2074	+	begin
2075	+	if (index < 0) or (index > ArrayDataCount) then
2076	+	ShowError(sArrayIndexError,[index]);
2077	+	Result := FArrayData[index];
2078	+	end;
2079	+
2080	+	function TSQLXMLReader.GetArrayDataCount: integer;
2081	+	begin
2082	+	Result := Length(FArrayData);
2083	+	end;
2084	+
2085	+	function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
2086	+	begin
2087	+	if (index < 0) or (index > BlobDataCount) then
2088	+	ShowError(sBlobIndexError,[index]);
2089	+	Result := FBlobData[index];
2090	+	end;
2091	+
2092	+	function TSQLXMLReader.GetBlobDataCount: integer;
2093	+	begin
2094	+	Result := Length(FBlobData);
2095	+	end;
2096	+
2097	+	function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
2098	+	var i: TXMLTag;
2099	+	begin
2100	+	Result := 'unknown';
2101	+	for i := xtBlob to xtElt do
2102	+	if XMLTagDefs[i].XMLTag = xmltag then
2103	+	begin
2104	+	Result := XMLTagDefs[i].TagValue;
2105	+	Exit;
2106	+	end;
2107	+	end;
2108	+
2109	+	procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
2110	+	begin
2111	+	case FXMLTagStack[FXMLTagIndex] of
2112	+	xtBlob:
2113	+	if FAttributeName = 'subtype' then
2114	+	FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
2115	+	else
2116	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2117	+
2118	+	xtArray:
2119	+	if FAttributeName = 'sqltype' then
2120	+	FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
2121	+	else
2122	+	if FAttributeName = 'relation_name' then
2123	+	FArrayData[FCurrentArray].relationName := attrValue
2124	+	else
2125	+	if FAttributeName = 'column_name' then
2126	+	FArrayData[FCurrentArray].columnName := attrValue
2127	+	else
2128	+	if FAttributeName = 'dim' then
2129	+	FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
2130	+	else
2131	+	if FAttributeName = 'length' then
2132	+	FArrayData[FCurrentArray].Size := StrToInt(attrValue)
2133	+	else
2134	+	if FAttributeName = 'scale' then
2135	+	FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
2136	+	else
2137	+	if FAttributeName = 'charset' then
2138	+	FArrayData[FCurrentArray].CharSet := attrValue
2139	+	else
2140	+	if FAttributeName = 'bounds' then
2141	+	ProcessBoundsList(attrValue)
2142	+	else
2143	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2144	+
2145	+	xtElt:
2146	+	if FAttributeName = 'ix' then
2147	+	with FArrayData[FCurrentArray] do
2148	+	Index[CurrentRow] :=  StrToInt(attrValue)
2149	+	else
2150	+	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2151	+	end;
2152	+	end;
2153	+
2154	+	procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
2155	+	var list: TStringList;
2156	+	i,j: integer;
2157	+	begin
2158	+	list := TStringList.Create;
2159	+	try
2160	+	list.Delimiter := ',';
2161	+	list.DelimitedText := boundsList;
2162	+	with FArrayData[FCurrentArray] do
2163	+	begin
2164	+	if dim <> list.Count then
2165	+	ShowError(sInvalidBoundsList,[boundsList]);
2166	+	SetLength(bounds,dim);
2167	+	for i := 0 to list.Count - 1 do
2168	+	begin
2169	+	j := Pos(':',list[i]);
2170	+	if j = 0 then
2171	+	raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
2172	+	bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
2173	+	bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
2174	+	end;
2175	+	end;
2176	+	finally
2177	+	list.Free;
2178	+	end;
2179	+	end;
2180	+
2181	+	procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
2182	+
2183	+	function nibble(hex: char): byte;
2184	+	begin
2185	+	case hex of
2186	+	'0': Result := 0;
2187	+	'1': Result := 1;
2188	+	'2': Result := 2;
2189	+	'3': Result := 3;
2190	+	'4': Result := 4;
2191	+	'5': Result := 5;
2192	+	'6': Result := 6;
2193	+	'7': Result := 7;
2194	+	'8': Result := 8;
2195	+	'9': Result := 9;
2196	+	'a','A': Result := 10;
2197	+	'b','B': Result := 11;
2198	+	'c','C': Result := 12;
2199	+	'd','D': Result := 13;
2200	+	'e','E': Result := 14;
2201	+	'f','F': Result := 15;
2202	+	end;
2203	+	end;
2204	+
2205	+	procedure RemoveWhiteSpace(var hexData: string);
2206	+	var i: integer;
2207	+	begin
2208	+	{Remove White Space}
2209	+	i := 1;
2210	+	while i <= length(hexData) do
2211	+	begin
2212	+	case hexData[i] of
2213	+	' ',#9,#10,#13:
2214	+	begin
2215	+	if i < Length(hexData) then
2216	+	Move(hexData[i+1],hexData[i],Length(hexData)-i);
2217	+	SetLength(hexData,Length(hexData)-1);
2218	+	end;
2219	+	else
2220	+	Inc(i);
2221	+	end;
2222	+	end;
2223	+	end;
2224	+
2225	+	procedure WriteToBlob(hexData: string);
2226	+	var i,j : integer;
2227	+	blength: integer;
2228	+	P: PByte;
2229	+	begin
2230	+	RemoveWhiteSpace(hexData);
2231	+	if odd(length(hexData)) then
2232	+	ShowError(sBinaryBlockMustbeEven,[nil]);
2233	+	blength := Length(hexData) div 2;
2234	+	ReallocMem(FBlobBuffer,blength);
2235	+	j := 1;
2236	+	P := FBlobBuffer;
2237	+	for i := 1 to blength do
2238	+	begin
2239	+	P^ := (nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]);
2240	+	Inc(j,2);
2241	+	Inc(P);
2242	+	end;
2243	+	FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
2244	+	end;
2245	+
2246	+	begin
2247	+	if tagValue = '' then Exit;
2248	+	case FXMLTagStack[FXMLTagIndex] of
2249	+	xtBlob:
2250	+	WriteToBlob(tagValue);
2251	+
2252	+	xtElt:
2253	+	with FArrayData[FCurrentArray] do
2254	+	ArrayIntf.SetAsString(index,tagValue);
2255	+
2256	+	end;
2257	+	end;
2258	+
2259	+	procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
2260	+	begin
2261	+	if FXMLTagIndex > MaxXMLTags then
2262	+	ShowError(sXMLStackOverFlow,[nil]);
2263	+	Inc(FXMLTagIndex);
2264	+	FXMLTagStack[FXMLTagIndex] := xmltag;
2265	+	FXMLString := '';
2266	+
2267	+	case xmltag of
2268	+	xtBlob:
2269	+	begin
2270	+	Inc(FCurrentBlob);
2271	+	SetLength(FBlobData,FCurrentBlob+1);
2272	+	FBlobData[FCurrentBlob].BlobIntf := nil;
2273	+	FBlobData[FCurrentBlob].SubType := 0;
2274	+	end;
2275	+
2276	+	xtArray:
2277	+	begin
2278	+	Inc(FCurrentArray);
2279	+	SetLength(FArrayData,FCurrentArray+1);
2280	+	with FArrayData[FCurrentArray] do
2281	+	begin
2282	+	ArrayIntf := nil;
2283	+	SQLType := 0;
2284	+	dim := 0;
2285	+	Size := 0;
2286	+	Scale := 0;
2287	+	CharSet := 'NONE';
2288	+	SetLength(Index,0);
2289	+	CurrentRow := -1;
2290	+	end;
2291	+	end;
2292	+
2293	+	xtElt:
2294	+	with FArrayData[FCurrentArray] do
2295	+	Inc(CurrentRow)
2296	+	end;
2297	+	end;
2298	+
2299	+	function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
2300	+	begin
2301	+	if FXMLTagIndex = 0 then
2302	+	ShowError(sXMLStackUnderflow,[nil]);
2303	+
2304	+	xmlTag := FXMLTagStack[FXMLTagIndex];
2305	+	case FXMLTagStack[FXMLTagIndex] of
2306	+	xtBlob:
2307	+	FBlobData[FCurrentBlob].BlobIntf.Close;
2308	+
2309	+	xtArray:
2310	+	FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
2311	+
2312	+	xtElt:
2313	+	Dec(FArrayData[FCurrentArray].CurrentRow);
2314	+	end;
2315	+	Dec(FXMLTagIndex);
2316	+	Result := FXMLTagIndex = 0;
2317	+	end;
2318	+
2319	+	procedure TSQLXMLReader.XMLTagEnter;
2320	+	var aCharSetID: integer;
2321	+	begin
2322	+	if (Attachment = nil) or not Attachment.IsConnected then
2323	+	ShowError(sNoDatabase);
2324	+	if Transaction = nil then
2325	+	ShowError(sNoTransaction);
2326	+	case FXMLTagStack[FXMLTagIndex] of
2327	+	xtBlob:
2328	+	begin
2329	+	if not Transaction.InTransaction then
2330	+	Transaction.Start;
2331	+	FBlobData[FCurrentBlob].BlobIntf := Attachment.CreateBlob(
2332	+	Transaction,FBlobData[FCurrentBlob].SubType);
2333	+	end;
2334	+
2335	+	xtArray:
2336	+	with FArrayData[FCurrentArray] do
2337	+	begin
2338	+	if not Transaction.InTransaction then
2339	+	Transaction.Start;
2340	+	Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
2341	+	SetLength(Index,dim);
2342	+	ArrayIntf := Attachment.CreateArray(
2343	+	Transaction,
2344	+	Attachment.CreateArrayMetaData(SQLType,
2345	+	relationName,columnName,Scale,Size,
2346	+	aCharSetID,dim,bounds)
2347	+	);
2348	+	end;
2349	+	end;
2350	+	end;
2351	+
2352	+	{This is where the XML tags are identified and the token stream modified in
2353	+	consequence}
2354	+
2355	+	function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
2356	+
2357	+	procedure NotAnXMLTag;
2358	+	begin
2359	+	begin
2360	+	if FXMLTagIndex = 0 then
2361	+	{nothing to do with XML so go back to processing SQL}
2362	+	begin
2363	+	QueueToken(token);
2364	+	ReleaseQueue(token);
2365	+	FXMLState := stNoXML
2366	+	end
2367	+	else
2368	+	begin
2369	+	{Not an XML tag, so just push back to XML Data}
2370	+	FXMLState := stXMLData;
2371	+	FXMLString := FXMLString + GetQueuedText;
2372	+	ResetQueue;
2373	+	end;
2374	+	end;
2375	+	end;
2376	+
2377	+	var XMLTag: TXMLTag;
2378	+	begin
2379	+	Result := inherited TokenFound(token);
2380	+	if not Result then Exit;
2381	+
2382	+	case FXMLState of
2383	+	stNoXML:
2384	+	if token = sqltLT then
2385	+	begin
2386	+	ResetQueue;
2387	+	QueueToken(token); {save in case this is not XML}
2388	+	FXMLState := stInTag;
2389	+	end;
2390	+
2391	+	stInTag:
2392	+	{Opening '<' found, now looking for tag name or end tag marker}
2393	+	case token of
2394	+	sqltIdentifier:
2395	+	begin
2396	+	if FindTag(TokenText,XMLTag) then
2397	+	begin
2398	+	XMLTagInit(XMLTag);
2399	+	QueueToken(token);
2400	+	FXMLState := stInTagBody;
2401	+	end
2402	+	else
2403	+	NotAnXMLTag;
2404	+	end;
2405	+
2406	+	sqltForwardSlash:
2407	+	FXMLState := stInEndTag;
2408	+
2409	+	else
2410	+	NotAnXMLTag;
2411	+	end {case token};
2412	+
2413	+	stInTagBody:
2414	+	{Tag name found. Now looking for attribute or closing '>'}
2415	+	case token of
2416	+	sqltIdentifier:
2417	+	begin
2418	+	FAttributeName := TokenText;
2419	+	QueueToken(token);
2420	+	FXMLState := stAttribute;
2421	+	end;
2422	+
2423	+	sqltGT:
2424	+	begin
2425	+	ResetQueue;
2426	+	XMLTagEnter;
2427	+	FXMLState := stXMLData;
2428	+	end;
2429	+
2430	+	sqltSpace,
2431	+	sqltEOL:
2432	+	QueueToken(token);
2433	+
2434	+	else
2435	+	NotAnXMLTag;
2436	+	end {case token};
2437	+
2438	+	stAttribute:
2439	+	{Attribute name found. Must be followed by an '=', a '>' or another tag name}
2440	+	case token of
2441	+	sqltEquals:
2442	+	begin
2443	+	QueueToken(token);
2444	+	FXMLState := stAttributeValue;
2445	+	end;
2446	+
2447	+	sqltSpace,
2448	+	sqltEOL:
2449	+	QueueToken(token);
2450	+
2451	+	sqltIdentifier:
2452	+	begin
2453	+	ProcessAttributeValue('');
2454	+	FAttributeName := TokenText;
2455	+	QueueToken(token);
2456	+	FXMLState := stAttribute;
2457	+	end;
2458	+
2459	+	sqltGT:
2460	+	begin
2461	+	ProcessAttributeValue('');
2462	+	ResetQueue;
2463	+	XMLTagEnter;
2464	+	FXMLState := stXMLData;
2465	+	end;
2466	+
2467	+	else
2468	+	NotAnXMLTag;
2469	+	end; {case token}
2470	+
2471	+	stAttributeValue:
2472	+	{Looking for attribute value as a single identifier or a double quoted value}
2473	+	case token of
2474	+	sqltIdentifier,sqltIdentifierInDoubleQuotes:
2475	+	begin
2476	+	ProcessAttributeValue(TokenText);
2477	+	QueueToken(token);
2478	+	FXMLState := stInTagBody;
2479	+	end;
2480	+
2481	+	sqltSpace,
2482	+	sqltEOL:
2483	+	QueueToken(token);
2484	+
2485	+	else
2486	+	NotAnXMLTag;
2487	+	end; {case token}
2488	+
2489	+	stXMLData:
2490	+	if token = sqltLT then
2491	+	begin
2492	+	QueueToken(token); {save in case this is not XML}
2493	+	FXMLState := stInTag;
2494	+	end
2495	+	else
2496	+	FXMLString := FXMLString + TokenText;
2497	+
2498	+	stInEndTag:
2499	+	{Opening '</' found, now looking for tag name}
2500	+	case token of
2501	+	sqltIdentifier:
2502	+	begin
2503	+	if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
2504	+	begin
2505	+	QueueToken(token);
2506	+	FXMLState := stInEndTagBody;
2507	+	end
2508	+	else
2509	+	ShowError(sInvalidEndTag,[TokenText]);
2510	+	end;
2511	+	else
2512	+	NotAnXMLTag;
2513	+	end {case token};
2514	+
2515	+	stInEndTagBody:
2516	+	{End tag name found, now looping for closing '>'}
2517	+	case Token of
2518	+	sqltGT:
2519	+	begin
2520	+	ProcessTagValue(FXMLString);
2521	+	if XMLTagEnd(XMLTag) then
2522	+	begin
2523	+	ResetQueue;
2524	+	QueueToken(sqltColon,':');
2525	+	case XMLTag of
2526	+	xtBlob:
2527	+	QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
2528	+
2529	+	xtArray:
2530	+	QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
2531	+	end;
2532	+	ReleaseQueue(token);
2533	+	FXMLState := stNoXML;
2534	+	end
2535	+	else
2536	+	FXMLState := stXMLData;
2537	+	end;
2538	+
2539	+	sqltSpace,
2540	+	sqltEOL:
2541	+	QueueToken(token);
2542	+
2543	+	else
2544	+	ShowError(sBadEndTagClosing);
2545	+	end; {case token}
2546	+
2547	+	end {Case FState};
2548	+
2549	+	{Only allow token to be returned if not processing an XML tag}
2550	+
2551	+	Result := FXMLState = stNoXML;
2552	+	end;
2553	+
2554	+	procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
2555	+	begin
2556	+	raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
2557	+	end;
2558	+
2559	+	procedure TSQLXMLReader.ShowError(msg: string);
2560	+	begin
2561	+	ShowError(msg,[nil]);
2562	+	end;
2563	+
2564	+	constructor TSQLXMLReader.Create;
2565	+	begin
2566	+	inherited;
2567	+	FXMLState := stNoXML;
2568	+	end;
2569	+
2570	+	procedure TSQLXMLReader.FreeDataObjects;
2571	+	begin
2572	+	FXMLTagIndex := 0;
2573	+	SetLength(FBlobData,0);
2574	+	FCurrentBlob := -1;
2575	+	SetLength(FArrayData,0);
2576	+	FCurrentArray := -1;
2577	+	end;
2578	+
2579	+	class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
2580	+	begin
2581	+	Result := FormatBlob(Field.AsString,Field.getSubtype);
2582	+	end;
2583	+
2584	+	class function TSQLXMLReader.FormatBlob(contents: string; subtype: integer
2585	+	): string;
2586	+	var TextOut: TStrings;
2587	+	begin
2588	+	TextOut := TStringList.Create;
2589	+	try
2590	+	TextOut.Add(Format('<blob subtype="%d">',[subtype]));
2591	+	StringToHex(contents,TextOut,BlobLineLength);
2592	+	TextOut.Add('</blob>');
2593	+	Result := TextOut.Text;
2594	+	finally
2595	+	TextOut.Free;
2596	+	end;
2597	+	end;
2598	+
2599	+
2600	+	class function TSQLXMLReader.FormatArray(ar: IArray
2601	+	): string;
2602	+	var index: array of integer;
2603	+	TextOut: TStrings;
2604	+
2605	+	procedure AddElements(dim: integer; indent:string = ' ');
2606	+	var i: integer;
2607	+	recurse: boolean;
2608	+	begin
2609	+	SetLength(index,dim+1);
2610	+	recurse := dim < ar.GetDimensions - 1;
2611	+	with ar.GetBounds[dim] do
2612	+	for i := LowerBound to UpperBound do
2613	+	begin
2614	+	index[dim] := i;
2615	+	if recurse then
2616	+	begin
2617	+	TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
2618	+	AddElements(dim+1,indent + ' ');
2619	+	TextOut.Add('</elt>');
2620	+	end
2621	+	else
2622	+	if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
2623	+	(ar.GetCharSetID = 1) then
2624	+	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
2625	+	else
2626	+	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
2627	+	end;
2628	+	end;
2629	+
2630	+	var
2631	+	s: string;
2632	+	bounds: TArrayBounds;
2633	+	i: integer;
2634	+	boundsList: string;
2635	+	begin
2636	+	TextOut := TStringList.Create;
2637	+	try
2638	+	if ar.GetCharSetWidth = 0 then
2639	+	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2640	+	[ar.GetDimensions,ar.GetSQLType,ar.GetSize,
2641	+	ar.GetTableName,ar.GetColumnName])
2642	+	else
2643	+	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2644	+	[ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
2645	+	ar.GetTableName,ar.GetColumnName]);
2646	+	case ar.GetSQLType of
2647	+	SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
2648	+	s := s + Format(' scale = "%d"',[ ar.GetScale]);
2649	+	SQL_TEXT,
2650	+	SQL_VARYING:
2651	+	s := s + Format(' charset = "%s"',[ar.GetAttachment.GetCharsetName(ar.GetCharSetID)]);
2652	+	end;
2653	+	bounds := ar.GetBounds;
2654	+	boundsList := '';
2655	+	for i := 0 to length(bounds) - 1 do
2656	+	begin
2657	+	if i <> 0 then boundsList := boundsList + ',';
2658	+	boundsList := boundsList + Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
2659	+	end;
2660	+	s := s + Format(' bounds="%s"',[boundsList]);
2661	+	s := s + '>';
2662	+	TextOut.Add(s);
2663	+
2664	+	SetLength(index,0);
2665	+	AddElements(0);
2666	+	TextOut.Add('</array>');
2667	+	Result := TextOut.Text;
2668	+	finally
2669	+	TextOut.Free;
2670	+	end;
2671	+	end;
2672	+
2673	+	procedure TSQLXMLReader.Reset;
2674	+	begin
2675	+	inherited Reset;
2676	+	FreeDataObjects;
2677	+	FXMLString := '';
2678	+	FreeMem(FBlobBuffer);
2679	+	end;
2680	+
2681	+	{ TJournalProcessor }
2682	+
2683	+	procedure TJournalProcessor.DoExecute;
2684	+	var token: TSQLTokens;
2685	+	LineState: TLineState;
2686	+	JnlEntry: TJnlEntry;
2687	+	Len: integer;
2688	+	tz: AnsiString;
2689	+
2690	+	procedure ClearJnlEntry;
2691	+	begin
2692	+	with JnlEntry do
2693	+	begin
2694	+	TransactionName := '';
2695	+	TPB := nil;
2696	+	QueryText :='';
2697	+	JnlEntryType := jeUnknown;
2698	+	SessionID := 0;
2699	+	TransactionID := 0;
2700	+	DefaultCompletion := taCommit;
2701	+	end;
2702	+	end;
2703	+
2704	+	function CreateTPB(TPBText: AnsiString): ITPB;
2705	+	var index: integer;
2706	+	begin
2707	+	Result := nil;
2708	+	if Length(TPBText) = 0 then
2709	+	Exit;
2710	+	Result := FFirebirdClientAPI.AllocateTPB;
2711	+	try
2712	+	index := Pos('[',TPBText);
2713	+	if index > 0 then
2714	+	system.Delete(TPBText,1,index);
2715	+	repeat
2716	+	index := Pos(',',TPBText);
2717	+	if index = 0 then
2718	+	begin
2719	+	index := Pos(']',TPBText);
2720	+	if index <> 0 then
2721	+	system.Delete(TPBText,index,1);
2722	+	Result.AddByTypeName(TPBText);
2723	+	break;
2724	+	end;
2725	+	Result.AddByTypeName(system.copy(TPBText,1,index-1));
2726	+	system.Delete(TPBText,1,index);
2727	+	until false;
2728	+	except
2729	+	Result := nil;
2730	+	raise;
2731	+	end;
2732	+	end;
2733	+
2734	+	begin
2735	+	LineState := lsInit;
2736	+	JnlEntry.JnlEntryType := jeUnknown;
2737	+	while not EOF do
2738	+	begin
2739	+	if LineState = lsInit then
2740	+	ClearJnlEntry;
2741	+	token := GetNextToken;
2742	+	with JnlEntry do
2743	+	case token of
2744	+	sqltAsterisk:
2745	+	if LineState = lsInit then
2746	+	LineState := lsJnlFound;
2747	+
2748	+	sqltIdentifier:
2749	+	if LineState = lsJnlFound then
2750	+	begin
2751	+	JnlEntryType := IdentifyJnlEntry(TokenText);
2752	+	LineState := lsGotJnlType;
2753	+	end
2754	+	else
2755	+	LineState := lsInit;
2756	+
2757	+	sqltQuotedString:
2758	+	if (LineState = lsGotJnlType)
2759	+	and ParseDateTimeTZString(TokenText,TimeStamp,tz) then
2760	+	LineState := lsGotTimestamp
2761	+	else
2762	+	LineState := lsInit;
2763	+
2764	+	sqltColon:
2765	+	case LineState of
2766	+	lsGotText1Length:
2767	+	begin
2768	+	if Len > 0 then
2769	+	begin
2770	+	if JnlEntryType = jeTransStart then
2771	+	TransactionName := ReadCharacters(Len)
2772	+	else
2773	+	QueryText := ReadCharacters(Len)
2774	+	end;
2775	+	if JnlEntryType = jeTransStart then
2776	+	LineState := lsGotText1
2777	+	else
2778	+	begin
2779	+	if assigned(FOnNextJournalEntry) then
2780	+	OnNextJournalEntry(JnlEntry);
2781	+	LineState := lsInit;
2782	+	end
2783	+	end;
2784	+
2785	+	lsGotText2Length:
2786	+	begin
2787	+	if Len > 0 then
2788	+	TPB :=  CreateTPB(ReadCharacters(Len));
2789	+	LineState := lsGotText2;
2790	+	end;
2791	+
2792	+	else
2793	+	if LineState <> lsGotJnlType then
2794	+	LineState := lsInit;
2795	+	end;
2796	+
2797	+	sqltComma:
2798	+	if not (LineState in [lsGotTimestamp,lsGotAttachmentID,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2799	+	LineState := lsInit;
2800	+
2801	+	sqltNumberString:
2802	+	case LineState of
2803	+	lsGotTimestamp:
2804	+	begin
2805	+	AttachmentID := StrToInt(TokenText);
2806	+	LineState := lsGotAttachmentID;
2807	+	end;
2808	+
2809	+	lsGotAttachmentID:
2810	+	begin
2811	+	SessionID := StrToInt(TokenText);
2812	+	LineState := lsGotSessionID;
2813	+	end;
2814	+
2815	+	lsGotSessionID:
2816	+	begin
2817	+	TransactionID := StrToInt(TokenText);
2818	+	if JnlEntryType in [jeTransCommit, jeTransCommitFail, jeTransRollback, jeTransRollbackFail] then
2819	+	begin
2820	+	if assigned(FOnNextJournalEntry) then
2821	+	OnNextJournalEntry(JnlEntry);
2822	+	LineState := lsInit;
2823	+	end
2824	+	else
2825	+	LineState := lsGotTransactionID;
2826	+	end;
2827	+
2828	+	lsGotTransactionID:
2829	+	begin
2830	+	case JnlEntryType of
2831	+	jeTransStart:
2832	+	begin
2833	+	len := StrToInt(TokenText);
2834	+	LineState := lsGotText1Length;
2835	+	end;
2836	+
2837	+	jeQuery:
2838	+	begin
2839	+	len :=  StrToInt(TokenText);
2840	+	LineState := lsGotText1Length;
2841	+	end;
2842	+
2843	+	jeTransCommitRet,
2844	+	jeTransCommitFail,
2845	+	jeTransRollbackFail,
2846	+	jeTransRollbackRet:
2847	+	begin
2848	+	OldTransactionID := StrToInt(TokenText);
2849	+	if assigned(FOnNextJournalEntry) then
2850	+	OnNextJournalEntry(JnlEntry);
2851	+	LineState := lsInit;
2852	+	end;
2853	+
2854	+	else
2855	+	LineState := lsInit;
2856	+	end; {case JnlEntryType}
2857	+
2858	+	end;
2859	+
2860	+	lsGotText1:
2861	+	begin
2862	+	len := StrToInt(TokenText);
2863	+	LineState := lsGotText2Length;
2864	+	end;
2865	+
2866	+	lsGotText2:
2867	+	begin
2868	+	if JnlEntryType = jeTransStart then
2869	+	begin
2870	+	DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2871	+	if assigned(FOnNextJournalEntry) then
2872	+	OnNextJournalEntry(JnlEntry);
2873	+	end;
2874	+	LineState := lsInit;
2875	+	end;
2876	+	end; {case LineState}
2877	+	end; {case token}
2878	+	end; {while}
2879	+	ClearJnlEntry;
2880	+	end;
2881	+
2882	+	function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2883	+	): TJnlEntryType;
2884	+	begin
2885	+	Result := jeUnknown;
2886	+	if Length(aTokenText) > 0 then
2887	+	case aTokenText[1] of
2888	+	'S':
2889	+	Result := jeTransStart;
2890	+	'C':
2891	+	Result := jeTransCommit;
2892	+	'c':
2893	+	Result := jeTransCommitRet;
2894	+	'R':
2895	+	Result := jeTransRollback;
2896	+	'r':
2897	+	Result := jeTransRollbackRet;
2898	+	'E':
2899	+	Result := jeTransEnd;
2900	+	'Q':
2901	+	Result := jeQuery;
2902	+	'F':
2903	+	Result := jeTransCommitFail;
2904	+	'f':
2905	+	Result := jeTransRollbackFail;
2906	+	end;
2907	+	end;
2908	+
2909	+	class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2910	+	begin
2911	+	case je of
2912	+	jeTransStart:
2913	+	Result := 'Transaction Start';
2914	+	jeTransCommit:
2915	+	Result := 'Commit';
2916	+	jeTransCommitFail:
2917	+	Result := 'Commit (Failed)';
2918	+	jeTransCommitRet:
2919	+	Result := 'Commit Retaining';
2920	+	jeTransRollback:
2921	+	Result := 'Rollback';
2922	+	jeTransRollbackFail:
2923	+	Result := 'Rollback (Failed)';
2924	+	jeTransRollbackRet:
2925	+	Result := 'Rollback Retaining';
2926	+	jeTransEnd:
2927	+	Result := 'Transaction End';
2928	+	jeQuery:
2929	+	Result := 'Query';
2930	+	jeUnknown:
2931	+	Result := 'Unknown';
2932	+	end;
2933	+	end;
2934	+
2935	+	function TJournalProcessor.GetChar: AnsiChar;
2936	+	begin
2937	+	if FInStream.Read(Result,1) = 0 then
2938	+	Result := #0;
2939	+	end;
2940	+
2941	+	destructor TJournalProcessor.Destroy;
2942	+	begin
2943	+	FInStream.Free;
2944	+	inherited Destroy;
2945	+	end;
2946	+
2947	+	class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
2948	+	aOnNextJournalEntry: TOnNextJournalEntry);
2949	+	begin
2950	+	with TJournalProcessor.Create do
2951	+	try
2952	+	FInStream := TFileStream.Create(aFileName,fmOpenRead);
2953	+	FFirebirdClientAPI := api;
2954	+	OnNextJournalEntry := aOnNextJournalEntry;
2955	+	DoExecute;
2956	+	finally
2957	+	Free
2958	+	end;
2959	+	end;
2960	+
2961	+
2962		end.

Comparing:
ibx/trunk/fbintf/IBUtils.pas (property svn:eol-style), Revision 311 by tony, Mon Aug 24 09:32:58 2020 UTC vs.
ibx/branches/udr/client/IBUtils.pas (property svn:eol-style), Revision 387 by tony, Wed Jan 19 13:34:42 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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