ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/design/IBSQLEditFrame.pas
Revision: 158
Committed: Thu Mar 1 11:23:33 2018 UTC (6 years, 9 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/design/IBSQLEditFrame.pas
File size: 42964 byte(s)
Log Message: 
Repository resync

File Contents

# User Rev Content
1 tony 158 (*
2     * IBX For Lazarus (Firebird Express)
3     *
4     * The contents of this file are subject to the Initial Developer's
5     * Public License Version 1.0 (the "License"); you may not use this
6     * file except in compliance with the License. You may obtain a copy
7     * of the License here:
8     *
9     * http://www.firebirdsql.org/index.php?op=doc&id=idpl
10     *
11     * Software distributed under the License is distributed on an "AS
12     * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13     * implied. See the License for the specific language governing rights
14     * and limitations under the License.
15     *
16     * The Initial Developer of the Original Code is Tony Whyman.
17     *
18     * The Original Code is (C) 2011-17 Tony Whyman, MWA Software
19     * (http://www.mwasoftware.co.uk).
20     *
21     * All Rights Reserved.
22     *
23     * Contributor(s): ______________________________________.
24     *
25     *)
26     unit IBSQLEditFrame;
27    
28     {$mode objfpc}{$H+}
29    
30     interface
31    
32     uses
33     Classes, SysUtils, FileUtil, SynEdit, SynHighlighterSQL, LResources, Forms,
34     Controls, ActnList, Menus, Dialogs, ComCtrls, ExtCtrls, StdCtrls, IBQuery,
35     IBSQL, IBDatabase, IBUpdate, IBDatabaseInfo, IBLookupComboEditBox,
36     IBCustomDataset, db, LazSynTextArea, IB;
37    
38     type
39    
40     { TIBSQLEditFrame }
41    
42     TIBSQLEditFrame = class(TFrame)
43     PackageNameSource: TDataSource;
44     PackageNames: TIBQuery;
45     ReadOnlyFieldsSource: TDataSource;
46     IBUpdate6: TIBUpdate;
47     ReadOnlyFields: TIBQuery;
48     IBUpdate5: TIBUpdate;
49     IdentityColsSource: TDataSource;
50     FieldNameList: TIBQuery;
51     FieldsSource: TDataSource;
52     DatabaseInfo: TIBDatabaseInfo;
53     IdentityCols: TIBQuery;
54     IBUpdate1: TIBUpdate;
55     IBUpdate2: TIBUpdate;
56     IBUpdate3: TIBUpdate;
57     IBUpdate4: TIBUpdate;
58     SQLTransaction: TIBTransaction;
59     IdentifyStatementSQL: TIBSQL;
60     PrimaryKeys: TIBQuery;
61     PrimaryKeySource: TDataSource;
62     ProcInputParams: TIBQuery;
63     ProcInputSource: TDataSource;
64     ProcOutputParams: TIBQuery;
65     ProcOutputSource: TDataSource;
66     Redo: TAction;
67     ToolButton10: TToolButton;
68     ToolButton11: TToolButton;
69     Undo: TAction;
70     SaveToFile: TAction;
71     LoadFromFile: TAction;
72     BtnImages: TImageList;
73     MenuItem8: TMenuItem;
74     MenuItem9: TMenuItem;
75     OpenDialog1: TOpenDialog;
76     SaveDialog1: TSaveDialog;
77     ToolBar1: TToolBar;
78     ToolButton1: TToolButton;
79     ToolButton2: TToolButton;
80     ToolButton3: TToolButton;
81     ToolButton4: TToolButton;
82     ToolButton5: TToolButton;
83     ToolButton6: TToolButton;
84     ToolButton7: TToolButton;
85     ToolButton8: TToolButton;
86     ToolButton9: TToolButton;
87     UserProcedures: TIBQuery;
88     UserProcSource: TDataSource;
89     UserTables: TIBQuery;
90     UserTableSource: TDataSource;
91     WrapText: TAction;
92     Clear: TAction;
93     MenuItem1: TMenuItem;
94     MenuItem2: TMenuItem;
95     MenuItem3: TMenuItem;
96     MenuItem4: TMenuItem;
97     MenuItem5: TMenuItem;
98     MenuItem6: TMenuItem;
99     MenuItem7: TMenuItem;
100     PopupMenu1: TPopupMenu;
101     SelectAll: TAction;
102     Paste: TAction;
103     CopyText: TAction;
104     Cut: TAction;
105     ActionList1: TActionList;
106     SQLText: TSynEdit;
107     SynSQLSyn1: TSynSQLSyn;
108     procedure ClearExecute(Sender: TObject);
109     procedure CopyTextExecute(Sender: TObject);
110     procedure CutExecute(Sender: TObject);
111     procedure CutUpdate(Sender: TObject);
112     procedure FieldNameListBeforeOpen(DataSet: TDataSet);
113     procedure IBUpdate1ApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
114     Params: ISQLParams);
115     procedure LoadFromFileExecute(Sender: TObject);
116     procedure PackageNamesAfterScroll(DataSet: TDataSet);
117     procedure PackageNamesBeforeClose(DataSet: TDataSet);
118     procedure PasteExecute(Sender: TObject);
119     procedure PasteUpdate(Sender: TObject);
120     procedure RedoExecute(Sender: TObject);
121     procedure RedoUpdate(Sender: TObject);
122     procedure SaveToFileExecute(Sender: TObject);
123     procedure SelectAllExecute(Sender: TObject);
124     procedure SelectAllUpdate(Sender: TObject);
125     procedure UndoExecute(Sender: TObject);
126     procedure UndoUpdate(Sender: TObject);
127     procedure UserProceduresAfterOpen(DataSet: TDataSet);
128     procedure UserProceduresBeforeClose(DataSet: TDataSet);
129     procedure UserProceduresBeforeOpen(DataSet: TDataSet);
130     procedure UserTablesAfterOpen(DataSet: TDataSet);
131     procedure UserTablesBeforeClose(DataSet: TDataSet);
132     procedure UserTablesBeforeOpen(DataSet: TDataSet);
133     procedure WrapTextExecute(Sender: TObject);
134     procedure WrapTextUpdate(Sender: TObject);
135     private
136     FDatabase: TIBDatabase;
137     FExcludeIdentityColumns: boolean;
138     FExecuteOnlyProcs: boolean;
139     FIncludeReadOnlyFields: boolean;
140     FIncludeSystemTables: boolean;
141     FOnUserTablesOpened: TNotifyEvent;
142     FOpening: boolean;
143     FSelectProcs: boolean;
144     FQuerySync: boolean;
145     procedure AddWhereClause(QuotedStrings: boolean; SQL: TStrings;
146     UseOldValues: boolean);
147     function GetSQLType(SQLType: TIBSQLStatementTypes): string;
148     procedure GetFieldNames(Dataset: TDataset; var FieldNames: TStrings;
149     aIncludeReadOnly: boolean = true);
150     procedure GenerateSelectSQL(TableName: string; QuotedStrings: boolean; FieldNames,PrimaryKeyNames, SQL: TStrings); overload;
151     procedure GenerateInsertSQL(TableName: string; QuotedStrings: boolean;
152     FieldNames, ReadOnlyFieldNames, SQL: TStrings); overload;
153     procedure GenerateModifySQL(TableName: string; QuotedStrings: boolean;
154     FieldNames, ReadOnlyFieldNames, SQL: TStrings); overload;
155     procedure GenerateExecuteSQL(PackageName, ProcName: string;
156     QuotedStrings: boolean; ExecuteOnly: boolean; InputParams, OutputParams,
157     ExecuteSQL: TStrings); overload;
158     procedure GenerateDeleteSQL(TableName: string; QuotedStrings: boolean; ReadOnlyFieldNames, SQL: TStrings); overload;
159     procedure SetDatabase(AValue: TIBDatabase);
160     procedure SetExcludeIdentityColumns(AValue: boolean);
161     procedure SetExecuteOnlyProcs(AValue: boolean);
162     procedure SetIncludeReadOnlyFields(AValue: boolean);
163     procedure SetIncludeSystemTables(AValue: boolean);
164     procedure SetSelectProcs(AValue: boolean);
165    
166     public
167     constructor Create(aOwner: TComponent); override;
168     procedure DoWrapText(Lines: TStrings); overload;
169     procedure DoWrapText; overload;
170     procedure UnWrapText;
171     procedure RefreshAll;
172     procedure SelectAllFields(Checked: boolean);
173     procedure GenerateSelectSQL(QuotedStrings: boolean; AddReadOnlyFields: boolean = false); overload;
174     procedure GenerateSelectSQL(QuotedStrings: boolean; SQL: TStrings; AddReadOnlyFields: boolean = false); overload;
175     procedure GenerateRefreshSQL(QuotedStrings: boolean);
176     procedure GenerateRefreshSQL(QuotedStrings: boolean; SQL: TStrings; AddReadOnlyFields: boolean = false);
177     procedure GenerateExecuteSQL(QuotedStrings: boolean); overload;
178     procedure GenerateInsertSQL(QuotedStrings: boolean); overload;
179     procedure GenerateInsertSQL(QuotedStrings: boolean; SQL: TStrings); overload;
180     procedure GenerateModifySQL(QuotedStrings: boolean; aIncludePrimaryKeys: boolean); overload;
181     procedure GenerateModifySQL(QuotedStrings: boolean; SQL: TStrings; aIncludePrimaryKeys: boolean); overload;
182     procedure GenerateDeleteSQL(QuotedStrings: boolean); overload;
183     procedure GenerateDeleteSQL(QuotedStrings: boolean; SQL: TStrings); overload;
184     function GetStatementType(var IsStoredProcedure: boolean): TIBSQLStatementTypes;
185     procedure InsertSelectedPrimaryKey;
186     procedure InsertSelectedFieldName;
187     procedure InsertTableName;
188     procedure InsertProcName;
189     procedure InsertPackageName;
190     procedure InsertSelectedInputParam;
191     procedure InsertSelectedOutputParam;
192     procedure InsertSelectedIdentityCol;
193     procedure InsertSelectedReadOnlyField;
194     procedure OpenUserProcedures;
195     function SyncQueryBuilder: TIBSQLStatementTypes; overload;
196     function SyncQueryBuilder(SQL: TStrings): TIBSQLStatementTypes; overload;
197     procedure TestSQL(GenerateParamNames: boolean);
198     property Database: TIBDatabase read FDatabase write SetDatabase;
199     property IncludeReadOnlyFields: boolean read FIncludeReadOnlyFields write SetIncludeReadOnlyFields;
200     property IncludeSystemTables: boolean read FIncludeSystemTables write SetIncludeSystemTables;
201     property ExcludeIdentityColumns: boolean read FExcludeIdentityColumns write SetExcludeIdentityColumns;
202     property ExecuteOnlyProcs: boolean read FExecuteOnlyProcs write SetExecuteOnlyProcs;
203     property SelectProcs: boolean read FSelectProcs write SetSelectProcs;
204     property OnUserTablesOpened: TNotifyEvent read FOnUserTablesOpened write FOnUserTablesOpened;
205     end;
206    
207     implementation
208    
209     Uses IBUtils, FBMessages, Variants;
210    
211     {$R *.lfm}
212    
213     const
214     sNoPrimaryKeys = 'RF.RDB$FIELD_NAME not in ' +
215     '(Select RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS S JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME '+
216     'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and C.RDB$RELATION_NAME = RF.RDB$RELATION_NAME)';
217    
218     { TIBSQLEditFrame }
219    
220     procedure TIBSQLEditFrame.CutUpdate(Sender: TObject);
221     begin
222     (Sender as TAction).Enabled := SQLText.SelText <> '';
223     end;
224    
225     procedure TIBSQLEditFrame.FieldNameListBeforeOpen(DataSet: TDataSet);
226     begin
227     if not IncludeReadOnlyFields then
228     (DataSet as TIBQuery).Parser.Add2WhereClause('B.RDB$COMPUTED_SOURCE is NULL');
229     (DataSet as TIBQuery).Parser.Add2WhereClause(sNoPrimaryKeys);
230     if ExcludeIdentityColumns and (DatabaseInfo.ODSMajorVersion >= 12) then
231     (DataSet as TIBQuery).Parser.Add2WhereClause('RF.RDB$IDENTITY_TYPE is NULL');
232     end;
233    
234     procedure TIBSQLEditFrame.IBUpdate1ApplyUpdates(Sender: TObject;
235     UpdateKind: TUpdateKind; Params: ISQLParams);
236     begin
237     //do nothing - dummy to allow edits without database update
238     end;
239    
240     procedure TIBSQLEditFrame.LoadFromFileExecute(Sender: TObject);
241     begin
242     if OpenDialog1.Execute then
243     SQLText.Lines.LoadFromFile(OpenDialog1.FileName);
244     end;
245    
246     procedure TIBSQLEditFrame.PackageNamesAfterScroll(DataSet: TDataSet);
247     begin
248     UserProcedures.Active := false;
249     UserProcedures.Active := true;
250     end;
251    
252     procedure TIBSQLEditFrame.PackageNamesBeforeClose(DataSet: TDataSet);
253     begin
254     UserProcedures.Active := false;
255     end;
256    
257     procedure TIBSQLEditFrame.PasteExecute(Sender: TObject);
258     begin
259     SQLText.PasteFromClipboard;
260     end;
261    
262     procedure TIBSQLEditFrame.PasteUpdate(Sender: TObject);
263     begin
264     (Sender as TAction).Enabled := SQLText.CanPaste;
265     end;
266    
267     procedure TIBSQLEditFrame.RedoExecute(Sender: TObject);
268     begin
269     SQLText.Redo;
270     end;
271    
272     procedure TIBSQLEditFrame.RedoUpdate(Sender: TObject);
273     begin
274     (Sender as TAction).Enabled := SQLText.CanRedo;
275     end;
276    
277     procedure TIBSQLEditFrame.SaveToFileExecute(Sender: TObject);
278     begin
279     if SaveDialog1.Execute then
280     SQLText.Lines.SaveToFile(SaveDialog1.FileName);
281     end;
282    
283     procedure TIBSQLEditFrame.SelectAllExecute(Sender: TObject);
284     begin
285     SQLText.SelectAll;
286     end;
287    
288     procedure TIBSQLEditFrame.SelectAllUpdate(Sender: TObject);
289     begin
290     (Sender as TAction).Enabled := SQLText.Lines.Count > 0;
291     end;
292    
293     procedure TIBSQLEditFrame.UndoExecute(Sender: TObject);
294     begin
295     SQLText.Undo;
296     end;
297    
298     procedure TIBSQLEditFrame.UndoUpdate(Sender: TObject);
299     begin
300     (Sender as TAction).Enabled := SQLText.CanUndo;
301     end;
302    
303     procedure TIBSQLEditFrame.UserProceduresAfterOpen(DataSet: TDataSet);
304     begin
305     ProcInputParams.Active := true;
306     ProcOutputParams.Active := true;
307     end;
308    
309     procedure TIBSQLEditFrame.UserProceduresBeforeClose(DataSet: TDataSet);
310     begin
311     ProcInputParams.Active := false;
312     ProcOutputParams.Active := false;
313     end;
314    
315     procedure TIBSQLEditFrame.UserProceduresBeforeOpen(DataSet: TDataSet);
316     begin
317     if not (ExecuteOnlyProcs and SelectProcs) then
318     begin
319     if ExecuteOnlyProcs then
320     (DataSet as TIBQuery).Parser.Add2WhereClause('RDB$PROCEDURE_TYPE = 2');
321     if SelectProcs then
322     (DataSet as TIBQuery).Parser.Add2WhereClause('RDB$PROCEDURE_TYPE = 1 AND RDB$PROCEDURE_OUTPUTS > 0');
323     end;
324     if PackageNames.Active then
325     begin
326     if PackageNames.FieldByName('PACKAGE_NAME_TYPE').AsInteger = 0 then {global procedures}
327     (DataSet as TIBQuery).Parser.Add2WhereClause('RDB$PACKAGE_NAME is NULL')
328     else
329     (DataSet as TIBQuery).Parser.Add2WhereClause('RDB$PACKAGE_NAME = ''' +
330     PackageNames.FieldByName('RDB$PACKAGE_NAME').AsString + '''');
331     end;
332     // writeln((DataSet as TIBQuery).Parser.SQLText);
333     end;
334    
335     procedure TIBSQLEditFrame.UserTablesAfterOpen(DataSet: TDataSet);
336     begin
337     FieldNameList.Active := true;
338     PrimaryKeys.Active := true;
339     IdentityCols.Active := DatabaseInfo.ODSMajorVersion >= 12;
340     ReadOnlyFields.Active := true;
341     FOpening := true;
342     try
343     if assigned(FOnUserTablesOpened) then
344     OnUserTablesOpened(self);
345     finally
346     FOpening := false;
347     end;
348     end;
349    
350     procedure TIBSQLEditFrame.UserTablesBeforeClose(DataSet: TDataSet);
351     begin
352     FieldNameList.Active := false;
353     PrimaryKeys.Active := false;
354     IdentityCols.Active := false;
355     ReadOnlyFields.Active := false;
356     end;
357    
358     procedure TIBSQLEditFrame.UserTablesBeforeOpen(DataSet: TDataSet);
359     begin
360     if not IncludeSystemTables then
361     (DataSet as TIBQuery).Parser.Add2WhereClause('RDB$SYSTEM_FLAG = 0');
362     end;
363    
364     procedure TIBSQLEditFrame.WrapTextExecute(Sender: TObject);
365     begin
366     UnWrapText;
367     DoWrapText;
368     end;
369    
370     procedure TIBSQLEditFrame.WrapTextUpdate(Sender: TObject);
371     begin
372     (Sender as TAction).Enabled := SQLText.Lines.Count > 0;
373     end;
374    
375     procedure TIBSQLEditFrame.SetDatabase(AValue: TIBDatabase);
376     var i: integer;
377     begin
378     if FDatabase = AValue then Exit;
379     FDatabase := AValue;
380     FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
381     SQLTransaction.Active := false;
382     SQLTransaction.DefaultDatabase := FDatabase;
383     for i := 0 to ComponentCount - 1 do
384     if Components[i] is TIBCustomDataset then
385     TIBCustomDataset(Components[i]).Database := FDatabase
386     else
387     if Components[i] is TIBSQL then
388     TIBSQL(Components[i]).Database := FDatabase
389     else
390     if Components[i] is TIBDatabaseInfo then
391     TIBDatabaseInfo(Components[i]).Database := FDatabase;
392     if (FDatabase <> nil) and FDatabase.Connected then
393     SQLTransaction.Active := true;
394     end;
395    
396     procedure TIBSQLEditFrame.SetExcludeIdentityColumns(AValue: boolean);
397     begin
398     if FExcludeIdentityColumns = AValue then Exit;
399     FExcludeIdentityColumns := AValue;
400     RefreshAll;
401     end;
402    
403     procedure TIBSQLEditFrame.SetExecuteOnlyProcs(AValue: boolean);
404     begin
405     if FExecuteOnlyProcs = AValue then Exit;
406     FExecuteOnlyProcs := AValue;
407     RefreshAll;
408     end;
409    
410     procedure TIBSQLEditFrame.SetIncludeReadOnlyFields(AValue: boolean);
411     begin
412     if FIncludeReadOnlyFields = AValue then Exit;
413     FIncludeReadOnlyFields := AValue;
414     RefreshAll;
415     end;
416    
417     procedure TIBSQLEditFrame.SetIncludeSystemTables(AValue: boolean);
418     begin
419     if FIncludeSystemTables = AValue then Exit;
420     FIncludeSystemTables := AValue;
421     RefreshAll;
422     SyncQueryBuilder;
423     end;
424    
425     procedure TIBSQLEditFrame.SetSelectProcs(AValue: boolean);
426     begin
427     if FSelectProcs = AValue then Exit;
428     FSelectProcs := AValue;
429     RefreshAll;
430     end;
431    
432     constructor TIBSQLEditFrame.Create(aOwner: TComponent);
433     begin
434     inherited Create(aOwner);
435     FIncludeReadOnlyFields := true;
436     end;
437    
438     procedure TIBSQLEditFrame.DoWrapText;
439     begin
440     DoWrapText(SQLText.Lines);
441     if assigned(SQLText.OnChange) then
442     SQLText.OnChange(self);
443     end;
444    
445     type
446     THackedSynEdit = class(TSynEdit)
447     public
448     property TextArea: TLazSynTextArea read FTextArea;
449     end;
450    
451     procedure TIBSQLEditFrame.DoWrapText(Lines: TStrings);
452    
453     var NewLines: TStringList;
454     i: integer;
455     MaxWidth: integer;
456     MaxChars: integer;
457     Line: string;
458     Tokeniser: TSynSQLSyn;
459     SplitAt: integer;
460     SQLParam: boolean;
461     begin
462     NewLines := TStringList.Create;
463     Tokeniser := TSynSQLSyn.Create(nil); {use the highligher as a tokeniser}
464     try
465     Tokeniser.SQLDialect := sqlInterbase6;
466     SQlText.Canvas.Font := SQLText.Font;
467     with THackedSynEdit(SQLText).TextArea do
468     MaxWidth := Right - Left;
469     for i := 0 to Lines.Count - 1 do
470     begin
471     Line := Lines[i];
472     repeat
473     if (Length(Line) = 0) or (SQlText.Canvas.TextWidth(Line) <= MaxWidth) then
474     begin
475     NewLines.Add(Line);
476     break; {next line}
477     end
478     else
479     begin
480     {Need to split the line at the last complete SQL token}
481     MaxChars := SQlText.Canvas.TextFitInfo(Line,MaxWidth);
482     SQLParam := false;
483     Tokeniser.ResetRange;
484     Tokeniser.SetLine(Line,i);
485     SplitAt := 0;
486     while (Tokeniser.GetTokenPos < MaxChars) and not Tokeniser.GetEol do
487     begin
488     if not SQLParam then
489     SplitAt := Tokeniser.GetTokenPos; {combine param indicator with param}
490     SQLParam := Tokeniser.GetToken = ':';
491     Tokeniser.Next;
492     end;
493    
494     if SplitAt <= 0 then {token overflows line}
495     begin
496     NewLines.Add(Line);
497     break; {next line}
498     end;
499     NewLines.Add(system.copy(Line,1,SplitAt));
500     system.Delete(Line,1,SplitAt);
501     end;
502     until Length(Line) = 0;
503     end;
504     Lines.Assign(NewLines);
505     finally
506     NewLines.Free;
507     Tokeniser.Free;
508     end;
509     end;
510    
511     const
512     Separators = [' ',#$09,',','.',':'];
513    
514     procedure TIBSQLEditFrame.UnWrapText;
515     var Line: string;
516     i: integer;
517     begin
518     Line := '';
519     with SQLText do
520     begin
521     for i := 0 to Lines.Count - 1 do
522     begin
523     if (Length(Line) > 0) and not (Line[Length(Line)] in Separators) then
524     Line := Line + ' ';
525     Line := Line + Lines[i];
526     end;
527    
528     if assigned(OnChange) then
529     OnChange(self);
530     Lines.Text := Line;
531     end;
532     end;
533    
534     procedure TIBSQLEditFrame.RefreshAll;
535     begin
536     if UserTables.Active then
537     begin
538     UserTables.Active := false;
539     UserTables.Active := true;
540     end;
541     if PackageNames.Active then
542     begin
543     PackageNames.Active := false;
544     OpenUserProcedures;
545     end
546     else
547     if UserProcedures.Active then
548     begin
549     UserProcedures.Active := false;
550     OpenUserProcedures;
551     end;
552     end;
553    
554     procedure TIBSQLEditFrame.SelectAllFields(Checked: boolean);
555    
556     procedure DoSelectAllFields(Dataset: TDataset; aValue: boolean);
557     begin
558     with Dataset do
559     if Active then
560     begin
561     DisableControls;
562     try
563     First;
564     while not Eof do
565     begin
566     Edit;
567     FieldByName('Selected').AsInteger := ord(aValue);
568     Post;
569     Next;
570     end;
571     First;
572     finally
573     EnableControls;
574     end;
575     end;
576     end;
577    
578     begin
579     if FOpening or (Database = nil) or not Database.Connected then Exit;
580     DoSelectAllFields(FieldNameList,Checked);
581     DoSelectAllFields(PrimaryKeys,Checked);
582     DoSelectAllFields(IdentityCols,Checked);
583     DoSelectAllFields(ReadOnlyFields,Checked);
584     end;
585    
586     procedure TIBSQLEditFrame.GenerateSelectSQL(QuotedStrings: boolean;
587     AddReadOnlyFields: boolean);
588     begin
589     GenerateSelectSQL(QuotedStrings,SQLText.Lines,AddReadOnlyFields);
590     end;
591    
592     procedure TIBSQLEditFrame.GenerateRefreshSQL(QuotedStrings: boolean);
593     begin
594     GenerateRefreshSQL(QuotedStrings,SQLText.Lines);
595     end;
596    
597     procedure TIBSQLEditFrame.GenerateSelectSQL(QuotedStrings: boolean;
598     SQL: TStrings; AddReadOnlyFields: boolean);
599     var FieldNames: TStrings;
600     PrimaryKeyNames: TStrings;
601     ReadOnlyFieldNames: TStrings;
602     begin
603     SQL.Clear;
604     FieldNames := TStringList.Create;
605     PrimaryKeyNames := TStringList.Create;
606     ReadOnlyFieldNames := TStringList.Create;
607     try
608     GetFieldNames(PrimaryKeys,PrimaryKeyNames);
609     GetFieldNames(FieldNameList,FieldNames);
610     if not IncludeReadOnlyFields and AddReadOnlyFields then
611     begin
612     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
613     FieldNames.AddStrings(ReadOnlyFieldNames);
614     end;
615     GenerateSelectSQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,QuotedStrings,FieldNames,PrimaryKeyNames,SQL);
616     finally
617     FieldNames.Free;
618     PrimaryKeyNames.Free;
619     ReadOnlyFieldNames.Free;
620     end;
621     DoWrapText(SQL);
622     end;
623    
624     procedure TIBSQLEditFrame.GenerateRefreshSQL(QuotedStrings: boolean;
625     SQL: TStrings; AddReadOnlyFields: boolean);
626     begin
627     SQL.Clear;
628     GenerateSelectSQL(QuotedStrings,SQL,AddReadOnlyFields);
629     AddWhereClause(QuotedStrings,SQL,false);
630     end;
631    
632     procedure TIBSQLEditFrame.GenerateExecuteSQL(QuotedStrings: boolean);
633     var InputParams: TStrings;
634     OutputParams: TStrings;
635     PackageName: string;
636     begin
637     SQLText.Lines.Clear;
638    
639     InputParams := TStringList.Create;
640     OutputParams := TStringList.Create;
641     try
642     if PackageNames.Active and (PackageNames.FieldByName('Package_Name_Type').AsInteger = 1) then
643     PackageName := PackageNames.FieldByName('RDB$PACKAGE_NAME').AsString
644     else
645     PackageName := '';
646     GetFieldNames(ProcInputParams,InputParams);
647     GetFieldNames(ProcOutputParams,OutputParams);
648     GenerateExecuteSQL(PackageName,UserProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString,
649     QuotedStrings, UserProcedures.FieldByName('RDB$PROCEDURE_TYPE').AsInteger = 2,
650     InputParams,OutputParams,SQLText.Lines);
651     finally
652     InputParams.Free;
653     OutputParams.Free;
654     end;
655     end;
656    
657     procedure TIBSQLEditFrame.GenerateInsertSQL(QuotedStrings: boolean);
658     begin
659     GenerateInsertSQL(QuotedStrings,SQLText.Lines);
660     end;
661    
662     procedure TIBSQLEditFrame.GenerateModifySQL(QuotedStrings: boolean;
663     aIncludePrimaryKeys: boolean);
664     begin
665     GenerateModifySQL(QuotedStrings,SQLText.Lines,aIncludePrimaryKeys);
666     end;
667    
668     procedure TIBSQLEditFrame.GenerateDeleteSQL(QuotedStrings: boolean);
669     begin
670     GenerateDeleteSQL(QuotedStrings,SQLText.Lines);
671     end;
672    
673     procedure TIBSQLEditFrame.GenerateInsertSQL(QuotedStrings: boolean; SQL: TStrings);
674     var FieldNames: TStrings;
675     ReadOnlyFieldNames: TStrings;
676     InsertFields: TStrings;
677     I: integer;
678     begin
679     SQL.Clear;
680     FieldNames := TStringList.Create;
681     ReadOnlyFieldNames := TStringList.Create;
682     InsertFields := TStringList.Create;
683     try
684     GetFieldNames(PrimaryKeys,InsertFields);
685     for I := InsertFields.Count - 1 downto 0 do
686     if IdentityCols.Active and IdentityCols.Locate('ColumnName;Selected',VarArrayOf([InsertFields[I],1]),[loCaseInsensitive]) then
687     InsertFields.Delete(I);
688     GetFieldNames(FieldNameList,FieldNames,false);
689     InsertFields.AddStrings(FieldNames);
690     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
691     GenerateInsertSQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,QuotedStrings,InsertFields,ReadOnlyFieldNames,SQL);
692     finally
693     FieldNames.Free;
694     ReadOnlyFieldNames.Free;
695     InsertFields.Free;
696     end;
697     DoWrapText(SQL);
698     end;
699    
700     procedure TIBSQLEditFrame.GenerateModifySQL(QuotedStrings: boolean;
701     SQL: TStrings; aIncludePrimaryKeys: boolean);
702     var FieldNames: TStrings;
703     ReadOnlyFieldNames: TStrings;
704     UpdateFields: TStrings;
705     i, index: integer;
706     begin
707     SQL.Clear;
708     FieldNames := TStringList.Create;
709     ReadOnlyFieldNames := TStringList.Create;
710     UpdateFields := TStringList.Create;
711     try
712     if aIncludePrimaryKeys then
713     GetFieldNames(PrimaryKeys,UpdateFields);
714     GetFieldNames(FieldNameList,FieldNames,false);
715     UpdateFields.AddStrings(FieldNames);
716     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
717     GenerateModifySQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,
718     QuotedStrings,UpdateFields,ReadOnlyFieldNames,SQL);
719     finally
720     FieldNames.Free;
721     ReadOnlyFieldNames.Free;
722     UpdateFields.Free;
723     end;
724     end;
725    
726     procedure TIBSQLEditFrame.GenerateDeleteSQL(QuotedStrings: boolean;
727     SQL: TStrings);
728     var ReadOnlyFieldNames: TStrings;
729     begin
730     SQL.Clear;
731     ReadOnlyFieldNames := TStringList.Create;
732     try
733     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
734     GenerateDeleteSQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,QuotedStrings,ReadOnlyFieldNames,SQL)
735     finally
736     ReadOnlyFieldNames.Free;
737     end;
738     end;
739    
740     procedure TIBSQLEditFrame.CutExecute(Sender: TObject);
741     begin
742     SQLText.CutToClipboard;
743     end;
744    
745     procedure TIBSQLEditFrame.CopyTextExecute(Sender: TObject);
746     begin
747     SQLText.CopyToClipboard;
748     end;
749    
750     procedure TIBSQLEditFrame.ClearExecute(Sender: TObject);
751     begin
752     SQLText.Lines.Clear;
753     end;
754    
755     procedure TIBSQLEditFrame.AddWhereClause(
756     QuotedStrings: boolean; SQL: TStrings; UseOldValues: boolean);
757     var WhereClause: string;
758     Separator: string;
759     Count: integer;
760     Prefix: string;
761     ColumnName: string;
762     begin
763     Count := 0;
764     WhereClause := 'Where';
765     Separator := ' A.';
766     if UseOldValues then
767     Prefix := ':OLD_'
768     else
769     Prefix := ':';
770     with PrimaryKeys do
771     begin
772     DisableControls;
773     try
774     if State = dsEdit then Post;
775     First;
776     while not EOF do
777     begin
778     if FieldByName('Selected').AsInteger <> 0 then
779     begin
780     Inc(Count);
781     ColumnName := FieldByName('ColumnName').AsString;
782     if QuotedStrings then
783     WhereClause := WhereClause + Separator + '"' + ColumnName +
784     '" = ' + Prefix+ AnsiUpperCase(ColumnName)
785     else
786     WhereClause := WhereClause + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ColumnName) +
787     ' = ' + Prefix + AnsiUpperCase(ColumnName);
788     Separator := ' AND A.';
789     end;
790     Next;
791     end;
792     finally
793     EnableControls
794     end;
795     end;
796     if Count > 0 then
797     SQL.Add(WhereClause);
798     end;
799    
800     function TIBSQLEditFrame.GetSQLType(SQLType: TIBSQLStatementTypes): string;
801     begin
802     case SQLType of
803     SQLUnknown: Result := 'Unknown';
804     SQLSelect: Result := 'Select';
805     SQLInsert: Result := 'Insert';
806     SQLUpdate: Result := 'Update';
807     SQLDelete: Result := 'Delete';
808     SQLDDL: Result := 'DDL';
809     SQLGetSegment: Result := 'GetSegment';
810     SQLPutSegment: Result := 'PutSegment';
811     SQLExecProcedure: Result := 'Execute Procedure';
812     SQLStartTransaction: Result := 'StartTransaction';
813     SQLCommit: Result := 'Commit';
814     SQLRollback: Result := 'Rollback';
815     SQLSelectForUpdate: Result := 'Select for Update';
816     SQLSetGenerator: Result := 'Set Generator';
817     end;
818     end;
819    
820     procedure TIBSQLEditFrame.GetFieldNames(Dataset: TDataset;
821     var FieldNames: TStrings; aIncludeReadOnly: boolean);
822     begin
823     with DataSet do
824     begin
825     DisableControls;
826     try
827     if State = dsEdit then Post;
828     First;
829     while not EOF do
830     begin
831     if (FieldByName('Selected').AsInteger <> 0) and (aIncludeReadOnly or (FieldByName('ReadOnly').AsInteger = 0)) then
832     FieldNames.Add(FieldByName('ColumnName').AsString);
833     Next;
834     end;
835     finally
836     EnableControls
837     end;
838     end;
839     end;
840    
841     procedure TIBSQLEditFrame.GenerateSelectSQL(TableName: string;
842     QuotedStrings: boolean; FieldNames, PrimaryKeyNames, SQL: TStrings);
843     var SelectSQL: string;
844     Separator : string;
845     I: integer;
846     Lines: TStrings;
847     begin
848     SelectSQL := 'Select';
849     Separator := ' A.';
850     for I := 0 to PrimaryKeyNames.Count - 1 do
851     begin
852     if QuotedStrings then
853     SelectSQL := SelectSQL + Separator + '"' + PrimaryKeyNames[I] + '"'
854     else
855     SelectSQL := SelectSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,PrimaryKeyNames[I]);
856     Separator := ', A.';
857     end;
858     for I := 0 to FieldNames.Count - 1 do
859     begin
860     if QuotedStrings then
861     SelectSQL := SelectSQL + Separator + '"' + FieldNames[I] + '"'
862     else
863     SelectSQL := SelectSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]);
864     Separator := ', A.';
865     end;
866     if QuotedStrings then
867     SelectSQL := SelectSQL + ' From "' + TableName + '" A'
868     else
869     SelectSQL := SelectSQL + ' From ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A';
870     Lines := TStringList.Create;
871     try
872     Lines.Text := SelectSQL;
873     SQL.AddStrings(Lines);
874     finally
875     Lines.Free;
876     end;
877     end;
878    
879     procedure TIBSQLEditFrame.GenerateInsertSQL(TableName: string;
880     QuotedStrings: boolean; FieldNames, ReadOnlyFieldNames, SQL: TStrings);
881     var InsertSQL: string;
882     Separator: string;
883     Lines: TStrings;
884     I: integer;
885     begin
886     Lines := TStringList.Create;
887     try
888     if QuotedStrings then
889     InsertSQL := 'Insert Into "' + TableName + '" ('
890     else
891     InsertSQL := 'Insert Into ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' (';
892     Separator := '';
893     for I := 0 to FieldNames.Count - 1 do
894     begin
895     if QuotedStrings then
896     InsertSQL := InsertSQL + Separator + '"' + FieldNames[I] + '"'
897     else
898     InsertSQL := InsertSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]) ;
899     Separator := ', ';
900     end;
901     InsertSQL := InsertSQL + ')';
902     Lines.Add(InsertSQL);
903     InsertSQL := 'Values(';
904     Separator := ':';
905     for I := 0 to FieldNames.Count - 1 do
906     begin
907     InsertSQL := InsertSQL + Separator + AnsiUpperCase(FieldNames[I]) ;
908     Separator := ', :';
909     end;
910     InsertSQL := InsertSQL + ')';
911     Lines.Add(InsertSQL);
912    
913     {Is database Firebird 2.1 or later?}
914     if (DatabaseInfo.ODSMajorVersion > 11) or
915     ((DatabaseInfo.ODSMajorVersion = 11) and (DatabaseInfo.ODSMinorVersion >= 1)) then
916     begin
917     InsertSQL := '';
918     Separator := ' RETURNING ';
919     if IdentityCols.Active and (IdentityCols.RecordCount > 0) then
920     begin
921     IdentityCols.First;
922     while not IdentityCols.Eof do
923     begin
924     if (IdentityCols.FieldByName('Selected').AsInteger <> 0) and
925     (not PrimaryKeys.Active or not PrimaryKeys.Locate('columnName;Selected',
926     VarArrayOf([IdentityCols.FieldByName('ColumnName').AsString,0]),[loCaseInsensitive])) then
927     begin
928     InsertSQL := InsertSQL + Separator + IdentityCols.FieldByName('ColumnName').AsString;
929     Separator := ', ';
930     end;
931     IdentityCols.Next;
932     end;
933     end;
934     for I := 0 to ReadOnlyFieldNames.Count - 1 do
935     begin
936     if QuotedStrings then
937     InsertSQL := InsertSQL + Separator + '"' + ReadOnlyFieldNames[I] + '"'
938     else
939     InsertSQL := InsertSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
940     Separator := ', ';
941     end;
942     Lines.Add(InsertSQL);
943     end;
944     SQL.AddStrings(Lines);
945     finally
946     Lines.Free;
947     end;
948     end;
949    
950     procedure TIBSQLEditFrame.GenerateModifySQL(TableName: string;
951     QuotedStrings: boolean; FieldNames, ReadOnlyFieldNames, SQL: TStrings);
952     var UpdateSQL: string;
953     Separator: string;
954     I: integer;
955     begin
956     Separator := ' A.';
957     if QuotedStrings then
958     UpdateSQL := 'Update "' + TableName + '" A Set '
959     else
960     UpdateSQL := 'Update ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A Set ';
961     SQL.Add(UpdateSQL);
962     for I := 0 to FieldNames.Count - 1 do
963     begin
964     if QuotedStrings then
965     UpdateSQL := Separator + '"' + FieldNames[I] + '" = :' + AnsiUpperCase(FieldNames[I])
966     else
967     UpdateSQL := Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]) + ' = :' + AnsiUpperCase(FieldNames[I]);
968     if I < FieldNames.Count - 1 then
969     UpdateSQL := UpdateSQL + ',';
970     SQL.Add(UpdateSQL);
971     end;
972     AddWhereClause(QuotedStrings,SQL,true);
973    
974     {Is database Firebird 2.1 or later?}
975     if (DatabaseInfo.ODSMajorVersion > 11) or
976     ((DatabaseInfo.ODSMajorVersion = 11) and (DatabaseInfo.ODSMinorVersion >= 1)) then
977     begin
978     Separator := ' RETURNING A.';
979     UpdateSQL := '';
980     for I := 0 to ReadOnlyFieldNames.Count - 1 do
981     begin
982     if QuotedStrings then
983     UpdateSQL := UpdateSQL + Separator + '"' + ReadOnlyFieldNames[I] + '"'
984     else
985     UpdateSQL := UpdateSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
986     Separator := ', A.';
987     end;
988     SQL.Add(UpdateSQL);
989     end;
990     end;
991    
992     procedure TIBSQLEditFrame.GenerateDeleteSQL(TableName: string;
993     QuotedStrings: boolean; ReadOnlyFieldNames, SQL: TStrings);
994     {var ReturningText, Separator: string;
995     I: integer; }
996     begin
997     if QuotedStrings then
998     SQL.Add('Delete From "' + TableName + '" A')
999     else
1000     SQL.Add('Delete From ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A');
1001     AddWhereClause(QuotedStrings,SQL,true);
1002     { Separator := ' RETURNING A.';
1003     ReturningText := '';
1004     for I := 0 to ReadOnlyFieldNames.Count - 1 do
1005     begin
1006     if QuotedStrings then
1007     ReturningText := ReturningText + Separator + '"' + ReadOnlyFieldNames[I] + '"'
1008     else
1009     ReturningText := ReturningText + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
1010     Separator := ', A.';
1011     end;
1012     SQL.Add(ReturningText);}
1013     end;
1014    
1015     const
1016     sqlCheckProcedureNames = 'Select * From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
1017    
1018     function TIBSQLEditFrame.GetStatementType(var IsStoredProcedure: boolean
1019     ): TIBSQLStatementTypes;
1020     var TableName: string;
1021     begin
1022     Result := sqlUnknown;
1023     if not assigned(Database) or not Database.Connected or (Trim(SQLText.Lines.Text) = '') then
1024     Exit;
1025     IsStoredProcedure := false;
1026     with TIBSQL.Create(nil) do
1027     try
1028     Database := self.Database;
1029     Transaction := SQLTransaction;
1030     SQL.Assign(SQLText.Lines);
1031     GenerateParamNames := true; {permissive}
1032     try
1033     Prepare;
1034     Result := SQLStatementType
1035     except on E:EIBError do
1036     // ShowMessage(E.Message);
1037     end;
1038     if (Result = SQLSelect) and (MetaData.Count > 0) then
1039     begin
1040     TableName := MetaData[0].GetRelationName;
1041     SQL.Text := sqlCheckProcedureNames;
1042     Prepare;
1043     ParamByName('ProcName').AsString := TableName;
1044     ExecQuery;
1045     try
1046     IsStoredProcedure := not EOF;
1047     finally
1048     Close
1049     end;
1050     end;
1051     finally
1052     Free
1053     end;
1054     end;
1055    
1056     procedure TIBSQLEditFrame.GenerateExecuteSQL(PackageName,ProcName: string;
1057     QuotedStrings: boolean; ExecuteOnly: boolean; InputParams, OutputParams,
1058     ExecuteSQL: TStrings);
1059    
1060     function GetProcName: string;
1061     begin
1062     if QuotedStrings then
1063     begin
1064     if PackageName = '' then
1065     Result := QuoteIdentifier(Database.SQLDialect,ProcName)
1066     else
1067     Result := QuoteIdentifier(Database.SQLDialect,PackageName) + '.' +
1068     QuoteIdentifier(Database.SQLDialect,ProcName);
1069     end
1070     else
1071     if PackageName = '' then
1072     Result := QuoteIdentifierIfNeeded(Database.SQLDialect,ProcName)
1073     else
1074     Result := QuoteIdentifierIfNeeded(Database.SQLDialect,PackageName) + '.' +
1075     QuoteIdentifierIfNeeded(Database.SQLDialect,ProcName);
1076     end;
1077    
1078     var SQL: string;
1079     I: integer;
1080     Separator: string;
1081     Lines: TStrings;
1082     begin
1083     Lines := TStringList.Create;
1084     try
1085     Separator := '';
1086     if not ExecuteOnly and (OutputParams.Count > 0) then //Select Query
1087     begin
1088     SQL := 'Select ';
1089     for I := 0 to OutputParams.Count - 1 do
1090     begin
1091     if QuotedStrings then
1092     SQL := SQL + Separator + '"' + OutputParams[I] + '"'
1093     else
1094     SQL := SQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,OutputParams[I]);
1095     Separator := ', ';
1096     end;
1097     SQL := SQL + ' From ' + GetProcName;
1098     if InputParams.Count > 0 then
1099     begin
1100     Separator := '(:';
1101     for I := 0 to InputParams.Count - 1 do
1102     begin
1103     SQL := SQL + Separator + AnsiUpperCase(InputParams[I]);
1104     Separator := ', :';
1105     end;
1106     SQL := SQL + ')'
1107     end
1108     end
1109     else // Execute Procedure
1110     begin
1111     SQL := 'Execute Procedure ' + GetProcName;
1112     if InputParams.Count > 0 then
1113     begin
1114     Separator := ' :';
1115     for I := 0 to InputParams.Count - 1 do
1116     begin
1117     SQL := SQL + Separator + AnsiUpperCase(InputParams[I]);
1118     Separator := ', :';
1119     end;
1120     end
1121     end;
1122     Lines.Add(SQL + ';');
1123     ExecuteSQL.AddStrings(Lines);
1124     finally
1125     Lines.Free
1126     end
1127     end;
1128    
1129     procedure TIBSQLEditFrame.InsertSelectedPrimaryKey;
1130     begin
1131     SQLText.SelText := PrimaryKeys.FieldByName('ColumnName').AsString;
1132     SQLText.SetFocus
1133     end;
1134    
1135     procedure TIBSQLEditFrame.InsertSelectedFieldName;
1136     begin
1137     SQLText.SelText := FieldNameList.FieldByName('ColumnName').AsString;
1138     SQLText.SetFocus
1139     end;
1140    
1141     procedure TIBSQLEditFrame.InsertTableName;
1142     begin
1143     SQLText.SelText := UserTables.FieldByName('RDB$RELATION_NAME').AsString;
1144     SQLText.SetFocus
1145     end;
1146    
1147     procedure TIBSQLEditFrame.InsertProcName;
1148     begin
1149     SQLText.SelText := UserProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString;
1150     SQLText.SetFocus
1151     end;
1152    
1153     procedure TIBSQLEditFrame.InsertPackageName;
1154     begin
1155     if PackageNames.Active and (PackageNames.FieldByName('PACKAGE_NAME_TYPE').AsInteger = 1) then
1156     begin
1157     SQLText.SelText := PackageNames.FieldByName('RDB$PACKAGE_NAME').AsString;
1158     SQLText.SetFocus
1159     end;
1160     end;
1161    
1162     procedure TIBSQLEditFrame.InsertSelectedInputParam;
1163     begin
1164     SQLText.SelText := ProcInputParams.FieldByName('ColumnName').AsString;
1165     SQLText.SetFocus
1166     end;
1167    
1168     procedure TIBSQLEditFrame.InsertSelectedOutputParam;
1169     begin
1170     SQLText.SelText := ProcOutputParams.FieldByName('ColumnName').AsString;
1171     SQLText.SetFocus
1172     end;
1173    
1174     procedure TIBSQLEditFrame.InsertSelectedIdentityCol;
1175     begin
1176     SQLText.SelText := IdentityCols.FieldByName('ColumnName').AsString;
1177     SQLText.SetFocus
1178     end;
1179    
1180     procedure TIBSQLEditFrame.InsertSelectedReadOnlyField;
1181     begin
1182     SQLText.SelText := ReadOnlyFields.FieldByName('ColumnName').AsString;
1183     SQLText.SetFocus
1184     end;
1185    
1186     procedure TIBSQLEditFrame.OpenUserProcedures;
1187     begin
1188     if DatabaseInfo.ODSMajorVersion < 12 then
1189     UserProcedures.Active := true
1190     else
1191     PackageNames.Active := true;
1192     end;
1193    
1194     procedure GetSymbols(Lines: TStrings; var WordList: TStrings; MaxSymbols: integer = 3);
1195     var Tokeniser: TSynSQLSyn;
1196     i: integer;
1197     Token: string;
1198     begin
1199     Tokeniser := TSynSQLSyn.Create(nil); {use the highligher as a tokeniser}
1200     try
1201     Tokeniser.SQLDialect := sqlInterbase6;
1202     for i := 0 to Lines.Count - 1 do
1203     begin
1204     Tokeniser.SetLine(Lines[i],i);
1205     repeat
1206     if not (Tokeniser.GetTokenID in [tkComment,tkSpace,tkUnknown]) then
1207     begin
1208     Dec(MaxSymbols);
1209     Token := Tokeniser.GetToken;
1210     if (Length(Token) > 1) and (Token[1] = '"') and (Token[Length(Token)] = '"') then
1211     WordList.AddObject(system.copy(Token,2,Length(Token)-2),WordList) {note convention to indicate quoted}
1212     else
1213     WordList.Add(AnsiUpperCase(Token));
1214     // writeln(WordList[WordList.Count-1]);
1215     end;
1216     if MaxSymbols = 0 then
1217     Exit;
1218     Tokeniser.Next;
1219     until Tokeniser.GetEol;
1220     end;
1221     finally
1222     Tokeniser.Free;
1223     end;
1224     end;
1225    
1226     function TIBSQLEditFrame.SyncQueryBuilder: TIBSQLStatementTypes;
1227     begin
1228     Result := SyncQueryBuilder(SQLText.Lines);
1229     end;
1230    
1231     function TIBSQLEditFrame.SyncQueryBuilder(SQL: TStrings): TIBSQLStatementTypes;
1232     var TableName: string;
1233     FirstWord: string;
1234     Symbols: TStrings;
1235     i: integer;
1236    
1237     function FindProcedure(StartIndex: integer): boolean;
1238     begin
1239     if StartIndex >= Symbols.Count then Exit;
1240    
1241     if DatabaseInfo.ODSMajorVersion < 12 then {No packages}
1242     begin
1243     UserProcedures.Active := true;
1244     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex],[]);
1245     end
1246     else
1247     begin
1248     PackageNames.Active := true;
1249     if (StartIndex < Symbols.Count - 2) and (Symbols[StartIndex+1] = '.') and
1250     PackageNames.Locate('RDB$PACKAGE_NAME',Symbols[StartIndex],[]) then
1251     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex+2],[])
1252     else
1253     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex],[]);
1254     end;
1255     end;
1256    
1257     begin
1258     if (Database = nil) or not Database.Connected or FQuerySync then Exit;
1259    
1260     FQuerySync := true;
1261     Result := SQLUnknown;
1262     TableName := '';
1263     Symbols := TStringList.Create;
1264     try
1265     try
1266     IdentifyStatementSQL.Transaction.Active := true;
1267     IdentifyStatementSQL.SQL.Assign(SQL);
1268     IdentifyStatementSQL.Prepare;
1269     Result := IdentifyStatementSQL.SQLStatementType;
1270     case Result of
1271     SQLSelect:
1272     begin
1273     if IdentifyStatementSQL.MetaData.Count > 0 then
1274     TableName := IdentifyStatementSQL.MetaData[0].GetRelationName
1275     else
1276     Exit;
1277     if (Pos('MON$',TableName) > 0) or (Pos('RDB$',TableName) > 0) or (Pos('SEC$',TableName) > 0) then
1278     IncludeSystemTables := true;
1279    
1280     if not UserTables.Locate('RDB$RELATION_NAME',TableName,[]) then
1281     begin
1282     {We don't know if the stored procedure is in a package because
1283     the relationname is always the procedure name regardless of
1284     whether it is a non-package procedure or in a package. Hence,
1285     we have to look for the From keyword to find the full procedure name}
1286     GetSymbols(IdentifyStatementSQL.SQL,Symbols,-1); {Get All Symbols}
1287     for i := 0 to Symbols.Count - 1 do
1288     begin
1289     if (Symbols[i] = 'FROM') and (Symbols.Objects[i] = nil) then
1290     begin
1291     if FindProcedure(i+1) then
1292     Result := SQLExecProcedure;
1293     Exit;
1294     end;
1295     end;
1296     {Should have found it - try relationname in hope rather than expectation}
1297     UserProcedures.Active := true;
1298     if UserProcedures.Locate('RDB$PROCEDURE_NAME',TableName,[]) then
1299     Result := SQLExecProcedure;
1300     end;
1301     end;
1302     { If not a select statement then return table or procedure name
1303     as First Table Name }
1304     SQLUpdate:
1305     begin
1306     GetSymbols(IdentifyStatementSQL.SQL,Symbols,2);
1307     UserTables.Locate('RDB$RELATION_NAME',Symbols[1],[]);
1308     end;
1309    
1310     SQLInsert:
1311     begin
1312     GetSymbols(IdentifyStatementSQL.SQL,Symbols,3);
1313     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1314     end;
1315    
1316     SQLDelete:
1317     begin
1318     GetSymbols(IdentifyStatementSQL.SQL,Symbols,3);
1319     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1320     end;
1321    
1322     SQLExecProcedure:
1323     begin
1324     GetSymbols(IdentifyStatementSQL.SQL,Symbols,5);
1325     FirstWord := Symbols[0];
1326     if FirstWord = 'INSERT' then {INSERT...RETURNING}
1327     begin
1328     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1329     Result := SQLInsert;
1330     end
1331     else
1332     if FirstWord = 'UPDATE' then {UPDATE...RETURNING}
1333     begin
1334     UserTables.Locate('RDB$RELATION_NAME',Symbols[1],[]);
1335     Result := SQLUpdate;
1336     end
1337     else
1338     if FirstWord = 'DELETE' then {DELETE...RETURNING}
1339     begin
1340     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1341     Result := SQLDelete;
1342     end
1343     else
1344     FindProcedure(2);
1345     end;
1346     end
1347     except on E:EIBError do
1348     // ShowMessage(E.Message);
1349     end;
1350     finally
1351     Symbols.Free;
1352     FQuerySync := false;
1353     end;
1354     end;
1355    
1356     procedure TIBSQLEditFrame.TestSQL(GenerateParamNames: boolean);
1357     begin
1358     if not assigned(Database) or not Database.Connected then
1359     begin
1360     Messagedlg('No Database Connected',mtError,[mbOK],0);
1361     Exit;
1362     end;
1363     with TIBSQL.Create(nil) do
1364     try
1365     Database := self.Database;
1366     Transaction := SQLTransaction;
1367     GenerateParamNames := GenerateParamNames;
1368     SQL.Assign(SQLText.Lines);
1369     try
1370     Prepare;
1371     ShowMessage('SQL '+ GetSQLType(SQLStatementType) + ' Statement Looks OK');
1372     except on E:EIBError do
1373     ShowMessage(E.Message);
1374     end;
1375     finally
1376     Free
1377     end;
1378     end;
1379    
1380    
1381     end.
1382