ViewVC Help

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

root/public/ibx/trunk/runtime/nongui/ibxscript.pas

Comparing ibx/trunk/runtime/nongui/ibxscript.pas (file contents):
Revision 380 by tony, Mon Jan 10 10:13:17 2022 UTC vs.
Revision 402 by tony, Mon Aug 1 10:07:24 2022 UTC

#	Line 36 | Line 36 | uses Classes, IBDatabase,  IBSQL, IB, IB
36		type
37
38		TOnNextLine = procedure(Sender: TObject; Line: string) of object;
39	–	TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
40	–
41	–	{ TSQLXMLReader }
42	–
43	–	TSQLXMLReader = class(TSQLTokeniser)
44	–	private
45	–	type
46	–	TXMLStates =  (stNoXML, stInTag,stInTagBody,
47	–	stAttribute,stAttributeValue,stQuotedAttributeValue,
48	–	stInEndTag, stInEndTagBody,
49	–	stXMLData);
50	–
51	–	TXMLTag    =   (xtNone,xtBlob,xtArray,xtElt);
52	–
53	–	TXMLTagDef = record
54	–	XMLTag: TXMLTag;
55	–	TagValue: string;
56	–	end;
57	–
58	–	const
59	–	XMLTagDefs: array [xtBlob..xtElt] of TXMLTagDef = (
60	–	(XMLTag: xtBlob;   TagValue: 'blob'),
61	–	(XMLTag: xtArray;  TagValue: 'array'),
62	–	(XMLTag: xtElt;    TagValue: 'elt')
63	–	);
64	–	MaxXMLTags = 20;
65	–	BlobLineLength = 40;
66	–
67	–	public
68	–	const
69	–	ibx_blob = 'IBX_BLOB';
70	–	ibx_array = 'IBX_ARRAY';
71	–
72	–	type
73	–	TBlobData = record
74	–	BlobIntf: IBlob;
75	–	SubType: cardinal;
76	–	end;
77	–
78	–	TArrayData = record
79	–	ArrayIntf: IArray;
80	–	SQLType: cardinal;
81	–	relationName: string;
82	–	columnName: string;
83	–	dim: cardinal;
84	–	Size: cardinal;
85	–	Scale: integer;
86	–	CharSet: string;
87	–	bounds: TArrayBounds;
88	–	CurrentRow: integer;
89	–	Index: array of integer;
90	–	end;
91	–
92	–	private
93	–	FDatabase: TIBDatabase;
94	–	FOnProgressEvent: TOnProgressEvent;
95	–	FTransaction: TIBTransaction;
96	–	FXMLState: TXMLStates;
97	–	FXMLTagStack: array [1..MaxXMLTags] of TXMLTag;
98	–	FXMLTagIndex: integer;
99	–	FAttributeName: string;
100	–	FXMLData: string;
101	–	FBlobData: array of TBlobData;
102	–	FCurrentBlob: integer;
103	–	FBlobBuffer: PChar;
104	–	FArrayData: array of TArrayData;
105	–	FCurrentArray: integer;
106	–	FXMLString: string;
107	–	function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
108	–	function GetArrayData(index: integer): TArrayData;
109	–	function GetArrayDataCount: integer;
110	–	function GetBlobData(index: integer): TBlobData;
111	–	function GetBlobDataCount: integer;
112	–	function GetTagName(xmltag: TXMLTag): string;
113	–	procedure ProcessAttributeValue(attrValue: string);
114	–	procedure ProcessBoundsList(boundsList: string);
115	–	procedure ProcessTagValue(tagValue: string);
116	–	procedure XMLTagInit(xmltag: TXMLTag);
117	–	function XMLTagEnd(var xmltag: TXMLTag): boolean;
118	–	procedure XMLTagEnter;
119	–	protected
120	–	function GetErrorPrefix: string; virtual; abstract;
121	–	function TokenFound(var token: TSQLTokens): boolean; override;
122	–	procedure Reset; override;
123	–	procedure ShowError(msg: string; params: array of const); virtual; overload;
124	–	procedure ShowError(msg: string); overload;
125	–	public
126	–	constructor Create;
127	–	procedure FreeDataObjects;
128	–	class function FormatBlob(Field: ISQLData): string;
129	–	class function FormatArray(Database: TIBDatabase; ar: IArray): string;
130	–	property BlobData[index: integer]: TBlobData read GetBlobData;
131	–	property BlobDataCount: integer read GetBlobDataCount;
132	–	property ArrayData[index: integer]: TArrayData read GetArrayData;
133	–	property ArrayDataCount: integer read GetArrayDataCount;
134	–	property Database: TIBDatabase read FDatabase write FDatabase;
135	–	property Transaction: TIBTransaction read FTransaction write FTransaction;
136	–	property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
137	–	end;
39
40		{ TSQLStatementReader }
41
#	Line 143 | Line 44 | type
44		type
45		TSQLState = (stDefault, stInStmt, stInBlock, stInArrayDim, stInDeclare);
46		private
47	+	FDatabase: TIBDatabase;
48		FHasBegin: boolean;
49		FOnNextLine: TOnNextLine;
50		FTerminator: char;
51	+	FTransaction: TIBTransaction;
52		protected
53		procedure EchoNextLine(aLine: string);
54	+	function GetAttachment: IAttachment; override;
55	+	function GetTransaction: ITransaction; override;
56		public
57		constructor Create;
58		function GetNextStatement(var stmt: string) : boolean; virtual;
59		property HasBegin: boolean read FHasBegin;
60		property Terminator: char read FTerminator write FTerminator default DefaultTerminator;
61		property OnNextLine: TOnNextLine read FOnNextLine write FOnNextLine;
62	+	property Database: TIBDatabase read FDatabase write FDatabase;
63	+	property Transaction: TIBTransaction read FTransaction write FTransaction;
64		end;
65
66
#	Line 170 | Line 77 | type
77		FIndex: integer;
78		FCurLine: string;
79		protected
80	<	function GetChar: char; override;
81	<	function GetErrorPrefix: string; override;
80	>	function GetChar: AnsiChar; override;
81	>	function GetErrorPrefix: AnsiString; override;
82		public
83		procedure Reset; override;
84		procedure SetStreamSource(Lines: TStrings); overload;
#	Line 195 | Line 102 | type
102		FNextStatement: boolean;
103		function GetNextLine(var Line: string):boolean;
104		protected
105	<	function GetChar: char; override;
106	<	function GetErrorPrefix: string; override;
105	>	function GetChar: AnsiChar; override;
106	>	function GetErrorPrefix: AnsiString; override;
107		public
108		constructor Create(aPrompt: string='SQL>'; aContinue: string = 'CON>');
109		function GetNextStatement(var stmt: string) : boolean; override;
#	Line 371 | Line 278 | type
278		function ExecSQLScript(sql: string): boolean;
279		end;
280
374	–	function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
375	–	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
376	–
281
282		resourcestring
283		sInvalidSetStatement = 'Invalid %s Statement - %s';
284	+	sInvalidCharacterSet = 'Unrecognised character set name - "%s"';
285	+	sOnLineError = 'On Line %d Character %d: ';
286
287		implementation
288
#	Line 386 | Line 292 | resourcestring
292		sNoSelectSQL = 'Select SQL Statements are not supported';
293		sNoParamQueries =  'Parameterised Queries are not supported';
294		sResolveQueryParam =  'Resolving Query Parameter: %s';
389	–	sXMLStackUnderflow = 'XML Stack Underflow';
390	–	sInvalidEndTag = 'XML End Tag Mismatch - %s';
391	–	sBadEndTagClosing = 'XML End Tag incorrectly closed';
392	–	sXMLStackOverFlow = 'XML Stack Overflow';
393	–	sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
394	–	sInvalidBoundsList = 'Invalid array bounds list - "%s"';
395	–	sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
396	–	sInvalidCharacterSet = 'Unrecognised character set name - "%s"';
397	–	sOnLineError = 'On Line %d Character %d: ';
398	–	sArrayIndexError = 'Array Index Error (%d)';
399	–	sBlobIndexError = 'Blob Index Error (%d)';
295		sStatementError = 'Error processing SQL statement: %s %s - for statement "%s"';
401	–	//  sNotInArray = 'elt tag found but not in an XML array tag';
402	–	sNoDatabase = 'Missing database for xml tag import';
403	–	sNoTransaction = 'Missing transaction for xml tag import';
404	–
405	–	function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
406	–
407	–	function ToHex(aValue: byte): string;
408	–	const
409	–	HexChars: array [0..15] of char = '0123456789ABCDEF';
410	–	begin
411	–	Result := HexChars[aValue shr 4] +
412	–	HexChars[(aValue and $0F)];
413	–	end;
296
297	<	var i, j: integer;
297	>	{ TSQLStatementReader }
298	>
299	>	procedure TSQLStatementReader.EchoNextLine(aLine: string);
300		begin
301	<	i := 1;
302	<	Result := '';
419	<	if MaxLineLength = 0 then
420	<	while i <= Length(octetString) do
421	<	begin
422	<	Result += ToHex(byte(octetString[i]));
423	<	Inc(i);
424	<	end
425	<	else
426	<	while i <= Length(octetString) do
427	<	begin
428	<	for j := 1 to MaxLineLength do
429	<	begin
430	<	if i > Length(octetString) then
431	<	Exit
432	<	else
433	<	Result += ToHex(byte(octetString[i]));
434	<	inc(i);
435	<	end;
436	<	Result += LineEnding;
437	<	end;
301	>	if assigned(FOnNextLine) then
302	>	OnNextLine(self,aLine);
303		end;
304
305	<	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
305	>	function TSQLStatementReader.GetAttachment: IAttachment;
306		begin
307	<	TextOut.Add(StringToHex(octetString,MaxLineLength));
307	>	if FDatabase <> nil then
308	>	Result := FDatabase.Attachment
309	>	else
310	>	Result := nil;
311		end;
312
313	<	{ TSQLStatementReader }
446	<
447	<	procedure TSQLStatementReader.EchoNextLine(aLine: string);
313	>	function TSQLStatementReader.GetTransaction: ITransaction;
314		begin
315	<	if assigned(FOnNextLine) then
316	<	OnNextLine(self,aLine);
315	>	if FTransaction <> nil then
316	>	Result := FTransaction.TransactionIntf
317	>	else
318	>	Result := nil;
319		end;
320
321		constructor TSQLStatementReader.Create;
#	Line 463 | Line 331 | var State: TSQLState;
331		EndOfStatement: boolean;
332		begin
333		FHasBegin := false;
466	–	Result := false;
334		EndOfStatement := false;
335		Nested := 0;
336		stmt := '';
#	Line 642 | Line 509 | begin
509		end;
510		end;
511		end;
512	+	//    writeln(stmt);
513		end;
514		Result := stmt <> '';
515		end;
516
649	–	{ TSQLXMLReader }
650	–
651	–	function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
652	–	var i: TXMLTag;
653	–	begin
654	–	Result := false;
655	–	for i := xtBlob to xtElt do
656	–	if XMLTagDefs[i].TagValue = tag then
657	–	begin
658	–	xmlTag := XMLTagDefs[i].XMLTag;
659	–	Result := true;
660	–	break;
661	–	end;
662	–	end;
663	–
664	–	function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
665	–	begin
666	–	if (index < 0) or (index > ArrayDataCount) then
667	–	ShowError(sArrayIndexError,[index]);
668	–	Result := FArrayData[index];
669	–	end;
670	–
671	–	function TSQLXMLReader.GetArrayDataCount: integer;
672	–	begin
673	–	Result := Length(FArrayData);
674	–	end;
675	–
676	–	function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
677	–	begin
678	–	if (index < 0) or (index > BlobDataCount) then
679	–	ShowError(sBlobIndexError,[index]);
680	–	Result := FBlobData[index];
681	–	end;
682	–
683	–	function TSQLXMLReader.GetBlobDataCount: integer;
684	–	begin
685	–	Result := Length(FBlobData);
686	–	end;
687	–
688	–	function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
689	–	var i: TXMLTag;
690	–	begin
691	–	Result := 'unknown';
692	–	for i := xtBlob to xtElt do
693	–	if XMLTagDefs[i].XMLTag = xmltag then
694	–	begin
695	–	Result := XMLTagDefs[i].TagValue;
696	–	Exit;
697	–	end;
698	–	end;
699	–
700	–	procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
701	–	begin
702	–	case FXMLTagStack[FXMLTagIndex] of
703	–	xtBlob:
704	–	if FAttributeName = 'subtype' then
705	–	FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
706	–	else
707	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
708	–
709	–	xtArray:
710	–	if FAttributeName = 'sqltype' then
711	–	FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
712	–	else
713	–	if FAttributeName = 'relation_name' then
714	–	FArrayData[FCurrentArray].relationName := attrValue
715	–	else
716	–	if FAttributeName = 'column_name' then
717	–	FArrayData[FCurrentArray].columnName := attrValue
718	–	else
719	–	if FAttributeName = 'dim' then
720	–	FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
721	–	else
722	–	if FAttributeName = 'length' then
723	–	FArrayData[FCurrentArray].Size := StrToInt(attrValue)
724	–	else
725	–	if FAttributeName = 'scale' then
726	–	FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
727	–	else
728	–	if FAttributeName = 'charset' then
729	–	FArrayData[FCurrentArray].CharSet := attrValue
730	–	else
731	–	if FAttributeName = 'bounds' then
732	–	ProcessBoundsList(attrValue)
733	–	else
734	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
735	–
736	–	xtElt:
737	–	if FAttributeName = 'ix' then
738	–	with FArrayData[FCurrentArray] do
739	–	Index[CurrentRow] :=  StrToInt(attrValue)
740	–	else
741	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
742	–	end;
743	–	end;
744	–
745	–	procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
746	–	var list: TStringList;
747	–	i,j: integer;
748	–	begin
749	–	list := TStringList.Create;
750	–	try
751	–	list.Delimiter := ',';
752	–	list.DelimitedText := boundsList;
753	–	with FArrayData[FCurrentArray] do
754	–	begin
755	–	if dim <> list.Count then
756	–	ShowError(sInvalidBoundsList,[boundsList]);
757	–	SetLength(bounds,dim);
758	–	for i := 0 to list.Count - 1 do
759	–	begin
760	–	j := Pos(':',list[i]);
761	–	if j = 0 then
762	–	raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
763	–	bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
764	–	bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
765	–	end;
766	–	end;
767	–	finally
768	–	list.Free;
769	–	end;
770	–	end;
771	–
772	–	procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
773	–
774	–	function nibble(hex: char): byte;
775	–	begin
776	–	case hex of
777	–	'0': Result := 0;
778	–	'1': Result := 1;
779	–	'2': Result := 2;
780	–	'3': Result := 3;
781	–	'4': Result := 4;
782	–	'5': Result := 5;
783	–	'6': Result := 6;
784	–	'7': Result := 7;
785	–	'8': Result := 8;
786	–	'9': Result := 9;
787	–	'a','A': Result := 10;
788	–	'b','B': Result := 11;
789	–	'c','C': Result := 12;
790	–	'd','D': Result := 13;
791	–	'e','E': Result := 14;
792	–	'f','F': Result := 15;
793	–	end;
794	–	end;
795	–
796	–	procedure RemoveWhiteSpace(var hexData: string);
797	–	var i: integer;
798	–	begin
799	–	{Remove White Space}
800	–	i := 1;
801	–	while i <= length(hexData) do
802	–	begin
803	–	case hexData[i] of
804	–	' ',#9,#10,#13:
805	–	begin
806	–	if i < Length(hexData) then
807	–	Move(hexData[i+1],hexData[i],Length(hexData)-i);
808	–	SetLength(hexData,Length(hexData)-1);
809	–	end;
810	–	else
811	–	Inc(i);
812	–	end;
813	–	end;
814	–	end;
815	–
816	–	procedure WriteToBlob(hexData: string);
817	–	var i,j : integer;
818	–	blength: integer;
819	–	P: PChar;
820	–	begin
821	–	RemoveWhiteSpace(hexData);
822	–	if odd(length(hexData)) then
823	–	ShowError(sBinaryBlockMustbeEven,[nil]);
824	–	blength := Length(hexData) div 2;
825	–	IBAlloc(FBlobBuffer,0,blength);
826	–	j := 1;
827	–	P := FBlobBuffer;
828	–	for i := 1 to blength do
829	–	begin
830	–	P^ := char((nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]));
831	–	Inc(j,2);
832	–	Inc(P);
833	–	end;
834	–	FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
835	–	end;
836	–
837	–	begin
838	–	if tagValue = '' then Exit;
839	–	case FXMLTagStack[FXMLTagIndex] of
840	–	xtBlob:
841	–	WriteToBlob(tagValue);
842	–
843	–	xtElt:
844	–	with FArrayData[FCurrentArray] do
845	–	ArrayIntf.SetAsString(index,tagValue);
846	–
847	–	end;
848	–	end;
849	–
850	–	procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
851	–	begin
852	–	if FXMLTagIndex > MaxXMLTags then
853	–	ShowError(sXMLStackOverFlow,[nil]);
854	–	Inc(FXMLTagIndex);
855	–	FXMLTagStack[FXMLTagIndex] := xmltag;
856	–	FXMLString := '';
857	–
858	–	case xmltag of
859	–	xtBlob:
860	–	begin
861	–	Inc(FCurrentBlob);
862	–	SetLength(FBlobData,FCurrentBlob+1);
863	–	FBlobData[FCurrentBlob].BlobIntf := nil;
864	–	FBlobData[FCurrentBlob].SubType := 0;
865	–	end;
866	–
867	–	xtArray:
868	–	begin
869	–	Inc(FCurrentArray);
870	–	SetLength(FArrayData,FCurrentArray+1);
871	–	with FArrayData[FCurrentArray] do
872	–	begin
873	–	ArrayIntf := nil;
874	–	SQLType := 0;
875	–	dim := 0;
876	–	Size := 0;
877	–	Scale := 0;
878	–	CharSet := 'NONE';
879	–	SetLength(Index,0);
880	–	CurrentRow := -1;
881	–	end;
882	–	end;
883	–
884	–	xtElt:
885	–	with FArrayData[FCurrentArray] do
886	–	Inc(CurrentRow)
887	–	end;
888	–	end;
889	–
890	–	function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
891	–	begin
892	–	if FXMLTagIndex = 0 then
893	–	ShowError(sXMLStackUnderflow,[nil]);
894	–
895	–	xmlTag := FXMLTagStack[FXMLTagIndex];
896	–	case FXMLTagStack[FXMLTagIndex] of
897	–	xtBlob:
898	–	FBlobData[FCurrentBlob].BlobIntf.Close;
899	–
900	–	xtArray:
901	–	FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
902	–
903	–	xtElt:
904	–	Dec(FArrayData[FCurrentArray].CurrentRow);
905	–	end;
906	–	Dec(FXMLTagIndex);
907	–	Result := FXMLTagIndex = 0;
908	–	end;
909	–
910	–	procedure TSQLXMLReader.XMLTagEnter;
911	–	var aCharSetID: integer;
912	–	begin
913	–	if Database = nil then
914	–	ShowError(sNoDatabase);
915	–	if Transaction = nil then
916	–	ShowError(sNoTransaction);
917	–	case FXMLTagStack[FXMLTagIndex] of
918	–	xtBlob:
919	–	begin
920	–	Database.Connected := true;
921	–	Transaction.Active := true;
922	–	FBlobData[FCurrentBlob].BlobIntf := Database.Attachment.CreateBlob(
923	–	Transaction.TransactionIntf,FBlobData[FCurrentBlob].SubType);
924	–	end;
925	–
926	–	xtArray:
927	–	with FArrayData[FCurrentArray] do
928	–	begin
929	–	Database.Connected := true;
930	–	Transaction.Active := true;
931	–	Database.Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
932	–	SetLength(Index,dim);
933	–	ArrayIntf := Database.Attachment.CreateArray(
934	–	Transaction.TransactionIntf,
935	–	Database.Attachment.CreateArrayMetaData(SQLType,
936	–	relationName,columnName,Scale,Size,
937	–	aCharSetID,dim,bounds)
938	–	);
939	–	end;
940	–	end;
941	–	end;
942	–
943	–	{This is where the XML tags are identified and the token stream modified in
944	–	consequence}
945	–
946	–	function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
947	–
948	–	procedure NotAnXMLTag;
949	–	begin
950	–	begin
951	–	if FXMLTagIndex = 0 then
952	–	{nothing to do with XML so go back to processing SQL}
953	–	begin
954	–	QueueToken(token);
955	–	ReleaseQueue(token);
956	–	FXMLState := stNoXML
957	–	end
958	–	else
959	–	begin
960	–	{Not an XML tag, so just push back to XML Data}
961	–	FXMLState := stXMLData;
962	–	FXMLString += GetQueuedText;
963	–	ResetQueue;
964	–	end;
965	–	end;
966	–	end;
967	–
968	–	var XMLTag: TXMLTag;
969	–	begin
970	–	Result := inherited TokenFound(token);
971	–	if not Result then Exit;
972	–
973	–	case FXMLState of
974	–	stNoXML:
975	–	if token = sqltLT then
976	–	begin
977	–	ResetQueue;
978	–	QueueToken(token); {save in case this is not XML}
979	–	FXMLState := stInTag;
980	–	end;
981	–
982	–	stInTag:
983	–	{Opening '<' found, now looking for tag name or end tag marker}
984	–	case token of
985	–	sqltIdentifier:
986	–	begin
987	–	if FindTag(TokenText,XMLTag) then
988	–	begin
989	–	XMLTagInit(XMLTag);
990	–	QueueToken(token);
991	–	FXMLState := stInTagBody;
992	–	end
993	–	else
994	–	NotAnXMLTag;
995	–	end;
996	–
997	–	sqltForwardSlash:
998	–	FXMLState := stInEndTag;
999	–
1000	–	else
1001	–	NotAnXMLTag;
1002	–	end {case token};
1003	–
1004	–	stInTagBody:
1005	–	{Tag name found. Now looking for attribute or closing '>'}
1006	–	case token of
1007	–	sqltIdentifier:
1008	–	begin
1009	–	FAttributeName := TokenText;
1010	–	QueueToken(token);
1011	–	FXMLState := stAttribute;
1012	–	end;
1013	–
1014	–	sqltGT:
1015	–	begin
1016	–	ResetQueue;
1017	–	XMLTagEnter;
1018	–	FXMLState := stXMLData;
1019	–	end;
1020	–
1021	–	sqltSpace,
1022	–	sqltEOL:
1023	–	QueueToken(token);
1024	–
1025	–	else
1026	–	NotAnXMLTag;
1027	–	end {case token};
1028	–
1029	–	stAttribute:
1030	–	{Attribute name found. Must be followed by an '=', a '>' or another tag name}
1031	–	case token of
1032	–	sqltEquals:
1033	–	begin
1034	–	QueueToken(token);
1035	–	FXMLState := stAttributeValue;
1036	–	end;
1037	–
1038	–	sqltSpace,
1039	–	sqltEOL:
1040	–	QueueToken(token);
1041	–
1042	–	sqltIdentifier:
1043	–	begin
1044	–	ProcessAttributeValue('');
1045	–	FAttributeName := TokenText;
1046	–	QueueToken(token);
1047	–	FXMLState := stAttribute;
1048	–	end;
1049	–
1050	–	sqltGT:
1051	–	begin
1052	–	ProcessAttributeValue('');
1053	–	ResetQueue;
1054	–	XMLTagEnter;
1055	–	FXMLState := stXMLData;
1056	–	end;
1057	–
1058	–	else
1059	–	NotAnXMLTag;
1060	–	end; {case token}
1061	–
1062	–	stAttributeValue:
1063	–	{Looking for attribute value as a single identifier or a double quoted value}
1064	–	case token of
1065	–	sqltIdentifier,sqltIdentifierInDoubleQuotes:
1066	–	begin
1067	–	ProcessAttributeValue(TokenText);
1068	–	QueueToken(token);
1069	–	FXMLState := stInTagBody;
1070	–	end;
1071	–
1072	–	sqltSpace,
1073	–	sqltEOL:
1074	–	QueueToken(token);
1075	–
1076	–	else
1077	–	NotAnXMLTag;
1078	–	end; {case token}
1079	–
1080	–	stXMLData:
1081	–	if token = sqltLT then
1082	–	begin
1083	–	QueueToken(token); {save in case this is not XML}
1084	–	FXMLState := stInTag;
1085	–	end
1086	–	else
1087	–	FXMLString += TokenText;
1088	–
1089	–	stInEndTag:
1090	–	{Opening '</' found, now looking for tag name}
1091	–	case token of
1092	–	sqltIdentifier:
1093	–	begin
1094	–	if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
1095	–	begin
1096	–	QueueToken(token);
1097	–	FXMLState := stInEndTagBody;
1098	–	end
1099	–	else
1100	–	ShowError(sInvalidEndTag,[TokenText]);
1101	–	end;
1102	–	else
1103	–	NotAnXMLTag;
1104	–	end {case token};
1105	–
1106	–	stInEndTagBody:
1107	–	{End tag name found, now looping for closing '>'}
1108	–	case Token of
1109	–	sqltGT:
1110	–	begin
1111	–	ProcessTagValue(FXMLString);
1112	–	if XMLTagEnd(XMLTag) then
1113	–	begin
1114	–	ResetQueue;
1115	–	QueueToken(sqltColon,':');
1116	–	case XMLTag of
1117	–	xtBlob:
1118	–	QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
1119	–
1120	–	xtArray:
1121	–	QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
1122	–	end;
1123	–	ReleaseQueue(token);
1124	–	FXMLState := stNoXML;
1125	–	end
1126	–	else
1127	–	FXMLState := stXMLData;
1128	–	end;
1129	–
1130	–	sqltSpace,
1131	–	sqltEOL:
1132	–	QueueToken(token);
1133	–
1134	–	else
1135	–	ShowError(sBadEndTagClosing);
1136	–	end; {case token}
1137	–
1138	–	end {Case FState};
1139	–
1140	–	{Only allow token to be returned if not processing an XML tag}
1141	–
1142	–	Result := FXMLState = stNoXML;
1143	–	end;
1144	–
1145	–	procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
1146	–	begin
1147	–	raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
1148	–	end;
1149	–
1150	–	procedure TSQLXMLReader.ShowError(msg: string);
1151	–	begin
1152	–	ShowError(msg,[nil]);
1153	–	end;
1154	–
1155	–	constructor TSQLXMLReader.Create;
1156	–	begin
1157	–	inherited;
1158	–	FXMLState := stNoXML;
1159	–	end;
1160	–
1161	–	procedure TSQLXMLReader.FreeDataObjects;
1162	–	begin
1163	–	FXMLTagIndex := 0;
1164	–	SetLength(FBlobData,0);
1165	–	FCurrentBlob := -1;
1166	–	SetLength(FArrayData,0);
1167	–	FCurrentArray := -1;
1168	–	end;
1169	–
1170	–	class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
1171	–	var TextOut: TStrings;
1172	–	begin
1173	–	TextOut := TStringList.Create;
1174	–	try
1175	–	TextOut.Add(Format('<blob subtype="%d">',[Field.getSubtype]));
1176	–	StringToHex(Field.AsString,TextOut,BlobLineLength);
1177	–	TextOut.Add('</blob>');
1178	–	Result := TextOut.Text;
1179	–	finally
1180	–	TextOut.Free;
1181	–	end;
1182	–	end;
1183	–
1184	–	class function TSQLXMLReader.FormatArray(Database: TIBDatabase; ar: IArray
1185	–	): string;
1186	–	var index: array of integer;
1187	–	TextOut: TStrings;
1188	–
1189	–	procedure AddElements(dim: integer; indent:string = ' ');
1190	–	var i: integer;
1191	–	recurse: boolean;
1192	–	begin
1193	–	SetLength(index,dim+1);
1194	–	recurse := dim < ar.GetDimensions - 1;
1195	–	with ar.GetBounds[dim] do
1196	–	for i := LowerBound to UpperBound do
1197	–	begin
1198	–	index[dim] := i;
1199	–	if recurse then
1200	–	begin
1201	–	TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
1202	–	AddElements(dim+1,indent + ' ');
1203	–	TextOut.Add('</elt>');
1204	–	end
1205	–	else
1206	–	if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
1207	–	(ar.GetCharSetID = 1) then
1208	–	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
1209	–	else
1210	–	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
1211	–	end;
1212	–	end;
1213	–
1214	–	var
1215	–	s: string;
1216	–	bounds: TArrayBounds;
1217	–	i: integer;
1218	–	boundsList: string;
1219	–	begin
1220	–	TextOut := TStringList.Create;
1221	–	try
1222	–	if ar.GetCharSetWidth = 0 then
1223	–	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1224	–	[ar.GetDimensions,ar.GetSQLType,ar.GetSize,
1225	–	ar.GetTableName,ar.GetColumnName])
1226	–	else
1227	–	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1228	–	[ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
1229	–	ar.GetTableName,ar.GetColumnName]);
1230	–	case ar.GetSQLType of
1231	–	SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
1232	–	s += Format(' scale = "%d"',[ ar.GetScale]);
1233	–	SQL_TEXT,
1234	–	SQL_VARYING:
1235	–	s += Format(' charset = "%s"',[Database.Attachment.GetCharsetName(ar.GetCharSetID)]);
1236	–	end;
1237	–	bounds := ar.GetBounds;
1238	–	boundsList := '';
1239	–	for i := 0 to length(bounds) - 1 do
1240	–	begin
1241	–	if i <> 0 then boundsList += ',';
1242	–	boundsList += Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
1243	–	end;
1244	–	s += Format(' bounds="%s"',[boundsList]);
1245	–	s += '>';
1246	–	TextOut.Add(s);
1247	–
1248	–	SetLength(index,0);
1249	–	AddElements(0);
1250	–	TextOut.Add('</array>');
1251	–	Result := TextOut.Text;
1252	–	finally
1253	–	TextOut.Free;
1254	–	end;       end;
1255	–
1256	–	procedure TSQLXMLReader.Reset;
1257	–	begin
1258	–	inherited Reset;
1259	–	FreeDataObjects;
1260	–	FXMLString := '';
1261	–	FreeMem(FBlobBuffer);
1262	–	end;
1263	–
517
518
519		{ TIBXScript }
#	Line 1413 | Line 666 | begin
666		if not (csLoading in ComponentState) and (FDatabase = AValue) then Exit;
667		FDatabase := AValue;
668		FISQL.Database := AValue;
1416	–	FSQLReader.Database := AValue;
669		FInternalTransaction.Active := false;
670		FInternalTransaction.DefaultDatabase := AValue;
671		end;
#	Line 1476 | Line 728 | function TCustomIBXScript.ProcessStream:
728		var stmt: string;
729		begin
730		Result := false;
731	+	FSQLReader.Database := Database;
732	+	if FTransaction = nil then
733	+	FSQLReader.Transaction := FInternalTransaction
734	+	else
735	+	FSQLReader.Transaction := FTransaction;
736		while FSQLReader.GetNextStatement(stmt) do
737		try
738		stmt := trim(stmt);
#	Line 1507 | Line 764 | procedure TCustomIBXScript.SetSQLStateme
764		begin
765		FSQLReader := SQLStatementReader;
766		FSQLReader.OnNextLine := @EchoNextLine;
1510	–	FSQLReader.Transaction := FInternalTransaction;
767		end;
768
769		function TCustomIBXScript.ProcessStatement(stmt: string): boolean;
#	Line 1781 | Line 1037 | procedure TCustomIBXScript.SetTransactio
1037		begin
1038		if FTransaction = AValue then Exit;
1039		FTransaction := AValue;
1784	–	if FTransaction = nil then
1785	–	FSQLReader.Transaction := FInternalTransaction
1786	–	else
1787	–	FSQLReader.Transaction := FTransaction;
1040		end;
1041
1042		constructor TCustomIBXScript.Create(aOwner: TComponent);
#	Line 1819 | Line 1071 | end;
1071
1072		{ TInteractiveSQLStatementReader }
1073
1074	<	function TInteractiveSQLStatementReader.GetErrorPrefix: string;
1074	>	function TInteractiveSQLStatementReader.GetErrorPrefix: AnsiString;
1075		begin
1076		Result := '';
1077		end;
#	Line 1838 | Line 1090 | begin
1090		end;
1091		end;
1092
1093	<	function TInteractiveSQLStatementReader.GetChar: char;
1093	>	function TInteractiveSQLStatementReader.GetChar: AnsiChar;
1094		begin
1095		if Terminated then
1096		Result := #0
#	Line 1887 | Line 1139 | end;
1139
1140		{ TBatchSQLStatementReader }
1141
1142	<	function TBatchSQLStatementReader.GetChar: char;
1142	>	function TBatchSQLStatementReader.GetChar: AnsiChar;
1143		begin
1144		if not EOF and assigned(FInStream) and not (FInStream.Position = FInStream.Size) then
1145		begin
#	Line 1912 | Line 1164 | begin
1164		Result := #0;
1165		end;
1166
1167	<	function TBatchSQLStatementReader.GetErrorPrefix: string;
1167	>	function TBatchSQLStatementReader.GetErrorPrefix: AnsiString;
1168		begin
1169		Result := Format(sOnLineError,[FLineIndex,FIndex]);
1170		end;

Diff Legend

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