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 315 by tony, Thu Feb 25 11:56:36 2021 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 516 | Line 383 | begin
383		sqltIdentifierInDoubleQuotes:
384		stmt += '"' + TokenText + '"';
385
519	–	sqltCR: {ignore};
520	–
386		sqltEOL:
387		stmt += LineEnding;
388
#	Line 556 | Line 421 | begin
421		end;
422		end;
423
424	+	sqltCase:
425	+	{case constructs can appear within select statement in nested blocks.
426	+	We need to match the case constructs END token in order to parse the
427	+	block correctly. This is a simple parser and the only objective is
428	+	to determine the correct end of block. We therefore do not check to
429	+	ensure that the next end properly matches the case. The CASE is thus
430	+	treated the same as BEGIN. The Firebird SQL Parser will flag any errors
431	+	due to mismatched CASE/BEGIN END}
432	+	begin
433	+	Inc(Nested);
434	+	stmt += TokenText;
435	+	end;
436	+
437		sqltComment:
438		stmt += '/*' + TokenText + '*/';
439
#	Line 568 | Line 446 | begin
446		sqltIdentifierInDoubleQuotes:
447		stmt += '"' + TokenText + '"';
448
571	–	sqltCR: {ignore};
572	–
449		sqltEOL:
450		stmt += LineEnding;
451
#	Line 596 | Line 472 | begin
472		State := stInStmt;
473		end;
474
599	–	sqltCR: {ignore};
600	–
475		sqltEOL:
476		stmt += LineEnding;
477
#	Line 618 | Line 492 | begin
492		sqltCommentLine:
493		stmt += '/* ' + TokenText + ' */' + LineEnding;
494
495	+	sqltQuotedString:
496	+	stmt += '''' + SQLSafeString(TokenText) + '''';  {exists some DECLARE with cursor having SELECT ...\... rc.rdb$constraint_type = 'PRIMARY KEY');}
497	+
498		sqltSemiColon:
499		begin
500		State := stInStmt;
501		stmt += TokenText;
502		end;
503
627	–	sqltCR: {ignore};
628	–
504		sqltEOL:
505		stmt += LineEnding;
506
#	Line 634 | Line 509 | begin
509		end;
510		end;
511		end;
512	+	//    writeln(stmt);
513		end;
514		Result := stmt <> '';
515		end;
516
641	–	{ TSQLXMLReader }
642	–
643	–	function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
644	–	var i: TXMLTag;
645	–	begin
646	–	Result := false;
647	–	for i := xtBlob to xtElt do
648	–	if XMLTagDefs[i].TagValue = tag then
649	–	begin
650	–	xmlTag := XMLTagDefs[i].XMLTag;
651	–	Result := true;
652	–	break;
653	–	end;
654	–	end;
655	–
656	–	function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
657	–	begin
658	–	if (index < 0) or (index > ArrayDataCount) then
659	–	ShowError(sArrayIndexError,[index]);
660	–	Result := FArrayData[index];
661	–	end;
662	–
663	–	function TSQLXMLReader.GetArrayDataCount: integer;
664	–	begin
665	–	Result := Length(FArrayData);
666	–	end;
667	–
668	–	function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
669	–	begin
670	–	if (index < 0) or (index > BlobDataCount) then
671	–	ShowError(sBlobIndexError,[index]);
672	–	Result := FBlobData[index];
673	–	end;
674	–
675	–	function TSQLXMLReader.GetBlobDataCount: integer;
676	–	begin
677	–	Result := Length(FBlobData);
678	–	end;
679	–
680	–	function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
681	–	var i: TXMLTag;
682	–	begin
683	–	Result := 'unknown';
684	–	for i := xtBlob to xtElt do
685	–	if XMLTagDefs[i].XMLTag = xmltag then
686	–	begin
687	–	Result := XMLTagDefs[i].TagValue;
688	–	Exit;
689	–	end;
690	–	end;
691	–
692	–	procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
693	–	begin
694	–	case FXMLTagStack[FXMLTagIndex] of
695	–	xtBlob:
696	–	if FAttributeName = 'subtype' then
697	–	FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
698	–	else
699	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
700	–
701	–	xtArray:
702	–	if FAttributeName = 'sqltype' then
703	–	FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
704	–	else
705	–	if FAttributeName = 'relation_name' then
706	–	FArrayData[FCurrentArray].relationName := attrValue
707	–	else
708	–	if FAttributeName = 'column_name' then
709	–	FArrayData[FCurrentArray].columnName := attrValue
710	–	else
711	–	if FAttributeName = 'dim' then
712	–	FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
713	–	else
714	–	if FAttributeName = 'length' then
715	–	FArrayData[FCurrentArray].Size := StrToInt(attrValue)
716	–	else
717	–	if FAttributeName = 'scale' then
718	–	FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
719	–	else
720	–	if FAttributeName = 'charset' then
721	–	FArrayData[FCurrentArray].CharSet := attrValue
722	–	else
723	–	if FAttributeName = 'bounds' then
724	–	ProcessBoundsList(attrValue)
725	–	else
726	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
727	–
728	–	xtElt:
729	–	if FAttributeName = 'ix' then
730	–	with FArrayData[FCurrentArray] do
731	–	Index[CurrentRow] :=  StrToInt(attrValue)
732	–	else
733	–	ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
734	–	end;
735	–	end;
736	–
737	–	procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
738	–	var list: TStringList;
739	–	i,j: integer;
740	–	begin
741	–	list := TStringList.Create;
742	–	try
743	–	list.Delimiter := ',';
744	–	list.DelimitedText := boundsList;
745	–	with FArrayData[FCurrentArray] do
746	–	begin
747	–	if dim <> list.Count then
748	–	ShowError(sInvalidBoundsList,[boundsList]);
749	–	SetLength(bounds,dim);
750	–	for i := 0 to list.Count - 1 do
751	–	begin
752	–	j := Pos(':',list[i]);
753	–	if j = 0 then
754	–	raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
755	–	bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
756	–	bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
757	–	end;
758	–	end;
759	–	finally
760	–	list.Free;
761	–	end;
762	–	end;
763	–
764	–	procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
765	–
766	–	function nibble(hex: char): byte;
767	–	begin
768	–	case hex of
769	–	'0': Result := 0;
770	–	'1': Result := 1;
771	–	'2': Result := 2;
772	–	'3': Result := 3;
773	–	'4': Result := 4;
774	–	'5': Result := 5;
775	–	'6': Result := 6;
776	–	'7': Result := 7;
777	–	'8': Result := 8;
778	–	'9': Result := 9;
779	–	'a','A': Result := 10;
780	–	'b','B': Result := 11;
781	–	'c','C': Result := 12;
782	–	'd','D': Result := 13;
783	–	'e','E': Result := 14;
784	–	'f','F': Result := 15;
785	–	end;
786	–	end;
787	–
788	–	procedure RemoveWhiteSpace(var hexData: string);
789	–	var i: integer;
790	–	begin
791	–	{Remove White Space}
792	–	i := 1;
793	–	while i <= length(hexData) do
794	–	begin
795	–	case hexData[i] of
796	–	' ',#9,#10,#13:
797	–	begin
798	–	if i < Length(hexData) then
799	–	Move(hexData[i+1],hexData[i],Length(hexData)-i);
800	–	SetLength(hexData,Length(hexData)-1);
801	–	end;
802	–	else
803	–	Inc(i);
804	–	end;
805	–	end;
806	–	end;
807	–
808	–	procedure WriteToBlob(hexData: string);
809	–	var i,j : integer;
810	–	blength: integer;
811	–	P: PChar;
812	–	begin
813	–	RemoveWhiteSpace(hexData);
814	–	if odd(length(hexData)) then
815	–	ShowError(sBinaryBlockMustbeEven,[nil]);
816	–	blength := Length(hexData) div 2;
817	–	IBAlloc(FBlobBuffer,0,blength);
818	–	j := 1;
819	–	P := FBlobBuffer;
820	–	for i := 1 to blength do
821	–	begin
822	–	P^ := char((nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]));
823	–	Inc(j,2);
824	–	Inc(P);
825	–	end;
826	–	FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
827	–	end;
828	–
829	–	begin
830	–	if tagValue = '' then Exit;
831	–	case FXMLTagStack[FXMLTagIndex] of
832	–	xtBlob:
833	–	WriteToBlob(tagValue);
834	–
835	–	xtElt:
836	–	with FArrayData[FCurrentArray] do
837	–	ArrayIntf.SetAsString(index,tagValue);
838	–
839	–	end;
840	–	end;
841	–
842	–	procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
843	–	begin
844	–	if FXMLTagIndex > MaxXMLTags then
845	–	ShowError(sXMLStackOverFlow,[nil]);
846	–	Inc(FXMLTagIndex);
847	–	FXMLTagStack[FXMLTagIndex] := xmltag;
848	–	FXMLString := '';
849	–
850	–	case xmltag of
851	–	xtBlob:
852	–	begin
853	–	Inc(FCurrentBlob);
854	–	SetLength(FBlobData,FCurrentBlob+1);
855	–	FBlobData[FCurrentBlob].BlobIntf := nil;
856	–	FBlobData[FCurrentBlob].SubType := 0;
857	–	end;
858	–
859	–	xtArray:
860	–	begin
861	–	Inc(FCurrentArray);
862	–	SetLength(FArrayData,FCurrentArray+1);
863	–	with FArrayData[FCurrentArray] do
864	–	begin
865	–	ArrayIntf := nil;
866	–	SQLType := 0;
867	–	dim := 0;
868	–	Size := 0;
869	–	Scale := 0;
870	–	CharSet := 'NONE';
871	–	SetLength(Index,0);
872	–	CurrentRow := -1;
873	–	end;
874	–	end;
875	–
876	–	xtElt:
877	–	with FArrayData[FCurrentArray] do
878	–	Inc(CurrentRow)
879	–	end;
880	–	end;
881	–
882	–	function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
883	–	begin
884	–	if FXMLTagIndex = 0 then
885	–	ShowError(sXMLStackUnderflow,[nil]);
886	–
887	–	xmlTag := FXMLTagStack[FXMLTagIndex];
888	–	case FXMLTagStack[FXMLTagIndex] of
889	–	xtBlob:
890	–	FBlobData[FCurrentBlob].BlobIntf.Close;
891	–
892	–	xtArray:
893	–	FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
894	–
895	–	xtElt:
896	–	Dec(FArrayData[FCurrentArray].CurrentRow);
897	–	end;
898	–	Dec(FXMLTagIndex);
899	–	Result := FXMLTagIndex = 0;
900	–	end;
901	–
902	–	procedure TSQLXMLReader.XMLTagEnter;
903	–	var aCharSetID: integer;
904	–	begin
905	–	if Database = nil then
906	–	ShowError(sNoDatabase);
907	–	if Transaction = nil then
908	–	ShowError(sNoTransaction);
909	–	case FXMLTagStack[FXMLTagIndex] of
910	–	xtBlob:
911	–	begin
912	–	Database.Connected := true;
913	–	Transaction.Active := true;
914	–	FBlobData[FCurrentBlob].BlobIntf := Database.Attachment.CreateBlob(
915	–	Transaction.TransactionIntf,FBlobData[FCurrentBlob].SubType);
916	–	end;
917	–
918	–	xtArray:
919	–	with FArrayData[FCurrentArray] do
920	–	begin
921	–	Database.Connected := true;
922	–	Transaction.Active := true;
923	–	Database.Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
924	–	SetLength(Index,dim);
925	–	ArrayIntf := Database.Attachment.CreateArray(
926	–	Transaction.TransactionIntf,
927	–	Database.Attachment.CreateArrayMetaData(SQLType,
928	–	relationName,columnName,Scale,Size,
929	–	aCharSetID,dim,bounds)
930	–	);
931	–	end;
932	–	end;
933	–	end;
934	–
935	–	{This is where the XML tags are identified and the token stream modified in
936	–	consequence}
937	–
938	–	function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
939	–
940	–	procedure NotAnXMLTag;
941	–	begin
942	–	begin
943	–	if FXMLTagIndex = 0 then
944	–	{nothing to do with XML so go back to processing SQL}
945	–	begin
946	–	QueueToken(token);
947	–	ReleaseQueue(token);
948	–	FXMLState := stNoXML
949	–	end
950	–	else
951	–	begin
952	–	{Not an XML tag, so just push back to XML Data}
953	–	FXMLState := stXMLData;
954	–	FXMLString += GetQueuedText;
955	–	ResetQueue;
956	–	end;
957	–	end;
958	–	end;
959	–
960	–	var XMLTag: TXMLTag;
961	–	begin
962	–	Result := inherited TokenFound(token);
963	–	if not Result then Exit;
964	–
965	–	case FXMLState of
966	–	stNoXML:
967	–	if token = sqltLT then
968	–	begin
969	–	ResetQueue;
970	–	QueueToken(token); {save in case this is not XML}
971	–	FXMLState := stInTag;
972	–	end;
973	–
974	–	stInTag:
975	–	{Opening '<' found, now looking for tag name or end tag marker}
976	–	case token of
977	–	sqltIdentifier:
978	–	begin
979	–	if FindTag(TokenText,XMLTag) then
980	–	begin
981	–	XMLTagInit(XMLTag);
982	–	QueueToken(token);
983	–	FXMLState := stInTagBody;
984	–	end
985	–	else
986	–	NotAnXMLTag;
987	–	end;
988	–
989	–	sqltForwardSlash:
990	–	FXMLState := stInEndTag;
991	–
992	–	else
993	–	NotAnXMLTag;
994	–	end {case token};
995	–
996	–	stInTagBody:
997	–	{Tag name found. Now looking for attribute or closing '>'}
998	–	case token of
999	–	sqltIdentifier:
1000	–	begin
1001	–	FAttributeName := TokenText;
1002	–	QueueToken(token);
1003	–	FXMLState := stAttribute;
1004	–	end;
1005	–
1006	–	sqltGT:
1007	–	begin
1008	–	ResetQueue;
1009	–	XMLTagEnter;
1010	–	FXMLState := stXMLData;
1011	–	end;
1012	–
1013	–	sqltSpace,
1014	–	sqltCR, sqltEOL:
1015	–	QueueToken(token);
1016	–
1017	–	else
1018	–	NotAnXMLTag;
1019	–	end {case token};
1020	–
1021	–	stAttribute:
1022	–	{Attribute name found. Must be followed by an '=', a '>' or another tag name}
1023	–	case token of
1024	–	sqltEquals:
1025	–	begin
1026	–	QueueToken(token);
1027	–	FXMLState := stAttributeValue;
1028	–	end;
1029	–
1030	–	sqltSpace,
1031	–	sqltCR, sqltEOL:
1032	–	QueueToken(token);
1033	–
1034	–	sqltIdentifier:
1035	–	begin
1036	–	ProcessAttributeValue('');
1037	–	FAttributeName := TokenText;
1038	–	QueueToken(token);
1039	–	FXMLState := stAttribute;
1040	–	end;
1041	–
1042	–	sqltGT:
1043	–	begin
1044	–	ProcessAttributeValue('');
1045	–	ResetQueue;
1046	–	XMLTagEnter;
1047	–	FXMLState := stXMLData;
1048	–	end;
1049	–
1050	–	else
1051	–	NotAnXMLTag;
1052	–	end; {case token}
1053	–
1054	–	stAttributeValue:
1055	–	{Looking for attribute value as a single identifier or a double quoted value}
1056	–	case token of
1057	–	sqltIdentifier,sqltIdentifierInDoubleQuotes:
1058	–	begin
1059	–	ProcessAttributeValue(TokenText);
1060	–	QueueToken(token);
1061	–	FXMLState := stInTagBody;
1062	–	end;
1063	–
1064	–	sqltSpace,
1065	–	sqltCR, sqltEOL:
1066	–	QueueToken(token);
1067	–
1068	–	else
1069	–	NotAnXMLTag;
1070	–	end; {case token}
1071	–
1072	–	stXMLData:
1073	–	if token = sqltLT then
1074	–	begin
1075	–	QueueToken(token); {save in case this is not XML}
1076	–	FXMLState := stInTag;
1077	–	end
1078	–	else
1079	–	FXMLString += TokenText;
1080	–
1081	–	stInEndTag:
1082	–	{Opening '</' found, now looking for tag name}
1083	–	case token of
1084	–	sqltIdentifier:
1085	–	begin
1086	–	if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
1087	–	begin
1088	–	QueueToken(token);
1089	–	FXMLState := stInEndTagBody;
1090	–	end
1091	–	else
1092	–	ShowError(sInvalidEndTag,[TokenText]);
1093	–	end;
1094	–	else
1095	–	NotAnXMLTag;
1096	–	end {case token};
1097	–
1098	–	stInEndTagBody:
1099	–	{End tag name found, now looping for closing '>'}
1100	–	case Token of
1101	–	sqltGT:
1102	–	begin
1103	–	ProcessTagValue(FXMLString);
1104	–	if XMLTagEnd(XMLTag) then
1105	–	begin
1106	–	ResetQueue;
1107	–	QueueToken(sqltColon,':');
1108	–	case XMLTag of
1109	–	xtBlob:
1110	–	QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
1111	–
1112	–	xtArray:
1113	–	QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
1114	–	end;
1115	–	ReleaseQueue(token);
1116	–	FXMLState := stNoXML;
1117	–	end
1118	–	else
1119	–	FXMLState := stXMLData;
1120	–	end;
1121	–
1122	–	sqltSpace,
1123	–	sqltCR, sqltEOL:
1124	–	QueueToken(token);
1125	–
1126	–	else
1127	–	ShowError(sBadEndTagClosing);
1128	–	end; {case token}
1129	–
1130	–	end {Case FState};
1131	–
1132	–	{Only allow token to be returned if not processing an XML tag}
1133	–
1134	–	Result := FXMLState = stNoXML;
1135	–	end;
1136	–
1137	–	procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
1138	–	begin
1139	–	raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
1140	–	end;
1141	–
1142	–	procedure TSQLXMLReader.ShowError(msg: string);
1143	–	begin
1144	–	ShowError(msg,[nil]);
1145	–	end;
1146	–
1147	–	constructor TSQLXMLReader.Create;
1148	–	begin
1149	–	inherited;
1150	–	FXMLState := stNoXML;
1151	–	end;
1152	–
1153	–	procedure TSQLXMLReader.FreeDataObjects;
1154	–	begin
1155	–	FXMLTagIndex := 0;
1156	–	SetLength(FBlobData,0);
1157	–	FCurrentBlob := -1;
1158	–	SetLength(FArrayData,0);
1159	–	FCurrentArray := -1;
1160	–	end;
1161	–
1162	–	class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
1163	–	var TextOut: TStrings;
1164	–	begin
1165	–	TextOut := TStringList.Create;
1166	–	try
1167	–	TextOut.Add(Format('<blob subtype="%d">',[Field.getSubtype]));
1168	–	StringToHex(Field.AsString,TextOut,BlobLineLength);
1169	–	TextOut.Add('</blob>');
1170	–	Result := TextOut.Text;
1171	–	finally
1172	–	TextOut.Free;
1173	–	end;
1174	–	end;
1175	–
1176	–	class function TSQLXMLReader.FormatArray(Database: TIBDatabase; ar: IArray
1177	–	): string;
1178	–	var index: array of integer;
1179	–	TextOut: TStrings;
1180	–
1181	–	procedure AddElements(dim: integer; indent:string = ' ');
1182	–	var i: integer;
1183	–	recurse: boolean;
1184	–	begin
1185	–	SetLength(index,dim+1);
1186	–	recurse := dim < ar.GetDimensions - 1;
1187	–	with ar.GetBounds[dim] do
1188	–	for i := LowerBound to UpperBound do
1189	–	begin
1190	–	index[dim] := i;
1191	–	if recurse then
1192	–	begin
1193	–	TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
1194	–	AddElements(dim+1,indent + ' ');
1195	–	TextOut.Add('</elt>');
1196	–	end
1197	–	else
1198	–	if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
1199	–	(ar.GetCharSetID = 1) then
1200	–	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
1201	–	else
1202	–	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
1203	–	end;
1204	–	end;
1205	–
1206	–	var
1207	–	s: string;
1208	–	bounds: TArrayBounds;
1209	–	i: integer;
1210	–	boundsList: string;
1211	–	begin
1212	–	TextOut := TStringList.Create;
1213	–	try
1214	–	if ar.GetCharSetWidth = 0 then
1215	–	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1216	–	[ar.GetDimensions,ar.GetSQLType,ar.GetSize,
1217	–	ar.GetTableName,ar.GetColumnName])
1218	–	else
1219	–	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1220	–	[ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
1221	–	ar.GetTableName,ar.GetColumnName]);
1222	–	case ar.GetSQLType of
1223	–	SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
1224	–	s += Format(' scale = "%d"',[ ar.GetScale]);
1225	–	SQL_TEXT,
1226	–	SQL_VARYING:
1227	–	s += Format(' charset = "%s"',[Database.Attachment.GetCharsetName(ar.GetCharSetID)]);
1228	–	end;
1229	–	bounds := ar.GetBounds;
1230	–	boundsList := '';
1231	–	for i := 0 to length(bounds) - 1 do
1232	–	begin
1233	–	if i <> 0 then boundsList += ',';
1234	–	boundsList += Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
1235	–	end;
1236	–	s += Format(' bounds="%s"',[boundsList]);
1237	–	s += '>';
1238	–	TextOut.Add(s);
1239	–
1240	–	SetLength(index,0);
1241	–	AddElements(0);
1242	–	TextOut.Add('</array>');
1243	–	Result := TextOut.Text;
1244	–	finally
1245	–	TextOut.Free;
1246	–	end;       end;
1247	–
1248	–	procedure TSQLXMLReader.Reset;
1249	–	begin
1250	–	inherited Reset;
1251	–	FreeDataObjects;
1252	–	FXMLString := '';
1253	–	FreeMem(FBlobBuffer);
1254	–	end;
1255	–
517
518
519		{ TIBXScript }
#	Line 1405 | Line 666 | begin
666		if not (csLoading in ComponentState) and (FDatabase = AValue) then Exit;
667		FDatabase := AValue;
668		FISQL.Database := AValue;
1408	–	FSQLReader.Database := AValue;
669		FInternalTransaction.Active := false;
670		FInternalTransaction.DefaultDatabase := AValue;
671		end;
#	Line 1468 | 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);
739	<	//    writeln('stmt = ',stmt);
739	>	//    writeln('stmt = "',stmt,'"');
740		if stmt = '' then continue;
741		if not ProcessStatement(stmt) then
742		ExecSQL(stmt);
#	Line 1499 | Line 764 | procedure TCustomIBXScript.SetSQLStateme
764		begin
765		FSQLReader := SQLStatementReader;
766		FSQLReader.OnNextLine := @EchoNextLine;
1502	–	FSQLReader.Transaction := FInternalTransaction;
767		end;
768
769		function TCustomIBXScript.ProcessStatement(stmt: string): boolean;
#	Line 1773 | Line 1037 | procedure TCustomIBXScript.SetTransactio
1037		begin
1038		if FTransaction = AValue then Exit;
1039		FTransaction := AValue;
1776	–	if FTransaction = nil then
1777	–	FSQLReader.Transaction := FInternalTransaction
1778	–	else
1779	–	FSQLReader.Transaction := FTransaction;
1040		end;
1041
1042		constructor TCustomIBXScript.Create(aOwner: TComponent);
#	Line 1811 | Line 1071 | end;
1071
1072		{ TInteractiveSQLStatementReader }
1073
1074	<	function TInteractiveSQLStatementReader.GetErrorPrefix: string;
1074	>	function TInteractiveSQLStatementReader.GetErrorPrefix: AnsiString;
1075		begin
1076		Result := '';
1077		end;
#	Line 1830 | 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 1879 | 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 1894 | Line 1154 | begin
1154		FIndex := 1;
1155		end
1156		else
1157	+	if Result <> CR then
1158		begin
1159		FCurLine += Result;
1160		Inc(FIndex);
#	Line 1903 | 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;

Comparing ibx/trunk/runtime/nongui/ibxscript.pas (property svn:eol-style):
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC vs.
Revision 402 by tony, Mon Aug 1 10:07:24 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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