ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/design/IBSQLEditFrame.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 42964 byte(s)
Log Message: 
Fixes Merged

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 tony 209 IBSQL, IBDatabase, IBUpdate, IBDatabaseInfo,
36 tony 158 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     begin
706     SQL.Clear;
707     FieldNames := TStringList.Create;
708     ReadOnlyFieldNames := TStringList.Create;
709     UpdateFields := TStringList.Create;
710     try
711     if aIncludePrimaryKeys then
712     GetFieldNames(PrimaryKeys,UpdateFields);
713     GetFieldNames(FieldNameList,FieldNames,false);
714     UpdateFields.AddStrings(FieldNames);
715     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
716     GenerateModifySQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,
717     QuotedStrings,UpdateFields,ReadOnlyFieldNames,SQL);
718     finally
719     FieldNames.Free;
720     ReadOnlyFieldNames.Free;
721     UpdateFields.Free;
722     end;
723     end;
724    
725     procedure TIBSQLEditFrame.GenerateDeleteSQL(QuotedStrings: boolean;
726     SQL: TStrings);
727     var ReadOnlyFieldNames: TStrings;
728     begin
729     SQL.Clear;
730     ReadOnlyFieldNames := TStringList.Create;
731     try
732     GetFieldNames(ReadOnlyFields,ReadOnlyFieldNames,true);
733     GenerateDeleteSQL(UserTables.FieldByName('RDB$RELATION_NAME').AsString,QuotedStrings,ReadOnlyFieldNames,SQL)
734     finally
735     ReadOnlyFieldNames.Free;
736     end;
737     end;
738    
739     procedure TIBSQLEditFrame.CutExecute(Sender: TObject);
740     begin
741     SQLText.CutToClipboard;
742     end;
743    
744     procedure TIBSQLEditFrame.CopyTextExecute(Sender: TObject);
745     begin
746     SQLText.CopyToClipboard;
747     end;
748    
749     procedure TIBSQLEditFrame.ClearExecute(Sender: TObject);
750     begin
751     SQLText.Lines.Clear;
752     end;
753    
754     procedure TIBSQLEditFrame.AddWhereClause(
755     QuotedStrings: boolean; SQL: TStrings; UseOldValues: boolean);
756     var WhereClause: string;
757     Separator: string;
758     Count: integer;
759     Prefix: string;
760     ColumnName: string;
761     begin
762     Count := 0;
763     WhereClause := 'Where';
764     Separator := ' A.';
765     if UseOldValues then
766     Prefix := ':OLD_'
767     else
768     Prefix := ':';
769     with PrimaryKeys do
770     begin
771     DisableControls;
772     try
773     if State = dsEdit then Post;
774     First;
775     while not EOF do
776     begin
777     if FieldByName('Selected').AsInteger <> 0 then
778     begin
779     Inc(Count);
780     ColumnName := FieldByName('ColumnName').AsString;
781     if QuotedStrings then
782     WhereClause := WhereClause + Separator + '"' + ColumnName +
783     '" = ' + Prefix+ AnsiUpperCase(ColumnName)
784     else
785     WhereClause := WhereClause + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ColumnName) +
786     ' = ' + Prefix + AnsiUpperCase(ColumnName);
787     Separator := ' AND A.';
788     end;
789     Next;
790     end;
791     finally
792     EnableControls
793     end;
794     end;
795     if Count > 0 then
796     SQL.Add(WhereClause);
797     end;
798    
799     function TIBSQLEditFrame.GetSQLType(SQLType: TIBSQLStatementTypes): string;
800     begin
801     case SQLType of
802     SQLUnknown: Result := 'Unknown';
803     SQLSelect: Result := 'Select';
804     SQLInsert: Result := 'Insert';
805     SQLUpdate: Result := 'Update';
806     SQLDelete: Result := 'Delete';
807     SQLDDL: Result := 'DDL';
808     SQLGetSegment: Result := 'GetSegment';
809     SQLPutSegment: Result := 'PutSegment';
810     SQLExecProcedure: Result := 'Execute Procedure';
811     SQLStartTransaction: Result := 'StartTransaction';
812     SQLCommit: Result := 'Commit';
813     SQLRollback: Result := 'Rollback';
814     SQLSelectForUpdate: Result := 'Select for Update';
815     SQLSetGenerator: Result := 'Set Generator';
816     end;
817     end;
818    
819     procedure TIBSQLEditFrame.GetFieldNames(Dataset: TDataset;
820     var FieldNames: TStrings; aIncludeReadOnly: boolean);
821     begin
822     with DataSet do
823     begin
824     DisableControls;
825     try
826     if State = dsEdit then Post;
827     First;
828     while not EOF do
829     begin
830     if (FieldByName('Selected').AsInteger <> 0) and (aIncludeReadOnly or (FieldByName('ReadOnly').AsInteger = 0)) then
831     FieldNames.Add(FieldByName('ColumnName').AsString);
832     Next;
833     end;
834     finally
835     EnableControls
836     end;
837     end;
838     end;
839    
840     procedure TIBSQLEditFrame.GenerateSelectSQL(TableName: string;
841     QuotedStrings: boolean; FieldNames, PrimaryKeyNames, SQL: TStrings);
842     var SelectSQL: string;
843     Separator : string;
844     I: integer;
845     Lines: TStrings;
846     begin
847     SelectSQL := 'Select';
848     Separator := ' A.';
849     for I := 0 to PrimaryKeyNames.Count - 1 do
850     begin
851     if QuotedStrings then
852     SelectSQL := SelectSQL + Separator + '"' + PrimaryKeyNames[I] + '"'
853     else
854     SelectSQL := SelectSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,PrimaryKeyNames[I]);
855     Separator := ', A.';
856     end;
857     for I := 0 to FieldNames.Count - 1 do
858     begin
859     if QuotedStrings then
860     SelectSQL := SelectSQL + Separator + '"' + FieldNames[I] + '"'
861     else
862     SelectSQL := SelectSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]);
863     Separator := ', A.';
864     end;
865     if QuotedStrings then
866     SelectSQL := SelectSQL + ' From "' + TableName + '" A'
867     else
868     SelectSQL := SelectSQL + ' From ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A';
869     Lines := TStringList.Create;
870     try
871     Lines.Text := SelectSQL;
872     SQL.AddStrings(Lines);
873     finally
874     Lines.Free;
875     end;
876     end;
877    
878     procedure TIBSQLEditFrame.GenerateInsertSQL(TableName: string;
879     QuotedStrings: boolean; FieldNames, ReadOnlyFieldNames, SQL: TStrings);
880     var InsertSQL: string;
881     Separator: string;
882     Lines: TStrings;
883     I: integer;
884     begin
885     Lines := TStringList.Create;
886     try
887     if QuotedStrings then
888     InsertSQL := 'Insert Into "' + TableName + '" ('
889     else
890     InsertSQL := 'Insert Into ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' (';
891     Separator := '';
892     for I := 0 to FieldNames.Count - 1 do
893     begin
894     if QuotedStrings then
895     InsertSQL := InsertSQL + Separator + '"' + FieldNames[I] + '"'
896     else
897     InsertSQL := InsertSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]) ;
898     Separator := ', ';
899     end;
900     InsertSQL := InsertSQL + ')';
901     Lines.Add(InsertSQL);
902     InsertSQL := 'Values(';
903     Separator := ':';
904     for I := 0 to FieldNames.Count - 1 do
905     begin
906     InsertSQL := InsertSQL + Separator + AnsiUpperCase(FieldNames[I]) ;
907     Separator := ', :';
908     end;
909     InsertSQL := InsertSQL + ')';
910     Lines.Add(InsertSQL);
911    
912     {Is database Firebird 2.1 or later?}
913     if (DatabaseInfo.ODSMajorVersion > 11) or
914     ((DatabaseInfo.ODSMajorVersion = 11) and (DatabaseInfo.ODSMinorVersion >= 1)) then
915     begin
916     InsertSQL := '';
917     Separator := ' RETURNING ';
918     if IdentityCols.Active and (IdentityCols.RecordCount > 0) then
919     begin
920     IdentityCols.First;
921     while not IdentityCols.Eof do
922     begin
923     if (IdentityCols.FieldByName('Selected').AsInteger <> 0) and
924     (not PrimaryKeys.Active or not PrimaryKeys.Locate('columnName;Selected',
925     VarArrayOf([IdentityCols.FieldByName('ColumnName').AsString,0]),[loCaseInsensitive])) then
926     begin
927 tony 209 InsertSQL := InsertSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,IdentityCols.FieldByName('ColumnName').AsString);
928 tony 158 Separator := ', ';
929     end;
930     IdentityCols.Next;
931     end;
932     end;
933     for I := 0 to ReadOnlyFieldNames.Count - 1 do
934     begin
935     if QuotedStrings then
936     InsertSQL := InsertSQL + Separator + '"' + ReadOnlyFieldNames[I] + '"'
937     else
938     InsertSQL := InsertSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
939     Separator := ', ';
940     end;
941     Lines.Add(InsertSQL);
942     end;
943     SQL.AddStrings(Lines);
944     finally
945     Lines.Free;
946     end;
947     end;
948    
949     procedure TIBSQLEditFrame.GenerateModifySQL(TableName: string;
950     QuotedStrings: boolean; FieldNames, ReadOnlyFieldNames, SQL: TStrings);
951     var UpdateSQL: string;
952     Separator: string;
953     I: integer;
954     begin
955     Separator := ' A.';
956     if QuotedStrings then
957     UpdateSQL := 'Update "' + TableName + '" A Set '
958     else
959     UpdateSQL := 'Update ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A Set ';
960     SQL.Add(UpdateSQL);
961     for I := 0 to FieldNames.Count - 1 do
962     begin
963     if QuotedStrings then
964     UpdateSQL := Separator + '"' + FieldNames[I] + '" = :' + AnsiUpperCase(FieldNames[I])
965     else
966     UpdateSQL := Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,FieldNames[I]) + ' = :' + AnsiUpperCase(FieldNames[I]);
967     if I < FieldNames.Count - 1 then
968     UpdateSQL := UpdateSQL + ',';
969     SQL.Add(UpdateSQL);
970     end;
971     AddWhereClause(QuotedStrings,SQL,true);
972    
973     {Is database Firebird 2.1 or later?}
974     if (DatabaseInfo.ODSMajorVersion > 11) or
975     ((DatabaseInfo.ODSMajorVersion = 11) and (DatabaseInfo.ODSMinorVersion >= 1)) then
976     begin
977     Separator := ' RETURNING A.';
978     UpdateSQL := '';
979     for I := 0 to ReadOnlyFieldNames.Count - 1 do
980     begin
981     if QuotedStrings then
982     UpdateSQL := UpdateSQL + Separator + '"' + ReadOnlyFieldNames[I] + '"'
983     else
984     UpdateSQL := UpdateSQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
985     Separator := ', A.';
986     end;
987     SQL.Add(UpdateSQL);
988     end;
989     end;
990    
991     procedure TIBSQLEditFrame.GenerateDeleteSQL(TableName: string;
992     QuotedStrings: boolean; ReadOnlyFieldNames, SQL: TStrings);
993     {var ReturningText, Separator: string;
994     I: integer; }
995     begin
996     if QuotedStrings then
997     SQL.Add('Delete From "' + TableName + '" A')
998     else
999     SQL.Add('Delete From ' + QuoteIdentifierIfNeeded(Database.SQLDialect,TableName) + ' A');
1000     AddWhereClause(QuotedStrings,SQL,true);
1001     { Separator := ' RETURNING A.';
1002     ReturningText := '';
1003     for I := 0 to ReadOnlyFieldNames.Count - 1 do
1004     begin
1005     if QuotedStrings then
1006     ReturningText := ReturningText + Separator + '"' + ReadOnlyFieldNames[I] + '"'
1007     else
1008     ReturningText := ReturningText + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,ReadOnlyFieldNames[I]);
1009     Separator := ', A.';
1010     end;
1011     SQL.Add(ReturningText);}
1012     end;
1013    
1014     const
1015     sqlCheckProcedureNames = 'Select * From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
1016    
1017     function TIBSQLEditFrame.GetStatementType(var IsStoredProcedure: boolean
1018     ): TIBSQLStatementTypes;
1019     var TableName: string;
1020     begin
1021     Result := sqlUnknown;
1022     if not assigned(Database) or not Database.Connected or (Trim(SQLText.Lines.Text) = '') then
1023     Exit;
1024     IsStoredProcedure := false;
1025     with TIBSQL.Create(nil) do
1026     try
1027     Database := self.Database;
1028     Transaction := SQLTransaction;
1029     SQL.Assign(SQLText.Lines);
1030     GenerateParamNames := true; {permissive}
1031     try
1032     Prepare;
1033     Result := SQLStatementType
1034     except on E:EIBError do
1035     // ShowMessage(E.Message);
1036     end;
1037     if (Result = SQLSelect) and (MetaData.Count > 0) then
1038     begin
1039     TableName := MetaData[0].GetRelationName;
1040     SQL.Text := sqlCheckProcedureNames;
1041     Prepare;
1042     ParamByName('ProcName').AsString := TableName;
1043     ExecQuery;
1044     try
1045     IsStoredProcedure := not EOF;
1046     finally
1047     Close
1048     end;
1049     end;
1050     finally
1051     Free
1052     end;
1053     end;
1054    
1055     procedure TIBSQLEditFrame.GenerateExecuteSQL(PackageName,ProcName: string;
1056     QuotedStrings: boolean; ExecuteOnly: boolean; InputParams, OutputParams,
1057     ExecuteSQL: TStrings);
1058    
1059     function GetProcName: string;
1060     begin
1061     if QuotedStrings then
1062     begin
1063     if PackageName = '' then
1064     Result := QuoteIdentifier(Database.SQLDialect,ProcName)
1065     else
1066     Result := QuoteIdentifier(Database.SQLDialect,PackageName) + '.' +
1067     QuoteIdentifier(Database.SQLDialect,ProcName);
1068     end
1069     else
1070     if PackageName = '' then
1071     Result := QuoteIdentifierIfNeeded(Database.SQLDialect,ProcName)
1072     else
1073     Result := QuoteIdentifierIfNeeded(Database.SQLDialect,PackageName) + '.' +
1074     QuoteIdentifierIfNeeded(Database.SQLDialect,ProcName);
1075     end;
1076    
1077     var SQL: string;
1078     I: integer;
1079     Separator: string;
1080     Lines: TStrings;
1081     begin
1082     Lines := TStringList.Create;
1083     try
1084     Separator := '';
1085     if not ExecuteOnly and (OutputParams.Count > 0) then //Select Query
1086     begin
1087     SQL := 'Select ';
1088     for I := 0 to OutputParams.Count - 1 do
1089     begin
1090     if QuotedStrings then
1091     SQL := SQL + Separator + '"' + OutputParams[I] + '"'
1092     else
1093     SQL := SQL + Separator + QuoteIdentifierIfNeeded(Database.SQLDialect,OutputParams[I]);
1094     Separator := ', ';
1095     end;
1096     SQL := SQL + ' From ' + GetProcName;
1097     if InputParams.Count > 0 then
1098     begin
1099     Separator := '(:';
1100     for I := 0 to InputParams.Count - 1 do
1101     begin
1102     SQL := SQL + Separator + AnsiUpperCase(InputParams[I]);
1103     Separator := ', :';
1104     end;
1105     SQL := SQL + ')'
1106     end
1107     end
1108     else // Execute Procedure
1109     begin
1110     SQL := 'Execute Procedure ' + GetProcName;
1111     if InputParams.Count > 0 then
1112     begin
1113     Separator := ' :';
1114     for I := 0 to InputParams.Count - 1 do
1115     begin
1116     SQL := SQL + Separator + AnsiUpperCase(InputParams[I]);
1117     Separator := ', :';
1118     end;
1119     end
1120     end;
1121     Lines.Add(SQL + ';');
1122     ExecuteSQL.AddStrings(Lines);
1123     finally
1124     Lines.Free
1125     end
1126     end;
1127    
1128     procedure TIBSQLEditFrame.InsertSelectedPrimaryKey;
1129     begin
1130     SQLText.SelText := PrimaryKeys.FieldByName('ColumnName').AsString;
1131     SQLText.SetFocus
1132     end;
1133    
1134     procedure TIBSQLEditFrame.InsertSelectedFieldName;
1135     begin
1136     SQLText.SelText := FieldNameList.FieldByName('ColumnName').AsString;
1137     SQLText.SetFocus
1138     end;
1139    
1140     procedure TIBSQLEditFrame.InsertTableName;
1141     begin
1142     SQLText.SelText := UserTables.FieldByName('RDB$RELATION_NAME').AsString;
1143     SQLText.SetFocus
1144     end;
1145    
1146     procedure TIBSQLEditFrame.InsertProcName;
1147     begin
1148     SQLText.SelText := UserProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString;
1149     SQLText.SetFocus
1150     end;
1151    
1152     procedure TIBSQLEditFrame.InsertPackageName;
1153     begin
1154     if PackageNames.Active and (PackageNames.FieldByName('PACKAGE_NAME_TYPE').AsInteger = 1) then
1155     begin
1156     SQLText.SelText := PackageNames.FieldByName('RDB$PACKAGE_NAME').AsString;
1157     SQLText.SetFocus
1158     end;
1159     end;
1160    
1161     procedure TIBSQLEditFrame.InsertSelectedInputParam;
1162     begin
1163     SQLText.SelText := ProcInputParams.FieldByName('ColumnName').AsString;
1164     SQLText.SetFocus
1165     end;
1166    
1167     procedure TIBSQLEditFrame.InsertSelectedOutputParam;
1168     begin
1169     SQLText.SelText := ProcOutputParams.FieldByName('ColumnName').AsString;
1170     SQLText.SetFocus
1171     end;
1172    
1173     procedure TIBSQLEditFrame.InsertSelectedIdentityCol;
1174     begin
1175     SQLText.SelText := IdentityCols.FieldByName('ColumnName').AsString;
1176     SQLText.SetFocus
1177     end;
1178    
1179     procedure TIBSQLEditFrame.InsertSelectedReadOnlyField;
1180     begin
1181     SQLText.SelText := ReadOnlyFields.FieldByName('ColumnName').AsString;
1182     SQLText.SetFocus
1183     end;
1184    
1185     procedure TIBSQLEditFrame.OpenUserProcedures;
1186     begin
1187     if DatabaseInfo.ODSMajorVersion < 12 then
1188     UserProcedures.Active := true
1189     else
1190     PackageNames.Active := true;
1191     end;
1192    
1193     procedure GetSymbols(Lines: TStrings; var WordList: TStrings; MaxSymbols: integer = 3);
1194     var Tokeniser: TSynSQLSyn;
1195     i: integer;
1196     Token: string;
1197     begin
1198     Tokeniser := TSynSQLSyn.Create(nil); {use the highligher as a tokeniser}
1199     try
1200     Tokeniser.SQLDialect := sqlInterbase6;
1201     for i := 0 to Lines.Count - 1 do
1202     begin
1203     Tokeniser.SetLine(Lines[i],i);
1204     repeat
1205     if not (Tokeniser.GetTokenID in [tkComment,tkSpace,tkUnknown]) then
1206     begin
1207     Dec(MaxSymbols);
1208     Token := Tokeniser.GetToken;
1209     if (Length(Token) > 1) and (Token[1] = '"') and (Token[Length(Token)] = '"') then
1210     WordList.AddObject(system.copy(Token,2,Length(Token)-2),WordList) {note convention to indicate quoted}
1211     else
1212     WordList.Add(AnsiUpperCase(Token));
1213     // writeln(WordList[WordList.Count-1]);
1214     end;
1215     if MaxSymbols = 0 then
1216     Exit;
1217     Tokeniser.Next;
1218     until Tokeniser.GetEol;
1219     end;
1220     finally
1221     Tokeniser.Free;
1222     end;
1223     end;
1224    
1225     function TIBSQLEditFrame.SyncQueryBuilder: TIBSQLStatementTypes;
1226     begin
1227     Result := SyncQueryBuilder(SQLText.Lines);
1228     end;
1229    
1230     function TIBSQLEditFrame.SyncQueryBuilder(SQL: TStrings): TIBSQLStatementTypes;
1231     var TableName: string;
1232     FirstWord: string;
1233     Symbols: TStrings;
1234     i: integer;
1235    
1236     function FindProcedure(StartIndex: integer): boolean;
1237     begin
1238     if StartIndex >= Symbols.Count then Exit;
1239    
1240     if DatabaseInfo.ODSMajorVersion < 12 then {No packages}
1241     begin
1242     UserProcedures.Active := true;
1243     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex],[]);
1244     end
1245     else
1246     begin
1247     PackageNames.Active := true;
1248     if (StartIndex < Symbols.Count - 2) and (Symbols[StartIndex+1] = '.') and
1249     PackageNames.Locate('RDB$PACKAGE_NAME',Symbols[StartIndex],[]) then
1250     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex+2],[])
1251     else
1252     Result := UserProcedures.Locate('RDB$PROCEDURE_NAME',Symbols[StartIndex],[]);
1253     end;
1254     end;
1255    
1256     begin
1257     if (Database = nil) or not Database.Connected or FQuerySync then Exit;
1258    
1259     FQuerySync := true;
1260     Result := SQLUnknown;
1261     TableName := '';
1262     Symbols := TStringList.Create;
1263     try
1264     try
1265     IdentifyStatementSQL.Transaction.Active := true;
1266     IdentifyStatementSQL.SQL.Assign(SQL);
1267     IdentifyStatementSQL.Prepare;
1268     Result := IdentifyStatementSQL.SQLStatementType;
1269     case Result of
1270     SQLSelect:
1271     begin
1272     if IdentifyStatementSQL.MetaData.Count > 0 then
1273     TableName := IdentifyStatementSQL.MetaData[0].GetRelationName
1274     else
1275     Exit;
1276     if (Pos('MON$',TableName) > 0) or (Pos('RDB$',TableName) > 0) or (Pos('SEC$',TableName) > 0) then
1277     IncludeSystemTables := true;
1278    
1279     if not UserTables.Locate('RDB$RELATION_NAME',TableName,[]) then
1280     begin
1281     {We don't know if the stored procedure is in a package because
1282     the relationname is always the procedure name regardless of
1283     whether it is a non-package procedure or in a package. Hence,
1284     we have to look for the From keyword to find the full procedure name}
1285     GetSymbols(IdentifyStatementSQL.SQL,Symbols,-1); {Get All Symbols}
1286     for i := 0 to Symbols.Count - 1 do
1287     begin
1288     if (Symbols[i] = 'FROM') and (Symbols.Objects[i] = nil) then
1289     begin
1290     if FindProcedure(i+1) then
1291     Result := SQLExecProcedure;
1292     Exit;
1293     end;
1294     end;
1295     {Should have found it - try relationname in hope rather than expectation}
1296     UserProcedures.Active := true;
1297     if UserProcedures.Locate('RDB$PROCEDURE_NAME',TableName,[]) then
1298     Result := SQLExecProcedure;
1299     end;
1300     end;
1301     { If not a select statement then return table or procedure name
1302     as First Table Name }
1303     SQLUpdate:
1304     begin
1305     GetSymbols(IdentifyStatementSQL.SQL,Symbols,2);
1306     UserTables.Locate('RDB$RELATION_NAME',Symbols[1],[]);
1307     end;
1308    
1309     SQLInsert:
1310     begin
1311     GetSymbols(IdentifyStatementSQL.SQL,Symbols,3);
1312     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1313     end;
1314    
1315     SQLDelete:
1316     begin
1317     GetSymbols(IdentifyStatementSQL.SQL,Symbols,3);
1318     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1319     end;
1320    
1321     SQLExecProcedure:
1322     begin
1323     GetSymbols(IdentifyStatementSQL.SQL,Symbols,5);
1324     FirstWord := Symbols[0];
1325     if FirstWord = 'INSERT' then {INSERT...RETURNING}
1326     begin
1327     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1328     Result := SQLInsert;
1329     end
1330     else
1331     if FirstWord = 'UPDATE' then {UPDATE...RETURNING}
1332     begin
1333     UserTables.Locate('RDB$RELATION_NAME',Symbols[1],[]);
1334     Result := SQLUpdate;
1335     end
1336     else
1337     if FirstWord = 'DELETE' then {DELETE...RETURNING}
1338     begin
1339     UserTables.Locate('RDB$RELATION_NAME',Symbols[2],[]);
1340     Result := SQLDelete;
1341     end
1342     else
1343     FindProcedure(2);
1344     end;
1345     end
1346     except on E:EIBError do
1347     // ShowMessage(E.Message);
1348     end;
1349     finally
1350     Symbols.Free;
1351     FQuerySync := false;
1352     end;
1353     end;
1354    
1355     procedure TIBSQLEditFrame.TestSQL(GenerateParamNames: boolean);
1356     begin
1357     if not assigned(Database) or not Database.Connected then
1358     begin
1359     Messagedlg('No Database Connected',mtError,[mbOK],0);
1360     Exit;
1361     end;
1362     with TIBSQL.Create(nil) do
1363     try
1364     Database := self.Database;
1365     Transaction := SQLTransaction;
1366     GenerateParamNames := GenerateParamNames;
1367     SQL.Assign(SQLText.Lines);
1368     try
1369     Prepare;
1370     ShowMessage('SQL '+ GetSQLType(SQLStatementType) + ' Statement Looks OK');
1371     except on E:EIBError do
1372     ShowMessage(E.Message);
1373     end;
1374     finally
1375     Free
1376     end;
1377     end;
1378    
1379    
1380     end.
1381