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 228 by tony, Mon Apr 9 13:38:16 2018 UTC vs.
Revision 402 by tony, Mon Aug 1 10:07:24 2022 UTC

#	Line 31 | Line 31 | unit ibxscript;
31
32		interface
33
34	<	uses Classes, IBDatabase,  IBSQL, IB, IBDataOutput;
35	<
36	<	const
37	<	ibx_blob = 'IBX_BLOB';
38	<	ibx_array = 'IBX_ARRAY';
39	<
40	<	BlobLineLength = 40;
41	<
42	<	DefaultTerminator = ';';
43	<
44	<	{Non-character symbols}
45	<	sqNone                 = #0;
46	<	sqEnd                  = #1;
47	<	sqBegin                = #2;
48	<	sqString               = #3;
49	<	sqComment              = #4;
50	<	sqCase                 = #5;
51	<	sqDeclare              = #6;
52	<	sqCommentLine          = #7;
53	<	sqEOL                  = #8;
54	<	sqTab                  = #9;
55	<	sqTerminator           = #10;
56	<	sqEOF                  = #11;
57	<	sqTag                  = #12;
58	<	sqEndTag               = #13;
59	<	sqQuotedString         = #14;
60	<	sqDoubleQuotedString   = #15;
34	>	uses Classes, IBDatabase,  IBSQL, IB, IBDataOutput, IBUtils;
35
36		type
63	–	TSQLSymbol = char;
64	–
65	–	TSQLStates =  (stInit, stError, stInSQL, stNested,  stInDeclaration);
66	–
67	–	TXMLStates =  (stInTag,stAttribute,stAttributeValue,stQuotedAttributeValue,
68	–	stTagged,stEndTag);
69	–
70	–	TXMLTag    =   (xtNone,xtBlob,xtArray,xtElt);
37
38		TOnNextLine = procedure(Sender: TObject; Line: string) of object;
73	–	TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
74	–
75	–	TXMLTagDef = record
76	–	XMLTag: TXMLTag;
77	–	TagValue: string;
78	–	end;
79	–
80	–	const
81	–	XMLTagDefs: array [0..2] of TXMLTagDef = (
82	–	(XMLTag: xtBlob;   TagValue: 'blob'),
83	–	(XMLTag: xtArray;  TagValue: 'array'),
84	–	(XMLTag: xtElt;    TagValue: 'elt')
85	–	);
86	–
87	–	type
39
40	<	{ TSymbolStream }
40	>	{ TSQLStatementReader }
41
42	<	{A simple lookahead one parser to process a text stream as a stream of symbols.
43	<	This is an abstract object, subclassed for different sources.}
44	<
45	<	TSymbolStream = class
42	>	TSQLStatementReader = class(TSQLXMLReader)
43	>	private
44	>	type
45	>	TSQLState = (stDefault, stInStmt, stInBlock, stInArrayDim, stInDeclare);
46		private
47	<	FNextSymbol: TSQLSymbol;
47	>	FDatabase: TIBDatabase;
48	>	FHasBegin: boolean;
49		FOnNextLine: TOnNextLine;
98	–	FOnProgressEvent: TOnProgressEvent;
50		FTerminator: char;
51	<	FLastChar: char;
101	<	FIndex: integer;
102	<	FLine: string;
103	<	FString: string;
104	<	FXMLTag: TXMLTag;
105	<	FXMLMode: integer;
51	>	FTransaction: TIBTransaction;
52		protected
53	<	FNextStatement: boolean;
54	<	function GetErrorPrefix: string; virtual; abstract;
55	<	function GetNextSymbol(C: char): TSQLSymbol;
110	<	function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
111	<	function GetNextLine(var Line: string):boolean; virtual; abstract;
53	>	procedure EchoNextLine(aLine: string);
54	>	function GetAttachment: IAttachment; override;
55	>	function GetTransaction: ITransaction; override;
56		public
57		constructor Create;
58	<	procedure ShowError(msg: string; params: array of const);
59	<	function GetSymbol: TSQLSymbol; virtual;
60	<	procedure NextStatement;
117	<	property SymbolValue: string read FString;
118	<	property Terminator: char read FTerminator write FTerminator;
119	<	property XMLTag: TXMLTag read FXMLTag;
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 OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
62	>	property Database: TIBDatabase read FDatabase write FDatabase;
63	>	property Transaction: TIBTransaction read FTransaction write FTransaction;
64		end;
65
124	–	{ TBatchSymbolStream }
66
67	<	{This symbol stream supports non-interactive parsing of a text file, stream or
67	>	{ TBatchSQLStatementReader }
68	>
69	>	{This SQL Reader supports non-interactive parsing of a text file, stream or
70		lines of text.}
71
72	<	TBatchSymbolStream = class(TSymbolStream)
72	>	TBatchSQLStatementReader = class(TSQLStatementReader)
73		private
74	<	FLines: TStrings;
74	>	FInStream: TStream;
75	>	FOwnsInStream: boolean;
76		FLineIndex: integer;
77	+	FIndex: integer;
78	+	FCurLine: string;
79		protected
80	<	function GetErrorPrefix: string; override;
81	<	function GetNextLine(var Line: string):boolean; override;
80	>	function GetChar: AnsiChar; override;
81	>	function GetErrorPrefix: AnsiString; override;
82		public
83	<	constructor Create;
138	<	destructor Destroy; override;
83	>	procedure Reset; override;
84		procedure SetStreamSource(Lines: TStrings); overload;
85		procedure SetStreamSource(S: TStream); overload;
86		procedure SetStreamSource(FileName: string); overload;
87	+	procedure SetStringStreamSource(S: string);
88		end;
89
90	<	{ TInteractiveSymbolStream }
90	>	{ TInteractiveSQLStatementReader }
91
92	<	{This symbol stream supports interactive parsing of commands and
92	>	{This SQL reader supports interactive parsing of commands and
93		SQL statements entered at a console}
94
95	<	TInteractiveSymbolStream = class(TSymbolStream)
95	>	TInteractiveSQLStatementReader = class(TSQLStatementReader)
96		private
97		FPrompt: string;
98		FContinuePrompt: string;
99		FTerminated: boolean;
100	+	FLine: string;
101	+	FLineIndex: integer;
102	+	FNextStatement: boolean;
103	+	function GetNextLine(var Line: string):boolean;
104		protected
105	<	function GetErrorPrefix: string; override;
106	<	function GetNextLine(var Line: string):boolean; override;
105	>	function GetChar: AnsiChar; override;
106	>	function GetErrorPrefix: AnsiString; override;
107		public
108		constructor Create(aPrompt: string='SQL>'; aContinue: string = 'CON>');
109	<	function GetSymbol: TSQLSymbol; override;
109	>	function GetNextStatement(var stmt: string) : boolean; override;
110		property Terminated: boolean read FTerminated write FTerminated;
111		end;
112
163	–	TBlobData = record
164	–	BlobIntf: IBlob;
165	–	SubType: cardinal;
166	–	end;
167	–
168	–	TArrayData = record
169	–	ArrayIntf: IArray;
170	–	SQLType: cardinal;
171	–	relationName: string;
172	–	columnName: string;
173	–	dim: cardinal;
174	–	Size: cardinal;
175	–	Scale: integer;
176	–	CharSet: string;
177	–	bounds: TArrayBounds;
178	–	CurrentRow: integer;
179	–	Index: array of integer;
180	–	end;
181	–
182	–	{ TIBXMLProcessor }
183	–
184	–	{This is a simple XML parser that parses the output of a symbol stream as XML
185	–	structured data, recognising tags, attributes and data. The tags are given in
186	–	the table XMLTagDefs. The BlobData and ArrayData properties return blob and
187	–	array data decoded from the XML stream.}
188	–
189	–	TIBXMLProcessor = class
190	–	private
191	–	FDatabase: TIBDatabase;
192	–	FSymbolStream: TSymbolStream;
193	–	FState: TXMLStates;
194	–	FTransaction: TIBTransaction;
195	–	FXMLTagStack: array [1..20] of TXMLTag;
196	–	FXMLTagIndex: integer;
197	–	FAttributeName: string;
198	–	FBlobData: array of TBlobData;
199	–	FCurrentBlob: integer;
200	–	FArrayData: array of TArrayData;
201	–	FCurrentArray: integer;
202	–	FBlobBuffer: PChar;
203	–	procedure EndXMLTag(xmltag: TXMLTag);
204	–	procedure EnterTag;
205	–	function GetArrayData(index: integer): TArrayData;
206	–	function GetArrayDataCount: integer;
207	–	function GetBlobData(index: integer): TBlobData;
208	–	function GetBlobDataCount: integer;
209	–	procedure ProcessTagValue(tagValue: string);
210	–	procedure StartXMLTag(xmltag: TXMLTag);
211	–	procedure ProcessAttributeValue(attrValue: string);
212	–	procedure ProcessBoundsList(boundsList: string);
213	–	public
214	–	constructor Create;
215	–	destructor Destroy; override;
216	–	function AnalyseXML(SymbolStream: TSymbolStream): string;
217	–	procedure NextStatement;
218	–	class function FormatBlob(Field: ISQLData): string;
219	–	class function FormatArray(Database: TIBDatabase; ar: IArray): string;
220	–	property BlobData[index: integer]: TBlobData read GetBlobData;
221	–	property BlobDataCount: integer read GetBlobDataCount;
222	–	property ArrayData[index: integer]: TArrayData read GetArrayData;
223	–	property ArrayDataCount: integer read GetArrayDataCount;
224	–	property Database: TIBDatabase read FDatabase write FDatabase;
225	–	property Transaction: TIBTransaction read FTransaction write FTransaction;
226	–	end;
227	–
228	–	{ TIBSQLProcessor }
229	–
230	–	{This parses a symbol stream into SQL statements. If embedded XML is found then
231	–	this is processed by the supplied XMLProcessor. The HasBegin property provides
232	–	a simple way to recognised stored procedure DDL, and "Execute As" statements.}
233	–
234	–	TIBSQLProcessor = class
235	–	private
236	–	FSQLText: string;
237	–	FState: TSQLStates;
238	–	FStack: array [0..16] of TSQLStates;
239	–	FStackindex: integer;
240	–	FHasBegin: boolean;
241	–	FInCase: boolean;
242	–	FNested: integer;
243	–	FXMLProcessor: TIBXMLProcessor;
244	–	FSymbolStream: TSymbolStream;
245	–	procedure AddToSQL(const Symbol: string);
246	–	procedure SetState(AState: TSQLStates);
247	–	function PopState: TSQLStates;
248	–	public
249	–	constructor Create(XMLProcessor: TIBXMLProcessor);
250	–	function GetNextStatement(SymbolStream: TSymbolStream; var stmt: string) : boolean;
251	–	property HasBegin: boolean read FHasBegin;
252	–	end;
253	–
113		TGetParamValue = procedure(Sender: TObject; ParamName: string; var BlobID: TISC_QUAD) of object;
114		TLogEvent = procedure(Sender: TObject; Msg: string) of Object;
115		TOnSelectSQL = procedure (Sender: TObject; SQLText: string) of object;
#	Line 272 | Line 131 | type
131		TCustomIBXScript = class(TComponent)
132		private
133		FEcho: boolean;
134	<	FIBXMLProcessor: TIBXMLProcessor;
276	<	FIBSQLProcessor: TIBSQLProcessor;
134	>	FSQLReader: TSQLStatementReader;
135		FDatabase: TIBDatabase;
136		FDataOutputFormatter: TIBCustomDataOutput;
137		FIgnoreCreateDatabase: boolean;
#	Line 302 | Line 160 | type
160		procedure SetShowPerformanceStats(AValue: boolean);
161		procedure SetTransaction(AValue: TIBTransaction);
162		protected
305	–	FSymbolStream: TSymbolStream;
163		procedure Add2Log(const Msg: string; IsError: boolean=true); virtual;
164		procedure ExecSQL(stmt: string);
165		procedure EchoNextLine(Sender: TObject; Line: string);
166		procedure Notification(AComponent: TComponent; Operation: TOperation); override;
167		function ProcessStatement(stmt: string): boolean; virtual;
168		function ProcessStream: boolean;
169	+	procedure SetSQLStatementReader(SQLStatementReader: TSQLStatementReader);
170		public
171		constructor Create(aOwner: TComponent); override;
172		destructor Destroy; override;
173		procedure DefaultSelectSQLHandler(aSQLText: string);
174	+	property SQLStatementReader: TSQLStatementReader read FSQLReader;
175		published
176		property Database: TIBDatabase read FDatabase write SetDatabase;
177		property DataOutputFormatter: TIBCustomDataOutput read FDataOutputFormatter
#	Line 419 | Line 278 | type
278		function ExecSQLScript(sql: string): boolean;
279		end;
280
422	–	function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
423	–	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
424	–
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
289		uses Sysutils, RegExpr;
290
291		resourcestring
434	–	sTerminatorUnknownState = 'Statement Terminator in unexpected state (%d)';
292		sNoSelectSQL = 'Select SQL Statements are not supported';
436	–	sStackUnderflow = 'Stack Underflow';
293		sNoParamQueries =  'Parameterised Queries are not supported';
438	–	sStackOverFlow = 'Stack Overflow';
294		sResolveQueryParam =  'Resolving Query Parameter: %s';
440	–	sXMLStackUnderflow = 'XML Stack Underflow';
441	–	sInvalidEndTag = 'XML End Tag Mismatch - %s';
442	–	sXMLStackOverFlow = 'XML Stack Overflow';
443	–	sErrorState = 'Entered Error State';
444	–	sXMLError = 'Invalid XML (%c)';
445	–	sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
446	–	sInvalidBoundsList = 'Invalid array bounds list - "%s"';
447	–	sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
448	–	sInvalidCharacterSet = 'Unrecognised character set name - "%s"';
449	–	sOnLineError = 'On Line %d Character %d: ';
450	–	sArrayIndexError = 'Array Index Error (%d)';
451	–	sBlobIndexError = 'Blob Index Error (%d)';
295		sStatementError = 'Error processing SQL statement: %s %s - for statement "%s"';
296
297	<	function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
297	>	{ TSQLStatementReader }
298
299	<	function ToHex(aValue: byte): string;
300	<	const
301	<	HexChars: array [0..15] of char = '0123456789ABCDEF';
302	<	begin
303	<	Result := HexChars[aValue shr 4] +
461	<	HexChars[(aValue and $0F)];
462	<	end;
299	>	procedure TSQLStatementReader.EchoNextLine(aLine: string);
300	>	begin
301	>	if assigned(FOnNextLine) then
302	>	OnNextLine(self,aLine);
303	>	end;
304
305	<	var i, j: integer;
305	>	function TSQLStatementReader.GetAttachment: IAttachment;
306		begin
307	<	i := 1;
308	<	Result := '';
468	<	if MaxLineLength = 0 then
469	<	while i <= Length(octetString) do
470	<	begin
471	<	Result += ToHex(byte(octetString[i]));
472	<	Inc(i);
473	<	end
307	>	if FDatabase <> nil then
308	>	Result := FDatabase.Attachment
309		else
310	<	while i <= Length(octetString) do
311	<	begin
312	<	for j := 1 to MaxLineLength do
310	>	Result := nil;
311	>	end;
312	>
313	>	function TSQLStatementReader.GetTransaction: ITransaction;
314	>	begin
315	>	if FTransaction <> nil then
316	>	Result := FTransaction.TransactionIntf
317	>	else
318	>	Result := nil;
319	>	end;
320	>
321	>	constructor TSQLStatementReader.Create;
322	>	begin
323	>	inherited Create;
324	>	Terminator := DefaultTerminator;
325	>	end;
326	>
327	>	function TSQLStatementReader.GetNextStatement(var stmt: string): boolean;
328	>	var State: TSQLState;
329	>	Nested: integer;
330	>	token: TSQLTokens;
331	>	EndOfStatement: boolean;
332	>	begin
333	>	FHasBegin := false;
334	>	EndOfStatement := false;
335	>	Nested := 0;
336	>	stmt := '';
337	>	State := stDefault;
338	>	while not EOF and not EndOfStatement do
339	>	begin
340	>	token := GetNextToken;
341	>	//    writeln(token,' ',TokenText,' ',Terminator);
342	>	case State of
343	>	stDefault:
344	>	{ignore everything before a reserved word}
345	>	if (token <= high(TSQLReservedWords)) or (token = sqltIdentifier) then
346	>	begin
347	>	State := stInStmt;
348	>	stmt += TokenText;
349	>	end;
350	>
351	>	stInStmt:
352	>	begin
353	>	case token of
354	>	sqltBegin:
355	>	begin
356	>	FHasBegin := true;
357	>	State := stInBlock;
358	>	Nested := 1;
359	>	stmt += TokenText;
360	>	end;
361	>
362	>	sqltDeclare:
363	>	begin
364	>	State := stInDeclare;
365	>	stmt += TokenText;
366	>	end;
367	>
368	>	sqltOpenSquareBracket:
369	>	begin
370	>	State := stInArrayDim;
371	>	stmt += TokenText;
372	>	end;
373	>
374	>	sqltComment:
375	>	stmt += '/*' + TokenText + '*/';
376	>
377	>	sqltCommentLine:
378	>	stmt += '/*' + TokenText + ' */' + LineEnding;
379	>
380	>	sqltQuotedString:
381	>	stmt += '''' + SQLSafeString(TokenText) + '''';
382	>
383	>	sqltIdentifierInDoubleQuotes:
384	>	stmt += '"' + TokenText + '"';
385	>
386	>	sqltEOL:
387	>	stmt += LineEnding;
388	>
389	>	else
390	>	begin
391	>	if (tokentext = Terminator) and (Nested = 0) then
392	>	begin
393	>	EndOfStatement := true;
394	>	State := stDefault;
395	>	end
396	>	else
397	>	stmt += TokenText;
398	>	end;
399	>	end;
400	>	end;
401	>
402	>	{ignore begin..end blocks for Terminator detection }
403	>
404	>	stInBlock:
405	>	begin
406	>	case token of
407	>	sqltBegin:
408	>	begin
409	>	Inc(Nested);
410	>	stmt += TokenText;
411	>	end;
412	>
413	>	sqltEnd:
414	>	begin
415	>	Dec(Nested);
416	>	stmt += TokenText;
417	>	if Nested = 0 then
418	>	begin
419	>	State := stDefault;
420	>	EndOfStatement := true;
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	>
440	>	sqltCommentLine:
441	>	stmt += '/* ' + TokenText + ' */' + LineEnding;
442	>
443	>	sqltQuotedString:
444	>	stmt += '''' + SQLSafeString(TokenText) + '''';
445	>
446	>	sqltIdentifierInDoubleQuotes:
447	>	stmt += '"' + TokenText + '"';
448	>
449	>	sqltEOL:
450	>	stmt += LineEnding;
451	>
452	>	else
453	>	stmt += TokenText;
454	>	end;
455	>	end;
456	>
457	>	{ignore array dimensions for Terminator detection }
458	>
459	>	stInArrayDim:
460		begin
461	<	if i > Length(octetString) then
462	<	Exit
461	>	case token of
462	>
463	>	sqltComment:
464	>	stmt += '/*' + TokenText + '*/';
465	>
466	>	sqltCommentLine:
467	>	stmt += '/* ' + TokenText + ' */' + LineEnding;
468	>
469	>	sqltCloseSquareBracket:
470	>	begin
471	>	stmt += TokenText;
472	>	State := stInStmt;
473	>	end;
474	>
475	>	sqltEOL:
476	>	stmt += LineEnding;
477	>
478		else
479	<	Result += ToHex(byte(octetString[i]));
480	<	inc(i);
479	>	stmt += TokenText;
480	>	end;
481		end;
485	–	Result += LineEnding;
486	–	end;
487	–	end;
482
483	<	procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
484	<	begin
485	<	TextOut.Add(StringToHex(octetString,MaxLineLength));
483	>	{ignore Declare statement for terminator - semi-colon terminates declaration}
484	>
485	>	stInDeclare:
486	>	begin
487	>	case token of
488	>
489	>	sqltComment:
490	>	stmt += '/*' + TokenText + '*/';
491	>
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	>
504	>	sqltEOL:
505	>	stmt += LineEnding;
506	>
507	>	else
508	>	stmt += TokenText;
509	>	end;
510	>	end;
511	>	end;
512	>	//    writeln(stmt);
513	>	end;
514	>	Result := stmt <> '';
515		end;
516
517
#	Line 498 | Line 521 | end;
521		constructor TIBXScript.Create(aOwner: TComponent);
522		begin
523		inherited Create(aOwner);
524	<	FSymbolStream := TBatchSymbolStream.Create;
502	<	FSymbolStream.OnNextLine := @EchoNextLine;
524	>	SetSQLStatementReader(TBatchSQLStatementReader.Create);
525		end;
526
527		function TIBXScript.PerformUpdate(SQLFile: string; aAutoDDL: boolean): boolean;
#	Line 517 | Line 539 | end;
539
540		function TIBXScript.RunScript(SQLFile: string): boolean;
541		begin
542	<	TBatchSymbolStream(FSymbolStream).SetStreamSource(SQLFile);
542	>	TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLFile);
543		Result := ProcessStream;
544		end;
545
546		function TIBXScript.RunScript(SQLStream: TStream): boolean;
547		begin
548	<	TBatchSymbolStream(FSymbolStream).SetStreamSource(SQLStream);
548	>	TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLStream);
549		Result := ProcessStream;
550		end;
551
552		function TIBXScript.RunScript(SQLLines: TStrings): boolean;
553		begin
554	<	TBatchSymbolStream(FSymbolStream).SetStreamSource(SQLLines);
554	>	TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLLines);
555		Result := ProcessStream;
556		end;
557
558		function TIBXScript.ExecSQLScript(sql: string): boolean;
537	–	var s: TStringList;
559		begin
560	<	s := TStringList.Create;
561	<	try
541	<	s.Text := sql;
542	<	TBatchSymbolStream(FSymbolStream).SetStreamSource(s);
543	<	Result := ProcessStream;
544	<	finally
545	<	s.Free;
546	<	end;
560	>	TBatchSQLStatementReader(FSQLReader).SetStringStreamSource(sql);
561	>	Result := ProcessStream;
562		end;
563
564		{ TCustomIBXScript }
#	Line 561 | Line 576 | end;
576		procedure TCustomIBXScript.DoCommit;
577		begin
578		with GetTransaction do
564	–	begin
579		if InTransaction then Commit;
566	–	Active := true;
567	–	end;
580		end;
581
582		procedure TCustomIBXScript.DoReconnect;
571	–	var LoginPrompt: boolean;
583		begin
584		with GetTransaction do
585		if InTransaction then Commit;
586	<	LoginPrompt := Database.LoginPrompt;
576	<	Database.LoginPrompt := false;
577	<	Database.Connected := false;
578	<	Database.Connected := true;
579	<	Database.LoginPrompt := LoginPrompt;
580	<	GetTransaction.Active := true;
586	>	Database.Reconnect;
587		end;
588
589		procedure TCustomIBXScript.ExecSQL(stmt: string);
#	Line 588 | Line 594 | begin
594		FISQL.SQL.Text := stmt;
595		FISQL.Transaction := GetTransaction;
596		FISQL.Transaction.Active := true;
597	<	FISQL.ParamCheck := not FIBSQLProcessor.HasBegin; {Probably PSQL}
597	>	//   FISQL.ParamCheck := not FSQLReader.HasBegin; {Probably PSQL}
598		FISQL.Prepare;
599		FISQL.Statement.EnableStatistics(ShowPerformanceStats);
600
#	Line 627 | Line 633 | end;
633
634		function TCustomIBXScript.GetOnProgressEvent: TOnProgressEvent;
635		begin
636	<	Result := FSymbolStream.OnProgressEvent;
636	>	Result := FSQLReader.OnProgressEvent;
637		end;
638
639		function TCustomIBXScript.GetTransaction: TIBTransaction;
#	Line 660 | Line 666 | begin
666		if not (csLoading in ComponentState) and (FDatabase = AValue) then Exit;
667		FDatabase := AValue;
668		FISQL.Database := AValue;
663	–	FIBXMLProcessor.Database := AValue;
669		FInternalTransaction.Active := false;
670		FInternalTransaction.DefaultDatabase := AValue;
671		end;
#	Line 677 | Line 682 | end;
682
683		procedure TCustomIBXScript.SetOnProgressEvent(AValue: TOnProgressEvent);
684		begin
685	<	FSymbolStream.OnProgressEvent := AValue;
685	>	FSQLReader.OnProgressEvent := AValue;
686		end;
687
688		procedure TCustomIBXScript.SetParamValue(SQLVar: ISQLParam);
689		var BlobID: TISC_QUAD;
690		ix: integer;
691		begin
692	<	if (SQLVar.SQLType = SQL_BLOB) and (Pos(ibx_blob,SQLVar.Name) = 1) then
692	>	if (SQLVar.SQLType = SQL_BLOB) and (Pos(TSQLXMLReader.ibx_blob,SQLVar.Name) = 1) then
693		begin
694	<	ix := StrToInt(system.copy(SQLVar.Name,length(ibx_blob)+1,length(SQLVar.Name)-length(ibx_blob)));
695	<	SQLVar.AsBlob := FIBXMLProcessor.BlobData[ix].BlobIntf;
694	>	ix := StrToInt(system.copy(SQLVar.Name,length(TSQLXMLReader.ibx_blob)+1,length(SQLVar.Name)-length(TSQLXMLReader.ibx_blob)));
695	>	SQLVar.AsBlob := FSQLReader.BlobData[ix].BlobIntf;
696		Exit;
697		end
698		else
699	<	if (SQLVar.SQLType = SQL_ARRAY) and (Pos(ibx_array,SQLVar.Name) = 1) then
699	>	if (SQLVar.SQLType = SQL_ARRAY) and (Pos(TSQLXMLReader.ibx_array,SQLVar.Name) = 1) then
700		begin
701	<	ix := StrToInt(system.copy(SQLVar.Name,length(ibx_array)+1,length(SQLVar.Name)-length(ibx_array)));
702	<	SQLVar.AsArray := FIBXMLProcessor.ArrayData[ix].ArrayIntf;
701	>	ix := StrToInt(system.copy(SQLVar.Name,length(TSQLXMLReader.ibx_array)+1,length(SQLVar.Name)-length(TSQLXMLReader.ibx_array)));
702	>	SQLVar.AsArray := FSQLReader.ArrayData[ix].ArrayIntf;
703		Exit;
704		end;
705
#	Line 723 | Line 728 | function TCustomIBXScript.ProcessStream:
728		var stmt: string;
729		begin
730		Result := false;
731	<	while FIBSQLProcessor.GetNextStatement(FSymbolStream,stmt) do
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	<	//    writeln('stmt = ',stmt);
739	<	if trim(stmt) = '' then continue;
738	>	stmt := trim(stmt);
739	>	//    writeln('stmt = "',stmt,'"');
740	>	if stmt = '' then continue;
741		if not ProcessStatement(stmt) then
742		ExecSQL(stmt);
743
#	Line 734 | Line 745 | begin
745		begin
746		with GetTransaction do
747		if InTransaction then Rollback;
748	<	FSymbolStream.Terminator := DefaultTerminator;
748	>	FSQLReader.Terminator := TSQLStatementReader.DefaultTerminator;
749		if assigned(OnErrorLog) then
750		begin
751	<	Add2Log(Format(sStatementError,[FSymbolStream.GetErrorPrefix,
751	>	Add2Log(Format(sStatementError,[FSQLReader.GetErrorPrefix,
752		E.Message,stmt]),true);
753		if StopOnFirstError then Exit;
754		end
#	Line 748 | Line 759 | begin
759		Result := true;
760		end;
761
762	+	procedure TCustomIBXScript.SetSQLStatementReader(
763	+	SQLStatementReader: TSQLStatementReader);
764	+	begin
765	+	FSQLReader := SQLStatementReader;
766	+	FSQLReader.OnNextLine := @EchoNextLine;
767	+	end;
768	+
769		function TCustomIBXScript.ProcessStatement(stmt: string): boolean;
770		var command: string;
753	–	ucStmt: string;
771
772		function Toggle(aValue: string): boolean;
773		begin
#	Line 771 | Line 788 | var command: string;
788		try
789		RegexObj.ModifierG := false; {turn off greedy matches}
790		RegexObj.Expression := ' +USER +''(.+)''';
791	<	if RegexObj.Exec(ucStmt) then
791	>	if RegexObj.Exec(stmt) then
792		FDatabase.Params.Values['user_name'] := RegexObj.Match[1];
793
794		RegexObj.Expression := ' +PASSWORD +''(.+)''';
795	<	if RegexObj.Exec(ucStmt) then
795	>	if RegexObj.Exec(stmt) then
796		FDatabase.Params.Values['password'] :=
797		system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
798		finally
#	Line 790 | Line 807 | var command: string;
807		RegexObj := TRegExpr.Create;
808		try
809		RegexObj.ModifierG := false; {turn off greedy matches}
810	+	RegexObj.ModifierI := true; {case insensitive}
811		RegexObj.Expression := '^ *CONNECT +''(.*)''';
812	<	if RegexObj.Exec(ucStmt) then
812	>	if RegexObj.Exec(stmt) then
813		begin
814		FDatabase.DatabaseName := system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
815		end;
816
817		RegexObj.Expression := ' +ROLE +''(.+)''';
818	<	if RegexObj.Exec(ucStmt) then
818	>	if RegexObj.Exec(stmt) then
819		FDatabase.Params.Values['sql_role_name'] := RegexObj.Match[1]
820		else
821		with FDatabase.Params do
#	Line 805 | Line 823 | var command: string;
823		Delete(IndexOfName('sql_role_name'));
824
825		RegexObj.Expression := ' +CACHE +([0-9]+)';
826	<	if RegexObj.Exec(ucStmt) then
826	>	if RegexObj.Exec(stmt) then
827		FDatabase.Params.Values['cache_manager'] := RegexObj.Match[1]
828		else
829		with FDatabase.Params do
#	Line 822 | Line 840 | var command: string;
840		RegexObj := TRegExpr.Create;
841		try
842		RegexObj.ModifierG := false; {turn off greedy matches}
843	+	RegexObj.ModifierI := true; {case insensitive}
844		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'') +USER +''(.+)''';
845	<	if not RegexObj.Exec(ucStmt) and (FDatabase.Params.IndexOfName('user_name') <> -1) then
845	>	if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('user_name') <> -1) then
846		begin
847		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'')';
848	<	if RegexObj.Exec(ucStmt) then
848	>	if RegexObj.Exec(stmt) then
849		begin
850		system.Insert(' USER ''' + FDatabase.Params.Values['user_name'] +'''',stmt,
851		RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
833	–	ucStmt := AnsiUpperCase(stmt);
852		end;
853		end;
854
855		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +USER +''.+'' PASSWORD +''(.+)''';
856	<	if not RegexObj.Exec(ucStmt) and (FDatabase.Params.IndexOfName('password') <> -1) then
856	>	if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('password') <> -1) then
857		begin
858		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +(USER +''.+'')';
859	<	if RegexObj.Exec(ucStmt) then
859	>	if RegexObj.Exec(stmt) then
860		begin
861		system.Insert(' PASSWORD ''' + FDatabase.Params.Values['password'] +'''',stmt,
862		RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
845	–	ucStmt := AnsiUpperCase(stmt);
863		end;
864		end;
865		finally
#	Line 860 | Line 877 | var  RegexObj: TRegExpr;
877		LoginPrompt: boolean;
878		begin
879		Result := false;
880	<	ucStmt := AnsiUpperCase(stmt);
864	<	Terminator := FSymbolStream.Terminator;
880	>	Terminator := FSQLReader.Terminator;
881		RegexObj := TRegExpr.Create;
882		try
883		{process create database}
884	+	RegexObj.ModifierI := true; {case insensitive}
885		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''(.*)(\' + Terminator + '|)';
886	<	if RegexObj.Exec(ucStmt) then
886	>	if RegexObj.Exec(stmt) then
887		begin
888		if IgnoreCreateDatabase then
889		begin
#	Line 877 | Line 894 | begin
894		if assigned(FOnCreateDatabase) then
895		OnCreateDatabase(self,FileName);
896		stmt := 'CREATE DATABASE ''' + FileName + '''' + system.copy(stmt,RegexObj.MatchPos[3], RegexObj.MatchLen[3]);
880	–	ucStmt := AnsiUpperCase(stmt);
897		UpdateUserPassword;
898	<	FDatabase.Connected := false;
898	>	if FDatabase.Connected then
899	>	FDatabase.Dropdatabase;
900		FDatabase.CreateDatabase(stmt);
884	–	FDatabase.Connected := false;
885	–	ExtractUserInfo;
886	–	DoReconnect;
901		Result := true;
902		Exit;
903		end;
904
905		{process connect statement}
906		RegexObj.Expression := '^ *CONNECT +.*(\' + Terminator + '|)';
907	<	if RegexObj.Exec(ucStmt) then
907	>	if RegexObj.Exec(stmt) then
908		begin
909		ExtractConnectInfo;
910	<	DoReconnect;
910	>	FDatabase.Connected := false;
911	>	FDatabase.Connected := true;
912		Result := true;
913		Exit;
914		end;
915
916		{Process Drop Database}
917		RegexObj.Expression := '^ *DROP +DATABASE *(\' + Terminator + '|)';
918	<	if RegexObj.Exec(ucStmt) then
918	>	if RegexObj.Exec(stmt) then
919		begin
920		FDatabase.DropDatabase;
921		Result := true;
#	Line 909 | Line 924 | begin
924
925		{process commit statement}
926		RegexObj.Expression := '^ *COMMIT *(\' + Terminator + '|)';
927	<	if RegexObj.Exec(ucStmt) then
927	>	if RegexObj.Exec(stmt) then
928		begin
929		DoCommit;
930		Result := true;
#	Line 918 | Line 933 | begin
933
934		{process Reconnect statement}
935		RegexObj.Expression := '^ *RECONNECT *(\' + Terminator + '|)';
936	<	if RegexObj.Exec(ucStmt) then
936	>	if RegexObj.Exec(stmt) then
937		begin
938		DoReconnect;
939		Result := true;
#	Line 928 | Line 943 | begin
943
944		{Process Set Term}
945		RegexObj.Expression := '^ *SET +TERM +(.) *(\' + Terminator + '|)';
946	<	if RegexObj.Exec(ucStmt) then
946	>	if RegexObj.Exec(stmt) then
947		begin
948	<	FSymbolStream.Terminator := RegexObj.Match[1][1];
948	>	FSQLReader.Terminator := RegexObj.Match[1][1];
949		Result := true;
950		Exit;
951		end;
952
953		{process Set SQL Dialect}
954		RegexObj.Expression := '^ *SET +SQL +DIALECT +([0-9]) *(\' + Terminator + '|)';
955	<	if RegexObj.Exec(ucStmt) then
955	>	if RegexObj.Exec(stmt) then
956		begin
957		n := StrToInt(RegexObj.Match[1]);
958		if Database.SQLDialect <> n then
#	Line 952 | Line 967 | begin
967
968		{Process Remaining Set statements}
969		RegexObj.Expression := '^ *SET +([A-Z]+)( +[A-Z0-9]+|) *(\' + Terminator + '|)';
970	<	if RegexObj.Exec(ucStmt) then
970	>	if RegexObj.Exec(stmt) then
971		begin
972		command := AnsiUpperCase(RegexObj.Match[1]);
973		param := trim(RegexObj.Match[2]);
974	+	if command = 'GENERATOR' then
975	+	begin
976	+	Result := false;
977	+	Exit;
978	+	end;
979		if command = 'AUTODDL' then
980		AutoDDL := ((RegexObj.MatchLen[2] = 0) and not AutoDDL) or
981		(RegexObj.MatchLen[2] > 0) and Toggle(param)
#	Line 995 | Line 1015 | begin
1015		begin
1016		if assigned(DataOutputFormatter) then
1017		DataOutputFormatter.SetCommand(command,param,stmt,Result);
1018	<	if not Result and assigned(OnSetStatement) then
1019	<	OnSetStatement(self,command,param,stmt,Result)
1020	<	else
1021	<	raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
1018	>	if not Result then
1019	>	begin
1020	>	if assigned(OnSetStatement) then
1021	>	OnSetStatement(self,command,param,stmt,Result)
1022	>	else
1023	>	raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
1024	>	end;
1025		Exit;
1026		end;
1027		Result := true;
#	Line 1014 | Line 1037 | procedure TCustomIBXScript.SetTransactio
1037		begin
1038		if FTransaction = AValue then Exit;
1039		FTransaction := AValue;
1017	–	FIBXMLProcessor.Transaction := AValue;
1040		end;
1041
1042		constructor TCustomIBXScript.Create(aOwner: TComponent);
#	Line 1025 | Line 1047 | begin
1047		FAutoDDL := true;
1048		FISQL := TIBSQL.Create(self);
1049		FISQL.ParamCheck := true;
1028	–	FIBXMLProcessor := TIBXMLProcessor.Create;
1029	–	FIBSQLProcessor := TIBSQLProcessor.Create(FIBXMLProcessor);
1050		FInternalTransaction := TIBTransaction.Create(self);
1051		FInternalTransaction.Params.Clear;
1052		FInternalTransaction.Params.Add('concurrency');
#	Line 1035 | Line 1055 | end;
1055
1056		destructor TCustomIBXScript.Destroy;
1057		begin
1058	<	if FIBSQLProcessor <> nil then FIBSQLProcessor.Free;
1039	<	if FIBXMLProcessor <> nil then FIBXMLProcessor.Free;
1040	<	if FSymbolStream <> nil then FSymbolStream.Free;
1058	>	if FSQLReader <> nil then FSQLReader.Free;
1059		if FISQL <> nil then FISQL.Free;
1060		if FInternalTransaction <> nil then FInternalTransaction.Free;
1061		inherited Destroy;
#	Line 1048 | Line 1066 | begin
1066		if assigned(DataOutputFormatter) then
1067		DataOutputFormatter.DataOut(aSQLText,@Add2Log)
1068		else
1069	<	FSymbolStream.ShowError(sNoSelectSQL,[nil]);
1052	<	end;
1053	<
1054	<	{ TIBSQLProcessor }
1055	<
1056	<	procedure TIBSQLProcessor.AddToSQL(const Symbol: string);
1057	<	begin
1058	<	FSQLText := FSQLText +  Symbol;
1059	<	//  writeln('SQL = ',FSQLText);
1060	<	end;
1061	<
1062	<	procedure TIBSQLProcessor.SetState(AState: TSQLStates);
1063	<	begin
1064	<	if FStackIndex > 16 then
1065	<	FSymbolStream.ShowError(sStackOverFlow,[nil]);
1066	<	FStack[FStackIndex] := FState;
1067	<	Inc(FStackIndex);
1068	<	FState := AState
1069	>	FSQLReader.ShowError(sNoSelectSQL);
1070		end;
1071
1072	<	function TIBSQLProcessor.PopState: TSQLStates;
1072	<	begin
1073	<	if FStackIndex = 0 then
1074	<	FSymbolStream.ShowError(sStackUnderflow,[nil]);
1075	<	Dec(FStackIndex);
1076	<	Result := FStack[FStackIndex]
1077	<	end;
1072	>	{ TInteractiveSQLStatementReader }
1073
1074	<	constructor TIBSQLProcessor.Create(XMLProcessor: TIBXMLProcessor);
1074	>	function TInteractiveSQLStatementReader.GetErrorPrefix: AnsiString;
1075		begin
1076	<	inherited Create;
1082	<	FXMLProcessor := XMLProcessor;
1076	>	Result := '';
1077		end;
1078
1079	<	function TIBSQLProcessor.GetNextStatement(SymbolStream: TSymbolStream;
1086	<	var stmt: string): boolean;
1087	<	var Symbol: TSQLSymbol;
1088	<	NonSpace: boolean;
1089	<	Done: boolean;
1079	>	function TInteractiveSQLStatementReader.GetNextLine(var Line: string): boolean;
1080		begin
1081	<	FSQLText := '';
1082	<	FState := stInit;
1083	<	FHasBegin := false;
1084	<	FSymbolStream := SymbolStream;
1085	<	FXMLProcessor.NextStatement;
1086	<	SymbolStream.NextStatement;
1097	<
1098	<	Result := true;
1099	<	Done := false;
1100	<	NonSpace := false;
1101	<	while not Done do
1102	<	with SymbolStream do
1081	>	if FNextStatement then
1082	>	write(FPrompt)
1083	>	else
1084	>	write(FContinuePrompt);
1085	>	Result := not system.EOF;
1086	>	if Result then
1087		begin
1088	<	if FState = stError then
1089	<	ShowError(sErrorState,[nil]);
1106	<	Symbol := GetSymbol;
1107	<	//    writeln('Symbol = ',Symbol,' Value = ',SymbolValue);
1108	<	if not (Symbol in [' ',sqEOL]) then
1109	<	NonSpace := true;
1110	<
1111	<	case Symbol of
1112	<	sqTag:
1113	<	begin
1114	<	if FState in [stInSQL,stNested] then
1115	<	AddToSQL(FXMLProcessor.AnalyseXML(SymbolStream));
1116	<	end;
1117	<
1118	<	sqTerminator:
1119	<	case FState of
1120	<	stInit: {ignore empty statement};
1121	<
1122	<	stInSQL:
1123	<	Done := true;
1124	<
1125	<	stNested:
1126	<	AddToSQL(Terminator);
1127	<
1128	<	stInDeclaration:
1129	<	begin
1130	<	FState := PopState;
1131	<	AddToSQL(Terminator);
1132	<	end;
1133	<
1134	<	else
1135	<	ShowError(sTerminatorUnknownState,[FState]);
1136	<	end;
1137	<
1138	<	';':
1139	<	begin
1140	<	if FState = stInDeclaration then
1141	<	FState := PopState;
1142	<	AddToSQL(';');
1143	<	end;
1144	<
1145	<	'*':
1146	<	begin
1147	<	AddToSQL('*');
1148	<	if FState =  stInit then
1149	<	FState := stInSQL
1150	<	end;
1151	<
1152	<	'/':
1153	<	begin
1154	<	AddToSQL('/');
1155	<	if FState =  stInit then
1156	<	FState := stInSQL
1157	<	end;
1158	<
1159	<	sqComment,
1160	<	sqQuotedString,
1161	<	sqDoubleQuotedString:
1162	<	if FState <> stInit then
1163	<	AddToSQL(SymbolValue);
1164	<
1165	<	sqCommentLine:
1166	<	if FState <> stInit then
1167	<	AddToSQL(SymbolValue + LineEnding);
1168	<
1169	<	sqEnd:
1170	<	begin
1171	<	AddToSQL(SymbolValue);
1172	<	case FState of
1173	<	stNested:
1174	<	begin
1175	<	if FNested = 0 then
1176	<	begin
1177	<	FState := PopState;
1178	<	if not FInCase then
1179	<	begin
1180	<	FState := stInit;
1181	<	Done := true;
1182	<	end
1183	<	else
1184	<	FInCase := false;
1185	<	end
1186	<	else
1187	<	Dec(FNested)
1188	<	end;
1189	<	{Otherwise ignore}
1190	<	end
1191	<	end;
1192	<
1193	<	sqBegin:
1194	<	begin
1195	<	FHasBegin := true;
1196	<	AddToSQL(SymbolValue);
1197	<	case FState of
1198	<	stNested:
1199	<	Inc(FNested);
1200	<
1201	<	stInSQL,
1202	<	stInit:
1203	<	SetState(stNested);
1204	<	end
1205	<	end;
1206	<
1207	<	sqCase:
1208	<	begin
1209	<	AddToSQL(SymbolValue);
1210	<	case FState of
1211	<	stNested:
1212	<	Inc(FNested);
1213	<
1214	<	stInSQL,
1215	<	stInit:
1216	<	begin
1217	<	FInCase := true;
1218	<	SetState(stNested);
1219	<	end;
1220	<	end
1221	<	end;
1222	<
1223	<	sqDeclare:
1224	<	begin
1225	<	AddToSQL(SymbolValue);
1226	<	if FState in [stInit,stInSQL] then
1227	<	SetState(stInDeclaration)
1228	<	end;
1229	<
1230	<	sqString:
1231	<	begin
1232	<	AddToSQL(SymbolValue);
1233	<	if FState = stInit then
1234	<	FState := stInSQL
1235	<	end;
1236	<
1237	<	sqEOL:
1238	<	begin
1239	<	case FState of
1240	<	stInit:
1241	<	{Do nothing};
1242	<	else
1243	<	if NonSpace then AddToSQL(LineEnding);
1244	<	end;
1245	<	end;
1246	<
1247	<	sqEOF:
1248	<	begin
1249	<	Done := true;
1250	<	Result := trim(FSQLText) <> '';
1251	<	end
1252	<	else
1253	<	if FState <> stInit then
1254	<	AddToSQL(Symbol);
1255	<	end
1256	<	end;
1257	<	stmt := FSQLText;
1258	<	//  writeln('stmt = ',stmt);
1259	<	end;
1260	<
1261	<	{ TIBXMLProcessor }
1262	<
1263	<	procedure TIBXMLProcessor.EndXMLTag(xmltag: TXMLTag);
1264	<	begin
1265	<	if FXMLTagIndex = 0 then
1266	<	FSymbolStream.ShowError(sXMLStackUnderflow,[nil]);
1267	<	if xmltag <> FXMLTagStack[FXMLTagIndex] then
1268	<	FSymbolStream.ShowError(sInvalidEndTag,[FSymbolStream.SymbolValue]);
1269	<
1270	<	case FXMLTagStack[FXMLTagIndex] of
1271	<	xtBlob:
1272	<	FBlobData[FCurrentBlob].BlobIntf.Close;
1273	<
1274	<	xtArray:
1275	<	FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
1276	<
1277	<	xtElt:
1278	<	Dec(FArrayData[FCurrentArray].CurrentRow);
1279	<	end;
1280	<	Dec(FXMLTagIndex);
1281	<	end;
1282	<
1283	<	procedure TIBXMLProcessor.EnterTag;
1284	<	var aCharSetID: integer;
1285	<	begin
1286	<	case FXMLTagStack[FXMLTagIndex] of
1287	<	xtBlob:
1288	<	begin
1289	<	Database.Connected := true;
1290	<	Transaction.Active := true;
1291	<	FBlobData[FCurrentBlob].BlobIntf := Database.Attachment.CreateBlob(
1292	<	Transaction.TransactionIntf,FBlobData[FCurrentBlob].SubType);
1293	<	end;
1294	<
1295	<	xtArray:
1296	<	with FArrayData[FCurrentArray] do
1297	<	begin
1298	<	Database.Connected := true;
1299	<	Transaction.Active := true;
1300	<	Database.Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
1301	<	SetLength(Index,dim);
1302	<	ArrayIntf := Database.Attachment.CreateArray(
1303	<	Transaction.TransactionIntf,
1304	<	Database.Attachment.CreateArrayMetaData(SQLType,
1305	<	relationName,columnName,Scale,Size,
1306	<	aCharSetID,dim,bounds)
1307	<	);
1308	<	end;
1088	>	readln(Line);
1089	>	EchoNextLine(Line);
1090		end;
1091		end;
1092
1093	<	function TIBXMLProcessor.GetArrayData(index: integer): TArrayData;
1313	<	begin
1314	<	if (index < 0) or (index > ArrayDataCount) then
1315	<	FSymbolStream.ShowError(sArrayIndexError,[index]);
1316	<	Result := FArrayData[index];
1317	<	end;
1318	<
1319	<	function TIBXMLProcessor.GetArrayDataCount: integer;
1320	<	begin
1321	<	Result := Length(FArrayData);
1322	<	end;
1323	<
1324	<	function TIBXMLProcessor.GetBlobData(index: integer): TBlobData;
1325	<	begin
1326	<	if (index < 0) or (index > BlobDataCount) then
1327	<	FSymbolStream.ShowError(sBlobIndexError,[index]);
1328	<	Result := FBlobData[index];
1329	<	end;
1330	<
1331	<	function TIBXMLProcessor.GetBlobDataCount: integer;
1093	>	function TInteractiveSQLStatementReader.GetChar: AnsiChar;
1094		begin
1095	<	Result := Length(FBlobData);
1096	<	end;
1097	<
1098	<	procedure TIBXMLProcessor.ProcessTagValue(tagValue: string);
1337	<
1338	<	function nibble(hex: char): byte;
1339	<	begin
1340	<	case hex of
1341	<	'0': Result := 0;
1342	<	'1': Result := 1;
1343	<	'2': Result := 2;
1344	<	'3': Result := 3;
1345	<	'4': Result := 4;
1346	<	'5': Result := 5;
1347	<	'6': Result := 6;
1348	<	'7': Result := 7;
1349	<	'8': Result := 8;
1350	<	'9': Result := 9;
1351	<	'a','A': Result := 10;
1352	<	'b','B': Result := 11;
1353	<	'c','C': Result := 12;
1354	<	'd','D': Result := 13;
1355	<	'e','E': Result := 14;
1356	<	'f','F': Result := 15;
1357	<	end;
1358	<	end;
1359	<
1360	<	procedure RemoveWhiteSpace(var hexData: string);
1361	<	var i: integer;
1095	>	if Terminated then
1096	>	Result := #0
1097	>	else
1098	>	if FLineIndex > Length(FLine) then
1099		begin
1100	<	{Remove White Space}
1101	<	i := 1;
1102	<	while i <= length(hexData) do
1103	<	begin
1104	<	case hexData[i] of
1368	<	' ',#9,#10,#13:
1369	<	begin
1370	<	if i < Length(hexData) then
1371	<	Move(hexData[i+1],hexData[i],Length(hexData)-i);
1372	<	SetLength(hexData,Length(hexData)-1);
1373	<	end;
1374	<	else
1375	<	Inc(i);
1376	<	end;
1377	<	end;
1378	<	end;
1379	<
1380	<	procedure WriteToBlob(hexData: string);
1381	<	var i,j : integer;
1382	<	blength: integer;
1383	<	P: PChar;
1100	>	Result := LF;
1101	>	FLineIndex := 0;
1102	>	end
1103	>	else
1104	>	if FLineIndex = 0 then
1105		begin
1106	<	RemoveWhiteSpace(hexData);
1107	<	if odd(length(hexData)) then
1387	<	FSymbolStream.ShowError(sBinaryBlockMustbeEven,[nil]);
1388	<	blength := Length(hexData) div 2;
1389	<	IBAlloc(FBlobBuffer,0,blength);
1390	<	j := 1;
1391	<	P := FBlobBuffer;
1392	<	for i := 1 to blength do
1393	<	begin
1394	<	P^ := char((nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]));
1395	<	Inc(j,2);
1396	<	Inc(P);
1397	<	end;
1398	<	FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
1399	<	end;
1400	<
1401	<	begin
1402	<	if tagValue = '' then Exit;
1403	<	case FXMLTagStack[FXMLTagIndex] of
1404	<	xtBlob:
1405	<	WriteToBlob(tagValue);
1406	<
1407	<	xtElt:
1408	<	with FArrayData[FCurrentArray] do
1409	<	ArrayIntf.SetAsString(index,tagValue);
1410	<
1411	<	end;
1412	<	end;
1413	<
1414	<	procedure TIBXMLProcessor.StartXMLTag(xmltag: TXMLTag);
1415	<	begin
1416	<	if FXMLTagIndex > 19 then
1417	<	FSymbolStream.ShowError(sXMLStackOverFlow,[nil]);
1418	<	Inc(FXMLTagIndex);
1419	<	FXMLTagStack[FXMLTagIndex] := xmltag;
1420	<	case xmltag of
1421	<	xtBlob:
1422	<	begin
1423	<	Inc(FCurrentBlob);
1424	<	SetLength(FBlobData,FCurrentBlob+1);
1425	<	FBlobData[FCurrentBlob].BlobIntf := nil;
1426	<	FBlobData[FCurrentBlob].SubType := 0;
1427	<	end;
1428	<
1429	<	xtArray:
1430	<	begin
1431	<	Inc(FCurrentArray);
1432	<	SetLength(FArrayData,FCurrentArray+1);
1433	<	with FArrayData[FCurrentArray] do
1434	<	begin
1435	<	ArrayIntf := nil;
1436	<	SQLType := 0;
1437	<	dim := 0;
1438	<	Size := 0;
1439	<	Scale := 0;
1440	<	CharSet := 'NONE';
1441	<	SetLength(Index,0);
1442	<	CurrentRow := -1;
1443	<	end;
1444	<	end;
1445	<
1446	<	xtElt:
1447	<	with FArrayData[FCurrentArray] do
1448	<	Inc(CurrentRow);
1449	<
1450	<	end;
1451	<	end;
1452	<
1453	<	procedure TIBXMLProcessor.ProcessAttributeValue(attrValue: string);
1454	<	begin
1455	<	case FXMLTagStack[FXMLTagIndex] of
1456	<	xtBlob:
1457	<	if FAttributeName = 'subtype' then
1458	<	FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
1459	<	else
1460	<	FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1461	<
1462	<	xtArray:
1463	<	if FAttributeName = 'sqltype' then
1464	<	FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
1465	<	else
1466	<	if FAttributeName = 'relation_name' then
1467	<	FArrayData[FCurrentArray].relationName := attrValue
1468	<	else
1469	<	if FAttributeName = 'column_name' then
1470	<	FArrayData[FCurrentArray].columnName := attrValue
1471	<	else
1472	<	if FAttributeName = 'dim' then
1473	<	FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
1474	<	else
1475	<	if FAttributeName = 'length' then
1476	<	FArrayData[FCurrentArray].Size := StrToInt(attrValue)
1106	>	if not GetNextLine(FLine) then
1107	>	Result := #0
1108		else
1109	<	if FAttributeName = 'scale' then
1110	<	FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
1109	>	if Length(FLine) = 0 then
1110	>	Result := LF
1111		else
1481	–	if FAttributeName = 'charset' then
1482	–	FArrayData[FCurrentArray].CharSet := attrValue
1483	–	else
1484	–	if FAttributeName = 'bounds' then
1485	–	ProcessBoundsList(attrValue)
1486	–	else
1487	–	FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1488	–
1489	–	xtElt:
1490	–	if FAttributeName = 'ix' then
1491	–	with FArrayData[FCurrentArray] do
1492	–	Index[CurrentRow] :=  StrToInt(attrValue)
1493	–	else
1494	–	FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1495	–	end;
1496	–	end;
1497	–
1498	–	procedure TIBXMLProcessor.ProcessBoundsList(boundsList: string);
1499	–	var list: TStringList;
1500	–	i,j: integer;
1501	–	begin
1502	–	list := TStringList.Create;
1503	–	try
1504	–	list.Delimiter := ',';
1505	–	list.DelimitedText := boundsList;
1506	–	with FArrayData[FCurrentArray] do
1112		begin
1113	<	if dim <> list.Count then
1114	<	FSymbolStream.ShowError(sInvalidBoundsList,[boundsList]);
1115	<	SetLength(bounds,dim);
1116	<	for i := 0 to list.Count - 1 do
1117	<	begin
1118	<	j := Pos(':',list[i]);
1119	<	if j = 0 then
1120	<	raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
1516	<	bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
1517	<	bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
1518	<	end;
1519	<	end;
1520	<	finally
1521	<	list.Free;
1113	>	Result := FLine[1];
1114	>	FLineIndex := 2;
1115	>	end
1116	>	end
1117	>	else
1118	>	begin
1119	>	Result := FLine[FLineIndex];
1120	>	Inc(FLineIndex);
1121		end;
1122		end;
1123
1124	<	constructor TIBXMLProcessor.Create;
1124	>	constructor TInteractiveSQLStatementReader.Create(aPrompt: string; aContinue: string);
1125		begin
1126		inherited Create;
1127	<	NextStatement;
1128	<	end;
1129	<
1130	<	destructor TIBXMLProcessor.Destroy;
1532	<	begin
1533	<	FreeMem(FBlobBuffer);
1534	<	inherited Destroy;
1127	>	FPrompt := aPrompt;
1128	>	FLineIndex := 0;
1129	>	FNextStatement := true;
1130	>	FContinuePrompt := aContinue;
1131		end;
1132
1133	<	function TIBXMLProcessor.AnalyseXML(SymbolStream: TSymbolStream): string;
1134	<	var Symbol: TSQLSymbol;
1539	<	Done: boolean;
1540	<	XMLString: string;
1133	>	function TInteractiveSQLStatementReader.GetNextStatement(var stmt: string
1134	>	): boolean;
1135		begin
1136	<	Result := '';
1137	<	XMLString := '';
1544	<	Done := false;
1545	<	FState := stInTag;
1546	<	FSymbolStream := SymbolStream;
1547	<	with SymbolStream do
1548	<	begin
1549	<	StartXMLTag(XMLTag);
1550	<	while not Done do
1551	<	with SymbolStream do
1552	<	begin
1553	<	Symbol := GetSymbol;
1554	<
1555	<	case Symbol of
1556	<	sqEOL:
1557	<	case FState of
1558	<	stQuotedAttributeValue,
1559	<	stTagged:
1560	<	XMLString += LineEnding;
1561	<	end;
1562	<
1563	<	' ',sqTab:
1564	<	case FState of
1565	<	stQuotedAttributeValue,
1566	<	stTagged:
1567	<	XMLString += ' ';
1568	<	end;
1569	<
1570	<	';':
1571	<	case FState of
1572	<	stQuotedAttributeValue,
1573	<	stTagged:
1574	<	XMLString += ';';
1575	<	else
1576	<	ShowError(sXMLError,[Symbol]);
1577	<	end;
1578	<
1579	<	'''':
1580	<	case FState of
1581	<	stQuotedAttributeValue,
1582	<	stTagged:
1583	<	XMLString += '''';
1584	<	else
1585	<	ShowError(sXMLError,[Symbol]);
1586	<	end;
1587	<
1588	<	'*':
1589	<	case FState of
1590	<	stQuotedAttributeValue,
1591	<	stTagged:
1592	<	XMLString += '*';
1593	<	else
1594	<	ShowError(sXMLError,[Symbol]);
1595	<	end;
1596	<
1597	<	'/':
1598	<	case FState of
1599	<	stQuotedAttributeValue,
1600	<	stTagged:
1601	<	XMLString += '/';
1602	<	else
1603	<	ShowError(sXMLError,[Symbol]);
1604	<	end;
1605	<
1606	<	'>':
1607	<	case FState of
1608	<	stEndTag:
1609	<	case XMLTag of
1610	<	xtBlob:
1611	<	begin
1612	<	Result := ':' + Format(ibx_blob+'%d',[FCurrentBlob]);
1613	<	Done := true;
1614	<	end;
1615	<	xtArray:
1616	<	begin
1617	<	Result := ':' + Format(ibx_array+'%d',[FCurrentArray]);
1618	<	Done := true;
1619	<	end;
1620	<	else
1621	<	FState := stTagged;
1622	<	end;
1623	<
1624	<	stInTag:
1625	<	begin
1626	<	XMLString := '';
1627	<	FState := stTagged;
1628	<	EnterTag;
1629	<	end;
1630	<
1631	<	stQuotedAttributeValue,
1632	<	stTagged:
1633	<	XMLString += '>';
1634	<
1635	<	else
1636	<	ShowError(sXMLError,[Symbol]);
1637	<	end;
1638	<
1639	<	sqTag:
1640	<	if FState = stTagged then
1641	<	begin
1642	<	FState := stInTag;
1643	<	StartXMLTag(XMLTag)
1644	<	end
1645	<	else
1646	<	ShowError(sXMLError,[Symbol]);
1647	<
1648	<	sqEndTag:
1649	<	if FState = stTagged then
1650	<	begin
1651	<	ProcessTagValue(XMLString);
1652	<	EndXMLTag(XMLTag);
1653	<	FState := stEndTag;
1654	<	end
1655	<	else
1656	<	ShowError(sXMLError,[Symbol]);
1657	<
1658	<	'=':
1659	<	case FState of
1660	<	stAttribute:
1661	<	FState := stAttributeValue;
1662	<
1663	<	stQuotedAttributeValue,
1664	<	stTagged:
1665	<	XMLString += '=';
1666	<
1667	<	else
1668	<	ShowError(sXMLError,[Symbol]);
1669	<	end;
1670	<
1671	<	'"':
1672	<	case FState of
1673	<	stAttributeValue:
1674	<	begin
1675	<	XMLString := '';
1676	<	FState := stQuotedAttributeValue;
1677	<	end;
1678	<
1679	<	stQuotedAttributeValue:
1680	<	begin
1681	<	ProcessAttributeValue(XMLString);
1682	<	FState := stInTag;
1683	<	end;
1684	<
1685	<	stTagged:
1686	<	XMLString += '"';
1687	<
1688	<	else
1689	<	ShowError(sXMLError,[Symbol]);
1690	<	end;
1691	<
1692	<	sqString:
1693	<	case FState of
1694	<	stInTag: {attribute name}
1695	<	begin
1696	<	FAttributeName := SymbolValue;
1697	<	FState := stAttribute;
1698	<	end;
1699	<
1700	<	stAttributeValue:
1701	<	begin
1702	<	ProcessAttributeValue(FString);
1703	<	FState := stInTag;
1704	<	end;
1705	<
1706	<	stQuotedAttributeValue,
1707	<	stTagged:
1708	<	XMLString += SymbolValue;
1709	<
1710	<	else
1711	<	ShowError(sXMLError,[Symbol]);
1712	<	end;
1713	<	else
1714	<	ShowError(sXMLError,[Symbol]);
1715	<	end
1716	<	end;
1717	<	end;
1136	>	Result := inherited GetNextStatement(stmt);
1137	>	FNextStatement := Result;
1138		end;
1139
1140	<	procedure TIBXMLProcessor.NextStatement;
1721	<	begin
1722	<	FXMLTagIndex := 0;
1723	<	SetLength(FBlobData,0);
1724	<	FCurrentBlob := -1;
1725	<	SetLength(FArrayData,0);
1726	<	FCurrentArray := -1;
1727	<	end;
1140	>	{ TBatchSQLStatementReader }
1141
1142	<	class function TIBXMLProcessor.FormatBlob(Field: ISQLData): string;
1730	<	var TextOut: TStrings;
1142	>	function TBatchSQLStatementReader.GetChar: AnsiChar;
1143		begin
1144	<	TextOut := TStringList.Create;
1145	<	try
1146	<	TextOut.Add(Format('<blob subtype="%d">',[Field.getSubtype]));
1147	<	StringToHex(Field.AsString,TextOut,BlobLineLength);
1736	<	TextOut.Add('</blob>');
1737	<	Result := TextOut.Text;
1738	<	finally
1739	<	TextOut.Free;
1740	<	end;
1741	<	end;
1742	<
1743	<	class function TIBXMLProcessor.FormatArray(Database: TIBDatabase; ar: IArray
1744	<	): string;
1745	<	var index: array of integer;
1746	<	TextOut: TStrings;
1747	<
1748	<	procedure AddElements(dim: integer; indent:string = ' ');
1749	<	var i: integer;
1750	<	recurse: boolean;
1144	>	if not EOF and assigned(FInStream) and not (FInStream.Position = FInStream.Size) then
1145	>	begin
1146	>	Result := char(FInStream.ReadByte);
1147	>	if Result = LF then
1148		begin
1149	<	SetLength(index,dim+1);
1150	<	recurse := dim < ar.GetDimensions - 1;
1151	<	with ar.GetBounds[dim] do
1152	<	for i := LowerBound to UpperBound do
1153	<	begin
1154	<	index[dim] := i;
1155	<	if recurse then
1156	<	begin
1157	<	TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
1761	<	AddElements(dim+1,indent + ' ');
1762	<	TextOut.Add('</elt>');
1763	<	end
1764	<	else
1765	<	if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
1766	<	(ar.GetCharSetID = 1) then
1767	<	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
1768	<	else
1769	<	TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
1770	<	end;
1771	<	end;
1772	<
1773	<	var
1774	<	s: string;
1775	<	bounds: TArrayBounds;
1776	<	i: integer;
1777	<	boundsList: string;
1778	<	begin
1779	<	TextOut := TStringList.Create;
1780	<	try
1781	<	s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1782	<	[ar.GetDimensions,ar.GetSQLType,ar.GetSize,
1783	<	ar.GetTableName,ar.GetColumnName]);
1784	<	case ar.GetSQLType of
1785	<	SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
1786	<	s += Format(' scale = "%d"',[ ar.GetScale]);
1787	<	SQL_TEXT,
1788	<	SQL_VARYING:
1789	<	s += Format(' charset = "%s"',[Database.Attachment.GetCharsetName(ar.GetCharSetID)]);
1790	<	end;
1791	<	bounds := ar.GetBounds;
1792	<	boundsList := '';
1793	<	for i := 0 to length(bounds) - 1 do
1149	>	EchoNextLine(FCurLine);
1150	>	FCurLine := '';
1151	>	if assigned(OnProgressEvent) then
1152	>	OnProgressEvent(self,false,FIndex+1);
1153	>	Inc(FLineIndex);
1154	>	FIndex := 1;
1155	>	end
1156	>	else
1157	>	if Result <> CR then
1158		begin
1159	<	if i <> 0 then boundsList += ',';
1160	<	boundsList += Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
1159	>	FCurLine += Result;
1160	>	Inc(FIndex);
1161		end;
1162	<	s += Format(' bounds="%s"',[boundsList]);
1799	<	s += '>';
1800	<	TextOut.Add(s);
1801	<
1802	<	SetLength(index,0);
1803	<	AddElements(0);
1804	<	TextOut.Add('</array>');
1805	<	Result := TextOut.Text;
1806	<	finally
1807	<	TextOut.Free;
1808	<	end;
1809	<	end;
1810	<
1811	<	{ TInteractiveSymbolStream }
1812	<
1813	<	function TInteractiveSymbolStream.GetErrorPrefix: string;
1814	<	begin
1815	<	Result := '';
1816	<	end;
1817	<
1818	<	function TInteractiveSymbolStream.GetNextLine(var Line: string): boolean;
1819	<	begin
1820	<	if FNextStatement then
1821	<	write(FPrompt)
1822	<	else
1823	<	write(FContinuePrompt);
1824	<	Result := not EOF;
1825	<	if Result then
1826	<	readln(Line);
1827	<	end;
1828	<
1829	<	constructor TInteractiveSymbolStream.Create(aPrompt: string; aContinue: string);
1830	<	begin
1831	<	inherited Create;
1832	<	FPrompt := aPrompt;
1833	<	FContinuePrompt := aContinue;
1834	<	end;
1835	<
1836	<	function TInteractiveSymbolStream.GetSymbol: TSQLSymbol;
1837	<	begin
1838	<	if Terminated then
1839	<	Result := sqEOF
1162	>	end
1163		else
1164	<	Result := inherited GetSymbol;
1164	>	Result := #0;
1165		end;
1166
1167	<	{ TBatchSymbolStream }
1845	<
1846	<	function TBatchSymbolStream.GetErrorPrefix: string;
1167	>	function TBatchSQLStatementReader.GetErrorPrefix: AnsiString;
1168		begin
1169		Result := Format(sOnLineError,[FLineIndex,FIndex]);
1170		end;
1171
1172	<	function TBatchSymbolStream.GetNextLine(var Line: string): boolean;
1852	<	begin
1853	<	Result := FLineIndex < FLines.Count;
1854	<	if Result then
1855	<	begin
1856	<	Line := FLines[FLineIndex];
1857	<	//    writeln('Next Line = ',Line);
1858	<	Inc(FLineIndex);
1859	<	if assigned(OnProgressEvent) then
1860	<	OnProgressEvent(self,false,1);
1861	<	end;
1862	<	end;
1863	<
1864	<	constructor TBatchSymbolStream.Create;
1865	<	begin
1866	<	inherited Create;
1867	<	FLines := TStringList.Create;
1868	<	end;
1869	<
1870	<	destructor TBatchSymbolStream.Destroy;
1871	<	begin
1872	<	if assigned(FLines) then FLines.Free;
1873	<	inherited Destroy;
1874	<	end;
1875	<
1876	<	procedure TBatchSymbolStream.SetStreamSource(Lines: TStrings);
1172	>	procedure TBatchSQLStatementReader.Reset;
1173		begin
1174	<	FLineIndex := 0;
1175	<	FLines.Assign(Lines);
1174	>	inherited Reset;
1175	>	if FOwnsInStream and assigned(FInStream) then
1176	>	FInStream.Free;
1177	>	FInStream := nil;
1178	>	FOwnsInStream := false;
1179	>	FLineIndex := 1;
1180	>	FIndex := 1;
1181	>	FCurLine := '';
1182	>	end;
1183	>
1184	>	procedure TBatchSQLStatementReader.SetStreamSource(Lines: TStrings);
1185	>	begin
1186	>	Reset;
1187	>	FInStream := TMemoryStream.Create;
1188	>	FOwnsInStream := true;
1189	>	Lines.SaveToStream(FInStream);
1190	>	FInStream.Position := 0;
1191		if assigned(OnProgressEvent) then
1192	<	OnProgressEvent(self,true,FLines.Count);
1192	>	OnProgressEvent(self,true,FInStream.Size);
1193		end;
1194
1195	<	procedure TBatchSymbolStream.SetStreamSource(S: TStream);
1195	>	procedure TBatchSQLStatementReader.SetStreamSource(S: TStream);
1196		begin
1197	<	FLineIndex := 0;
1198	<	FLines.LoadFromStream(S);
1197	>	Reset;
1198	>	FInStream := S;
1199		if assigned(OnProgressEvent) then
1200	<	OnProgressEvent(self,true,FLines.Count);
1200	>	OnProgressEvent(self,true,S.Size - S.Position);
1201		end;
1202
1203	<	procedure TBatchSymbolStream.SetStreamSource(FileName: string);
1203	>	procedure TBatchSQLStatementReader.SetStreamSource(FileName: string);
1204		begin
1205	<	FLineIndex := 0;
1206	<	FLines.LoadFromFile(FileName);
1205	>	Reset;
1206	>	FInStream := TFileStream.Create(FileName,fmShareCompat);
1207	>	FOwnsInStream := true;
1208		if assigned(OnProgressEvent) then
1209	<	OnProgressEvent(self,true,FLines.Count);
1898	<	end;
1899	<
1900	<	{ TSymbolStream }
1901	<
1902	<	function TSymbolStream.GetNextSymbol(C: char): TSQLSymbol;
1903	<	begin
1904	<	Result := sqNone;
1905	<	if C = FTerminator then
1906	<	Result := sqTerminator
1907	<	else
1908	<	case C of
1909	<	#0..#8,#10..#31,' ':
1910	<	Result := ' ';
1911	<
1912	<	#9,';','"','''','/','-',
1913	<	'*','=','>','<',',':
1914	<	Result := C;
1915	<	else
1916	<	begin
1917	<	Result := sqString;
1918	<	FLastChar := C
1919	<	end
1920	<	end;
1921	<	end;
1922	<
1923	<	function TSymbolStream.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
1924	<	var i: integer;
1925	<	begin
1926	<	Result := false;
1927	<	for i := 0 to Length(XMLTagDefs) - 1 do
1928	<	if XMLTagDefs[i].TagValue = tag then
1929	<	begin
1930	<	xmlTag := XMLTagDefs[i].XMLTag;
1931	<	Result := true;
1932	<	break;
1933	<	end;
1934	<	end;
1935	<
1936	<	constructor TSymbolStream.Create;
1937	<	begin
1938	<	inherited;
1939	<	FTerminator := DefaultTerminator;
1940	<	NextStatement;
1209	>	OnProgressEvent(self,true,FInStream.Size);
1210		end;
1211
1212	<	procedure TSymbolStream.ShowError(msg: string; params: array of const);
1212	>	procedure TBatchSQLStatementReader.SetStringStreamSource(S: string);
1213		begin
1214	<	raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
1215	<	end;
1216	<
1217	<	function TSymbolStream.GetSymbol: TSQLSymbol;
1218	<	var
1950	<	DelimitedText: string;
1951	<	CurState: (gsNone,gsInComment,gsInSingleQuotes,gsInDoubleQuotes);
1952	<	begin
1953	<	Result := sqNone;
1954	<	CurState := gsNone;
1955	<	DelimitedText := '';
1956	<	if FNextSymbol <> sqNone then
1957	<	begin
1958	<	Result := FNextSymbol;
1959	<	if Result = sqString then
1960	<	FString := FLastChar
1961	<	else
1962	<	FString := '';
1963	<	FNextSymbol := sqNone
1964	<	end;
1965	<
1966	<	while FNextSymbol = sqNone do {find the next symbol}
1967	<	begin
1968	<	if FIndex > Length(FLine) then
1969	<	begin
1970	<	FNextSymbol := sqEOL;
1971	<	FIndex := 0;
1972	<	end
1973	<	else
1974	<	begin
1975	<	if FIndex = 0 then
1976	<	begin
1977	<	if not GetNextLine(FLine) then
1978	<	begin
1979	<	Result := sqEOF;
1980	<	FNextSymbol := sqNone;
1981	<	Exit;
1982	<	end;
1983	<	FIndex := 1;
1984	<	FNextStatement := false;
1985	<	if assigned(OnNextLine) then
1986	<	OnNextLine(self,FLine);
1987	<	if CurState <> gsNone then
1988	<	DelimitedText += LineEnding;
1989	<	if Length(FLine) = 0 then
1990	<	continue;
1991	<	end;
1992	<	if CurState <> gsNone then
1993	<	DelimitedText += FLine[FIndex];
1994	<	FNextSymbol := GetNextSymbol(FLine[FIndex]);
1995	<	Inc(FIndex);
1996	<	end;
1997	<
1998	<	case CurState of
1999	<	gsNone:
2000	<	begin
2001	<	{combine if possible}
2002	<	case Result of
2003	<	sqNone:
2004	<	begin
2005	<	Result := FNextSymbol;
2006	<	if FNextSymbol = sqString then
2007	<	FString := FLastChar;
2008	<	FNextSymbol := sqNone
2009	<	end;
2010	<
2011	<	'/':
2012	<	if FXMLMode > 0 then
2013	<	break
2014	<	else
2015	<	if FNextSymbol = '*' then
2016	<	begin
2017	<	CurState := gsInComment;
2018	<	DelimitedText := '/*';
2019	<	Result := sqNone;
2020	<	FNextSymbol := sqNone
2021	<	end
2022	<	else
2023	<	if FNextSymbol = '/' then
2024	<	begin
2025	<	FString := '/*' + system.copy(FLine,FIndex,length(FLine)- FIndex + 1) + ' */';
2026	<	Result := sqCommentLine;
2027	<	FIndex := 0;
2028	<	FNextSymbol := sqNone
2029	<	end;
2030	<
2031	<	'-':
2032	<	if FXMLMode > 0 then
2033	<	break
2034	<	else
2035	<	if FNextSymbol = '-' then
2036	<	begin
2037	<	FString := '--' + system.copy(FLine,FIndex,length(FLine)- FIndex + 1) ;
2038	<	Result := sqCommentLine;
2039	<	FIndex := 0;
2040	<	FNextSymbol := sqNone
2041	<	end;
2042	<
2043	<	'<':
2044	<	if (FXMLMode > 0) and (FNextSymbol = '/') then
2045	<	begin
2046	<	Result := sqEndTag;
2047	<	FString := '';
2048	<	FNextSymbol := sqNone
2049	<	end
2050	<	else
2051	<	if FNextSymbol = sqString then
2052	<	begin
2053	<	Result := sqTag;
2054	<	FString := FLastChar;
2055	<	FNextSymbol := sqNone
2056	<	end;
2057	<
2058	<	'''':
2059	<	if FXMLMode > 0 then
2060	<	break
2061	<	else
2062	<	if FNextSymbol = '''' then
2063	<	begin
2064	<	Result := sqQuotedString;
2065	<	FString := '''''';
2066	<	FNextSymbol := sqNone
2067	<	end
2068	<	else
2069	<	begin
2070	<	CurState := gsInSingleQuotes;
2071	<	DelimitedText := '''';
2072	<	if FNextSymbol = sqEOL then
2073	<	DelimitedText += LineEnding
2074	<	else
2075	<	DelimitedText += FLine[FIndex-1];
2076	<	Result := sqNone;
2077	<	FNextSymbol := sqNone
2078	<	end;
2079	<
2080	<	'"':
2081	<	if FXMLMode > 0 then
2082	<	break
2083	<	else
2084	<	begin
2085	<	CurState := gsInDoubleQuotes;
2086	<	DelimitedText := '"';
2087	<	if FNextSymbol = sqEOL then
2088	<	DelimitedText += LineEnding
2089	<	else
2090	<	DelimitedText += FLine[FIndex-1];
2091	<	Result := sqNone;
2092	<	FNextSymbol := sqNone
2093	<	end;
2094	<
2095	<	sqTag,
2096	<	sqEndTag,
2097	<	sqString:
2098	<	if FNextSymbol = sqString then
2099	<	begin
2100	<	FString := FString + FLastChar;
2101	<	FNextSymbol := sqNone
2102	<	end;
2103	<	end
2104	<	end;
2105	<
2106	<	{Check for state exit condition}
2107	<	gsInSingleQuotes:
2108	<	if Result = '''' then
2109	<	begin
2110	<	CurState := gsNone;
2111	<	if FNextSymbol = sqEOL then
2112	<	FString := DelimitedText
2113	<	else
2114	<	FString := system.copy(DelimitedText,1,Length(DelimitedText)-1);
2115	<	Result := sqQuotedString;
2116	<	end;
2117	<
2118	<	gsInDoubleQuotes:
2119	<	if Result = '"' then
2120	<	begin
2121	<	CurState := gsNone;
2122	<	if FNextSymbol = sqEOL then
2123	<	FString := DelimitedText
2124	<	else
2125	<	FString := system.copy(DelimitedText,1,Length(DelimitedText)-1);
2126	<	Result := sqDoubleQuotedString;
2127	<	end;
2128	<
2129	<	gsInComment:
2130	<	if (Result = '*') and (FNextSymbol = '/') then
2131	<	begin
2132	<	CurState := gsNone;
2133	<	FString := DelimitedText;
2134	<	Result := sqComment;
2135	<	FNextSymbol := sqNone
2136	<	end;
2137	<
2138	<	end;
2139	<
2140	<	if (CurState <> gsNone) and (FNextSymbol <> sqNone) then
2141	<	begin
2142	<	Result := FNextSymbol;
2143	<	FNextSymbol := sqNone;
2144	<	end;
2145	<	end;
2146	<
2147	<	if (Result = sqTag) and (FNextSymbol <> sqNone) then
2148	<	begin
2149	<	if FindTag(FString,FXMLTag) then
2150	<	Inc(FXMLMode)
2151	<	else
2152	<	Result := sqString;
2153	<	end
2154	<	else
2155	<	if (Result = sqEndTag) and (FNextSymbol <> sqNone) then
2156	<	begin
2157	<	if FindTag(FString,FXMLTag) then
2158	<	Dec(FXMLMode)
2159	<	else
2160	<	Result := sqString;
2161	<	end;
2162	<
2163	<	if (FXMLMode = 0) and (Result = sqString) and (FString <> '') then
2164	<	begin
2165	<	if CompareText(FString,'begin') = 0 then
2166	<	Result := sqBegin
2167	<	else
2168	<	if CompareText(FString,'end') = 0 then
2169	<	Result := sqEnd
2170	<	else
2171	<	if CompareText(FString,'declare') = 0 then
2172	<	Result := sqDeclare
2173	<	else
2174	<	if CompareText(FString,'case') = 0 then
2175	<	Result := sqCase
2176	<	end;
2177	<	//  writeln(Result,',',FString);
2178	<	end;
2179	<
2180	<	procedure TSymbolStream.NextStatement;
2181	<	begin
2182	<	FXMLTag := xtNone;
2183	<	FNextStatement := true;
1214	>	Reset;
1215	>	FInStream := TStringStream.Create(S);
1216	>	FOwnsInStream := true;
1217	>	if assigned(OnProgressEvent) then
1218	>	OnProgressEvent(self,true,FInStream.Size);
1219		end;
1220
1221		end.

Comparing ibx/trunk/runtime/nongui/ibxscript.pas (property svn:eol-style):
Revision 228 by tony, Mon Apr 9 13:38:16 2018 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