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 354 by tony, Sat Oct 23 14:32:11 2021 UTC vs.
ibx/branches/udr/client/IBUtils.pas (file contents), Revision 371 by tony, Wed Jan 5 15:21:22 2022 UTC

#	Line 49 | Line 49 | 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 301 | Line 310 | const
310		TAB  = #9;
311		NULL_TERMINATOR = #0;
312
304	–	{$IFNDEF FPC}
305	–	LineEnding = CRLF;
306	–	{$ENDIF}
307	–
313		{SQL Reserved words in alphabetical order}
314
315		sqlReservedWords: array [TSQLReservedWords] of string = (
#	Line 558 | 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 614 | 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	+	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 648 | Line 795 | function FBFormatDateTime(fmt: AnsiStrin
795		function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
796		function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
797		function StripLeadingZeros(Value: AnsiString): AnsiString;
798	<	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
799	<	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
#	Line 664 | Line 811 | uses FBMessages, Math
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
#	Line 1451 | 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 1843 | Line 2015 | begin
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;
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	<	Result := false;
2031	<	ds := 0;
2032	<	exponent := 0;
2033	<	S := Trim(S);
1855	<	Value := 0;
1856	<	scale := 0;
1857	<	if Length(S) = 0 then
1858	<	Exit;
1859	<	{$IF declared(DefaultFormatSettings)}
1860	<	with DefaultFormatSettings do
1861	<	{$ELSE}
1862	<	{$IF declared(FormatSettings)}
1863	<	with FormatSettings do
1864	<	{$IFEND}
1865	<	{$IFEND}
2030	>	i := 1;
2031	>	Result := '';
2032	>	if MaxLineLength = 0 then
2033	>	while i <= Length(octetString) do
2034		begin
2035	<	{ThousandSeparator not allowed as by Delphi specs}
2036	<	if (ThousandSeparator <> DecimalSeparator) and
2037	<	(Pos(ThousandSeparator, S) <> 0) then
2038	<	Exit;
2039	<
2040	<	for i := length(S) downto 1 do
2041	<	begin
1874	<	if S[i] = AnsiChar(DecimalSeparator) then
1875	<	begin
1876	<	if ds <> 0 then Exit; {only one allowed}
1877	<	ds := i-1;
1878	<	dec(exponent);
1879	<	system.Delete(S,i,1);
1880	<	end
1881	<	else
1882	<	if S[i] in ['+','-'] then
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 > 1) and not (S[i-1] in ['e','E']) then
2044	<	Exit; {malformed}
2045	<	end
2046	<	else
2047	<	if S[i] in ['e','E'] then {scientific notation}
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	<	if ds <> 0 then Exit; {not permitted in exponent}
2170	<	if exponent <> 0 then Exit; {only one allowed}
2171	<	exponent := i;
2172	<	end
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	<	if not (S[i] in ['0'..'9']) then
2221	<	Exit; {bad character}
2220	>	Inc(i);
2221	>	end;
2222		end;
2223	+	end;
2224
2225	<	if exponent > 0 then
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	<	Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
2240	<	if Result then
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	<	{adjust scale for decimal point}
2477	<	if ds > 0 then
2478	<	Scale := Scale - (exponent - ds - 1);
1907	<	Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
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 ds <> 0 then
2658	<	scale := ds - Length(S);
1914	<	Result := TryStrToInt64(S,Value);
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	<	function NumericToDouble(aValue: Int64; aScale: integer): double;
2673	>	procedure TSQLXMLReader.Reset;
2674		begin
2675	<	Result := aValue * IntPower(10,aScale)
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, jeTransRollback] 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	+	jeTransRollbackRet:
2845	+	begin
2846	+	OldTransactionID := StrToInt(TokenText);
2847	+	if assigned(FOnNextJournalEntry) then
2848	+	OnNextJournalEntry(JnlEntry);
2849	+	LineState := lsInit;
2850	+	end;
2851	+
2852	+	else
2853	+	LineState := lsInit;
2854	+	end; {case JnlEntryType}
2855	+
2856	+	end;
2857	+
2858	+	lsGotText1:
2859	+	begin
2860	+	len := StrToInt(TokenText);
2861	+	LineState := lsGotText2Length;
2862	+	end;
2863	+
2864	+	lsGotText2:
2865	+	begin
2866	+	if JnlEntryType = jeTransStart then
2867	+	begin
2868	+	DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2869	+	if assigned(FOnNextJournalEntry) then
2870	+	OnNextJournalEntry(JnlEntry);
2871	+	end;
2872	+	LineState := lsInit;
2873	+	end;
2874	+	end; {case LineState}
2875	+	end; {case token}
2876	+	end; {while}
2877	+	ClearJnlEntry;
2878	+	end;
2879	+
2880	+	function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2881	+	): TJnlEntryType;
2882	+	begin
2883	+	Result := jeUnknown;
2884	+	if Length(aTokenText) > 0 then
2885	+	case aTokenText[1] of
2886	+	'S':
2887	+	Result := jeTransStart;
2888	+	'C':
2889	+	Result := jeTransCommit;
2890	+	'c':
2891	+	Result := jeTransCommitRet;
2892	+	'R':
2893	+	Result := jeTransRollback;
2894	+	'r':
2895	+	Result := jeTransRollbackRet;
2896	+	'E':
2897	+	Result := jeTransEnd;
2898	+	'Q':
2899	+	Result := jeQuery;
2900	+	end;
2901	+	end;
2902	+
2903	+	class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2904	+	begin
2905	+	case je of
2906	+	jeTransStart:
2907	+	Result := 'Transaction Start';
2908	+	jeTransCommit:
2909	+	Result := 'Commit';
2910	+	jeTransCommitRet:
2911	+	Result := 'Commit Retaining';
2912	+	jeTransRollback:
2913	+	Result := 'Rollback';
2914	+	jeTransRollbackRet:
2915	+	Result := 'Rollback Retaining';
2916	+	jeTransEnd:
2917	+	Result := 'Transaction End';
2918	+	jeQuery:
2919	+	Result := 'Query';
2920	+	jeUnknown:
2921	+	Result := 'Unknown';
2922	+	end;
2923	+	end;
2924	+
2925	+	function TJournalProcessor.GetChar: AnsiChar;
2926	+	begin
2927	+	if FInStream.Read(Result,1) = 0 then
2928	+	Result := #0;
2929	+	end;
2930	+
2931	+	destructor TJournalProcessor.Destroy;
2932	+	begin
2933	+	FInStream.Free;
2934	+	inherited Destroy;
2935	+	end;
2936	+
2937	+	class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
2938	+	aOnNextJournalEntry: TOnNextJournalEntry);
2939	+	begin
2940	+	with TJournalProcessor.Create do
2941	+	try
2942	+	FInStream := TFileStream.Create(aFileName,fmOpenRead);
2943	+	FFirebirdClientAPI := api;
2944	+	OnNextJournalEntry := aOnNextJournalEntry;
2945	+	DoExecute;
2946	+	finally
2947	+	Free
2948	+	end;
2949	+	end;
2950	+
2951	+
2952		end.

Diff Legend

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