ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/design/IBSystemTables.pas
(Generate patch)
# Line 1 | Line 1
1 < (*
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 Tony Whyman, MWA Software
19 < *  (http://www.mwasoftware.co.uk).
20 < *
21 < *  All Rights Reserved.
22 < *
23 < *  Contributor(s): ______________________________________.
24 < *
25 < *)
26 <
27 < unit IBSystemTables;
28 <
29 < {$mode objfpc}{$H+}
30 <
31 < interface
32 <
33 < uses
34 <  Classes, SysUtils, IBSQL, IBDatabase, StdCtrls;
35 <
36 < type
37 <
38 <  { TIBSystemTables }
39 <
40 <  TIBSystemTables = class
41 <  private
42 <    FGetTableNames: TIBSQL;
43 <    FGetFieldNames: TIBSQL;
44 <    FGetPrimaryKeys: TIBSQL;
45 <    FTestSQL: TIBSQL;
46 <    FTableAndColumnSQL: TIBSQL;
47 <    FGetGeneratorsSQL: TIBSQL;
48 <    FGetProcedures: TIBSQL;
49 <    FGetProcedureParams: TIBSQL;
50 <    FGetProcedureInfo: TIBSQL;
51 <    function GetSQLType(SQLType: TIBSQLTypes): string;
52 <    procedure AddWhereClause(TableName: string; QuotedStrings: boolean; SQL: TStrings;
53 <       UseOldValues: boolean = false);
54 <    procedure GetProcParams(ProcName: string; ParamList: TStrings; InputParams: boolean); overload;
55 <    function GetWord(S: string; WordNo: integer): string;
56 < public
57 <    constructor Create;
58 <    destructor Destroy; override;
59 <    procedure SelectDatabase(Database: TIBDatabase; Transaction: TIBTransaction);
60 <    procedure GetTableNames(TableNames: TStrings);
61 <    procedure GetFieldNames(TableName: string; FieldNames: TStrings;
62 <              IncludePrimaryKeys:boolean=true; IncludeReadOnlyFields: boolean = true);
63 <    procedure GetPrimaryKeys(TableName: string; PrimaryKeys: TStrings);
64 <    procedure GetTableAndColumns(SelectSQL: string; var FirstTableName: string;
65 <                Columns: TStrings);
66 <    procedure GetProcedureNames(ProcNames: TStrings; WithOutputParams: boolean=false);
67 <    procedure GetProcParams(ProcName: string; var ExecuteOnly: boolean;
68 <                            InputParams, OutputParams: TStrings); overload;
69 <    procedure GetGenerators(GeneratorNames: TStrings);
70 <    procedure GenerateSelectSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
71 <    procedure GenerateRefreshSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
72 <    procedure GenerateInsertSQL(TableName: string; QuotedStrings: boolean; FieldNames, SQL: TStrings);
73 <    procedure GenerateModifySQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
74 <    procedure GenerateDeleteSQL(TableName: string; QuotedStrings: boolean; SQL: TStrings);
75 <    procedure GenerateExecuteSQL(ProcName: string; QuotedStrings: boolean; ExecuteOnly: boolean;
76 <              InputParams, OutputParams, ExecuteSQL: TStrings);
77 <    function GetStatementType(SQL: string; var IsStoredProcedure: boolean): TIBSQLTypes;
78 <    function GetFieldNames(FieldList: TListBox): TStrings;
79 <    procedure TestSQL(SQL: string);
80 <  end;
81 <
82 < implementation
83 <
84 < uses IB, Dialogs;
85 <
86 < { TIBSystemTables }
87 <
88 < const
89 <  sqlGETTABLES = 'Select Trim(RDB$RELATION_NAME) as TableName From RDB$RELATIONS ' +
90 <                 'Where RDB$SYSTEM_FLAG = 0 ' +
91 <                 'Order by 1';
92 <
93 <  sqlGETALLFIELDS = 'Select Trim(RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS ' +
94 <                 'Where RDB$RELATION_NAME = :TableName ' +
95 <                 'order by RDB$FIELD_POSITION asc ';
96 <
97 <  sqlGETFIELDS = 'Select Trim(RF.RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
98 <                 'JOIN RDB$FIELDS B On B.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
99 <                 'Where RF.RDB$RELATION_NAME = :TableName and B.RDB$COMPUTED_SOURCE is NULL ' +
100 <                 'order by RF.RDB$FIELD_POSITION asc ';
101 <
102 <  sqlGETPRIMARYKEYS = 'Select Trim(S.RDB$FIELD_NAME) as ColumnName From '+
103 <                      '(Select RDB$INDEX_NAME,RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS Order by RDB$FIELD_POSITION ASC) S ' +
104 <                      'JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME ' +
105 <                      'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and RDB$RELATION_NAME = :TableName';
106 <
107 <  sqlUPDATEFIELDS = 'Select Trim(RF.RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
108 <                    'JOIN RDB$FIELDS B On B.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
109 <                    'Where RF.RDB$RELATION_NAME = :TableName  and RF.RDB$FIELD_NAME not in ' +
110 <                    '(Select RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS S JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME '+
111 <                     'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and C.RDB$RELATION_NAME = RF.RDB$RELATION_NAME) and B.RDB$COMPUTED_SOURCE is NULL ' +
112 <                     'order by 1 asc ';
113 <
114 <  sqlALLUPDATEFIELDS = 'Select Trim(RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
115 <                    'Where RF.RDB$RELATION_NAME = :TableName  and RDB$FIELD_NAME not in ' +
116 <                    '(Select RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS S JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME '+
117 <                     'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and C.RDB$RELATION_NAME = RF.RDB$RELATION_NAME)' +
118 <                     'order by 1 asc ';
119 <
120 <  sqlGETGENERATORNAMES = 'Select RDB$GENERATOR_NAME FROM RDB$GENERATORS '+
121 <                         'Where RDB$SYSTEM_FLAG = 0 '+
122 <                         'Order by 1 asc';
123 <
124 <  sqlGETPROCEDURES = 'Select Trim(RDB$PROCEDURE_NAME) as ProcName, RDB$PROCEDURE_INPUTS, '+
125 <                     'RDB$PROCEDURE_OUTPUTS From RDB$PROCEDURES '+
126 <                     'Where RDB$SYSTEM_FLAG = 0 and RDB$PROCEDURE_TYPE <= :ProcType Order by 1 asc';
127 <
128 <  sqlGETPROCPARAM  = 'Select Trim(P.RDB$PARAMETER_NAME) as ParamName '+
129 <                     'From RDB$PROCEDURE_PARAMETERS P '+
130 <                     'JOIN RDB$FIELDS F On F.RDB$FIELD_NAME = P.RDB$FIELD_SOURCE '+
131 <                     'Where P.RDB$SYSTEM_FLAG = 0 and P.RDB$PROCEDURE_NAME = :ProcName and P.RDB$PARAMETER_TYPE = :type '+
132 <                     'Order by P.RDB$PARAMETER_NUMBER asc';
133 <
134 <  sqlCheckProcedureNames = 'Select * From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
135 <
136 <  sqlGETPROCEDUREINFO = 'Select RDB$PROCEDURE_TYPE From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
137 <
138 < function TIBSystemTables.GetSQLType(SQLType: TIBSQLTypes): string;
139 < begin
140 <  case SQLType of
141 <  SQLUnknown:              Result := 'Unknown';
142 <  SQLSelect:               Result := 'Select';
143 <  SQLInsert:               Result := 'Insert';
144 <  SQLUpdate:               Result := 'Update';
145 <  SQLDelete:               Result := 'Delete';
146 <  SQLDDL:                  Result := 'DDL';
147 <  SQLGetSegment:           Result := 'GetSegment';
148 <  SQLPutSegment:           Result := 'PutSegment';
149 <  SQLExecProcedure:        Result := 'Execute Procedure';
150 <  SQLStartTransaction:     Result := 'StartTransaction';
151 <  SQLCommit:               Result := 'Commit';
152 <  SQLRollback:             Result := 'Rollback';
153 <  SQLSelectForUpdate:      Result := 'Select for Update';
154 <  SQLSetGenerator:         Result := 'Set Generator';
155 <  end;
156 < end;
157 <
158 < procedure TIBSystemTables.AddWhereClause(TableName: string;
159 <  QuotedStrings: boolean; SQL: TStrings; UseOldValues: boolean);
160 < var WhereClause: string;
161 <    Separator: string;
162 <    Count: integer;
163 <    Prefix: string;
164 < begin
165 <  if not assigned(FGetPrimaryKeys.Database) or not FGetPrimaryKeys.Database.Connected or
166 <    not assigned(FGetPrimaryKeys.Transaction) then
167 <    Exit;
168 <  Count := 0;
169 <  WhereClause := 'Where';
170 <  Separator := ' A.';
171 <  if UseOldValues then
172 <    Prefix := ':OLD_'
173 <  else
174 <    Prefix := ':';
175 <  FGetPrimaryKeys.Prepare;
176 <  FGetPrimaryKeys.ParamByName('TableName').AsString := TableName;
177 <  FGetPrimaryKeys.ExecQuery;
178 <  try
179 <    while not FGetPrimaryKeys.EOF do
180 <    begin
181 <      Inc(Count);
182 <      if QuotedStrings then
183 <        WhereClause := WhereClause + Separator + '"' + FGetPrimaryKeys.FieldByName('ColumnName').AsString +
184 <               '" = ' + Prefix+ FGetPrimaryKeys.FieldByName('ColumnName').AsString
185 <      else
186 <        WhereClause := WhereClause + Separator + FGetPrimaryKeys.FieldByName('ColumnName').AsString +
187 <               ' = ' + Prefix + FGetPrimaryKeys.FieldByName('ColumnName').AsString;
188 <      Separator := ' AND A.';
189 <      FGetPrimaryKeys.Next
190 <    end;
191 <  finally
192 <    FGetPrimaryKeys.Close
193 <  end;
194 <  if Count > 0 then
195 <    SQL.Add(WhereClause)
196 < end;
197 <
198 < procedure TIBSystemTables.GetProcParams(ProcName: string; ParamList: TStrings;
199 <  InputParams: boolean);
200 < begin
201 <  if not assigned(FGetProcedureParams.Database) or not FGetProcedureParams.Database.Connected or
202 <    not assigned(FGetProcedureParams.Transaction) then
203 <    Exit;
204 <  ParamList.Clear;
205 <  with FGetProcedureParams do
206 <  begin
207 <    with Transaction do
208 <      if not InTransaction then StartTransaction;
209 <    Prepare;
210 <    ParamByName('ProcName').AsString := ProcName;
211 <    if InputParams then
212 <      ParamByName('type').AsInteger := 0
213 <    else
214 <      ParamByName('type').AsInteger := 1;
215 <    ExecQuery;
216 <    try
217 <      while not EOF do
218 <      begin
219 <        ParamList.Add(FieldByName('ParamName').AsString);
220 <        Next;
221 <      end;
222 <    finally
223 <      Close
224 <    end;
225 <  end;
226 < end;
227 <
228 < function TIBSystemTables.GetWord(S: string; WordNo: integer): string;
229 < const
230 <    SpaceChars = [' ',#$0a,#$0d,#$09,'('];
231 < var I: integer;
232 <    StartIdx: integer;
233 <    InWhiteSpace: boolean;
234 < begin
235 <  Result := '';
236 <  StartIdx := 1;
237 <  InWhiteSpace := true;
238 <  for I := 1 to Length(S) do
239 <  begin
240 <    if InWhiteSpace then
241 <    begin
242 <      if not (S[I] in SpaceChars) then
243 <      begin
244 <        StartIdx := I;
245 <        InWhiteSpace := false
246 <      end
247 <    end
248 <    else
249 <    begin
250 <      if S[I] in SpaceChars then
251 <      begin
252 <        Dec(WordNo);
253 <        if WordNo = 0 then
254 <        begin
255 <          Result := System.copy(S,StartIdx,I - StartIdx);
256 <          Exit
257 <        end;
258 <        InWhiteSpace := true
259 <      end
260 <    end
261 <  end;
262 < end;
263 <
264 < constructor TIBSystemTables.Create;
265 < begin
266 <  FGetTableNames := TIBSQL.Create(nil);
267 <  FGetFieldNames := TIBSQL.Create(nil);
268 <  FGetPrimaryKeys := TIBSQL.Create(nil);
269 <  FGetProcedures := TIBSQL.Create(nil);
270 <  FTestSQL := TIBSQL.Create(nil);
271 <  FTableAndColumnSQL := TIBSQL.Create(nil);
272 <  FGetGeneratorsSQL := TIBSQL.Create(nil);
273 <  FGetProcedureParams := TIBSQL.Create(nil);
274 <  FGetProcedureInfo := TIBSQL.Create(nil);
275 < end;
276 <
277 < destructor TIBSystemTables.Destroy;
278 < begin
279 <  if assigned(FGetFieldNames) then FGetFieldNames.Free;
280 <  if assigned(FGetTableNames) then FGetTableNames.Free;
281 <  if assigned(FTestSQL) then FTestSQL.Free;
282 <  if assigned(FGetPrimaryKeys) then FGetPrimaryKeys.Free;
283 <  if assigned(FTableAndColumnSQL) then FTableAndColumnSQL.Free;
284 <  if assigned(FGetGeneratorsSQL) then FGetGeneratorsSQL.Free;
285 <  if assigned(FGetProcedures) then FGetProcedures.Free;
286 <  if assigned(FGetProcedureParams) then FGetProcedureParams.Free;
287 <  if assigned(FGetProcedureInfo) then FGetProcedureInfo.Free;
288 <  inherited Destroy;
289 < end;
290 <
291 < procedure TIBSystemTables.SelectDatabase(Database: TIBDatabase;
292 <  Transaction: TIBTransaction);
293 < begin
294 <    FGetTableNames.Database := Database;
295 <    FGetTableNames.Transaction := Transaction;
296 <    FGetTableNames.SQL.Text := sqlGETTABLES;
297 <    FGetFieldNames.Database := Database;
298 <    FGetFieldNames.Transaction := Transaction;
299 <    FGetFieldNames.SQL.Text := sqlGETFIELDS;
300 <    FTestSQL.Database := Database;
301 <    FTestSQL.Transaction := Transaction;
302 <    FGetPrimaryKeys.Database := Database;
303 <    FGetPrimaryKeys.Transaction := Transaction;
304 <    FGetPrimaryKeys.SQL.Text := sqlGETPRIMARYKEYS;
305 <    FTableAndColumnSQL.Database := Database;
306 <    FTableAndColumnSQL.Transaction := Transaction;
307 <    FGetGeneratorsSQL.Database := Database;
308 <    FGetGeneratorsSQL.Transaction := Transaction;
309 <    FGetGeneratorsSQL.SQL.Text := sqlGETGENERATORNAMES;
310 <    FGetProcedureParams.Database := Database;
311 <    FGetProcedureParams.Transaction := Transaction;
312 <    FGetProcedureParams.SQL.Text := sqlGETPROCPARAM;
313 <    FGetProcedureInfo.Database := Database;
314 <    FGetProcedureInfo.Transaction := Transaction;
315 <    FGetProcedureInfo.SQL.Text := sqlGETPROCEDUREINFO;
316 <    FGetProcedures.Database := Database;
317 <    FGetProcedures.Transaction := Transaction;
318 <    FGetProcedures.SQL.Text := sqlGETPROCEDURES;
319 < end;
320 <
321 < procedure TIBSystemTables.GetTableNames(TableNames: TStrings);
322 < begin
323 <  if not assigned(FGetTableNames.Database) or not FGetTableNames.Database.Connected or
324 <    not assigned(FGetTableNames.Transaction) then
325 <    Exit;
326 <  with FGetTableNames.Transaction do
327 <    if not InTransaction then StartTransaction;
328 <  TableNames.Clear;
329 <  FGetTableNames.ExecQuery;
330 <  try
331 <    while not FGetTableNames.EOF do
332 <    begin
333 <      TableNames.Add(FGetTableNames.FieldByName('TableName').AsString);
334 <      FGetTableNames.Next
335 <    end;
336 <  finally
337 <    FGetTableNames.Close
338 <  end;
339 < end;
340 <
341 < procedure TIBSystemTables.GetFieldNames(TableName: string;
342 <  FieldNames: TStrings; IncludePrimaryKeys: boolean;
343 <  IncludeReadOnlyFields: boolean);
344 < begin
345 <  if not assigned(FGetFieldNames.Database) or not FGetFieldNames.Database.Connected or
346 <    not assigned(FGetFieldNames.Transaction) then
347 <    Exit;
348 <  with FGetFieldNames.Transaction do
349 <    if not InTransaction then StartTransaction;
350 <  FieldNames.Clear;
351 <  if IncludePrimaryKeys then
352 <  begin
353 <    if IncludeReadOnlyFields then
354 <      FGetFieldNames.SQL.Text := sqlGETALLFIELDS
355 <    else
356 <      FGetFieldNames.SQL.Text := sqlGETFIELDS
357 <  end
358 <  else
359 <  if  IncludeReadOnlyFields then
360 <    FGetFieldNames.SQL.Text := sqlALLUPDATEFIELDS
361 <  else
362 <      FGetFieldNames.SQL.Text := sqlUPDATEFIELDS;
363 <  FGetFieldNames.Prepare;
364 <  FGetFieldNames.ParamByName('TableName').AsString := TableName;
365 <  FGetFieldNames.ExecQuery;
366 <  try
367 <    while not FGetFieldNames.EOF do
368 <    begin
369 <      FieldNames.Add(FGetFieldNames.FieldByName('ColumnName').AsString);
370 <      FGetFieldNames.Next
371 <    end;
372 <  finally
373 <    FGetFieldNames.Close
374 <  end;
375 < end;
376 <
377 < procedure TIBSystemTables.GetPrimaryKeys(TableName: string; PrimaryKeys: TStrings);
378 < begin
379 <  if not assigned(FGetPrimaryKeys.Database) or not FGetPrimaryKeys.Database.Connected or
380 <    not assigned(FGetPrimaryKeys.Transaction) then
381 <    Exit;
382 <  with FGetPrimaryKeys.Transaction do
383 <    if not InTransaction then StartTransaction;
384 <  PrimaryKeys.Clear;
385 <  FGetPrimaryKeys.Prepare;
386 <  FGetPrimaryKeys.ParamByName('TableName').AsString := TableName;
387 <  FGetPrimaryKeys.ExecQuery;
388 <  try
389 <    while not FGetPrimaryKeys.EOF do
390 <    begin
391 <      PrimaryKeys.Add(FGetPrimaryKeys.FieldByName('ColumnName').AsString);
392 <      FGetPrimaryKeys.Next
393 <    end;
394 <  finally
395 <    FGetPrimaryKeys.Close
396 <  end;
397 < end;
398 <
399 < procedure TIBSystemTables.GetTableAndColumns(SelectSQL: string;
400 <  var FirstTableName: string; Columns: TStrings);
401 < var I: integer;
402 < begin
403 <  FirstTableName := '';
404 <  if not assigned(FTableAndColumnSQL.Database) or not FTableAndColumnSQL.Database.Connected or
405 <    not assigned(FTableAndColumnSQL.Transaction) or (Trim(SelectSQL) = '') then
406 <    Exit;
407 <  with FTableAndColumnSQL.Transaction do
408 <    if not InTransaction then StartTransaction;
409 <  FTableAndColumnSQL.SQL.Text := SelectSQL;
410 <  try
411 <    FTableAndColumnSQL.Prepare;
412 <    case FTableAndColumnSQL.SQLType of
413 <    SQLSelect:
414 <      begin
415 <        if FTableAndColumnSQL.Current.Count > 0 then
416 <          FirstTableName := strpas(FTableAndColumnSQL.Current.Vars[0].Data^.relname)
417 <        else
418 <          FirstTableName := '';
419 <        if assigned(Columns) then
420 <        begin
421 <          Columns.Clear;
422 <          for I := 0 to FTableAndColumnSQL.Current.Count - 1 do
423 <              Columns.Add(FTableAndColumnSQL.Current.Vars[I].Name)
424 <        end;
425 <      end;
426 <    { If not a select statement then return table or procedure name
427 <      as First Table Name }
428 <    SQLUpdate:
429 <      FirstTableName := GetWord(SelectSQL,2);
430 <
431 <    else
432 <      FirstTableName := GetWord(SelectSQL,3);
433 <    end
434 <  except on E:EIBError do
435 < //      ShowMessage(E.Message);
436 <  end;
437 < end;
438 <
439 < procedure TIBSystemTables.GetProcedureNames(ProcNames: TStrings; WithOutputParams: boolean);
440 < begin
441 <  if not assigned(FGetProcedures.Database) or not FGetProcedures.Database.Connected or
442 <    not assigned(FGetProcedures.Transaction) then
443 <    Exit;
444 <  ProcNames.Clear;
445 <  with FGetProcedures do
446 <  begin
447 <    with Transaction do
448 <      if not InTransaction then StartTransaction;
449 <    Prepare;
450 <    if WithOutputParams then
451 <      ParamByName('ProcType').AsInteger := 1
452 <    else
453 <      ParamByName('ProcType').AsInteger := 2;
454 <    ExecQuery;
455 <    try
456 <      while not EOF do
457 <      begin
458 <        ProcNames.Add(FieldByName('ProcName').AsString);
459 <        Next;
460 <      end;
461 <    finally
462 <      Close
463 <    end;
464 <  end;
465 < end;
466 <
467 < procedure TIBSystemTables.GetProcParams(ProcName: string;
468 <  var ExecuteOnly: boolean; InputParams, OutputParams: TStrings);
469 < begin
470 <  GetProcParams(ProcName,InputParams,true);
471 <  GetProcParams(ProcName,OutputParams,false);
472 <  ExecuteOnly := OutputParams.Count = 0;
473 <  if not ExecuteOnly then
474 <  with FGetProcedureInfo do
475 <  begin
476 <    with Transaction do
477 <      if not InTransaction then StartTransaction;
478 <    Prepare;
479 <    ParamByName('ProcName').AsString := ProcName;
480 <    ExecQuery;
481 <    try
482 <      if not EOF then
483 <        ExecuteOnly := FieldByName('RDB$PROCEDURE_TYPE').AsInteger = 2
484 <    finally
485 <      Close
486 <    end;
487 <  end;
488 < end;
489 <
490 < procedure TIBSystemTables.GetGenerators(GeneratorNames: TStrings);
491 < begin
492 <  if not assigned(FGetGeneratorsSQL.Database) or not FGetGeneratorsSQL.Database.Connected or
493 <    not assigned(FGetGeneratorsSQL.Transaction) then
494 <    Exit;
495 <  GeneratorNames.Clear;
496 <  with FGetGeneratorsSQL do
497 <  begin
498 <    with Transaction do
499 <      if not InTransaction then StartTransaction;
500 <    ExecQuery;
501 <    try
502 <      while not EOF do
503 <      begin
504 <        GeneratorNames.Add(FieldByName('RDB$GENERATOR_NAME').AsString);
505 <        Next;
506 <      end;
507 <    finally
508 <      Close
509 <    end;
510 <  end;
511 <
512 < end;
513 <
514 < procedure TIBSystemTables.GenerateSelectSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
515 < var SelectSQL: string;
516 <    Separator : string;
517 <    I: integer;
518 < begin
519 <  SQL.Clear;
520 <  if not assigned(FGetFieldNames.Database) or not FGetFieldNames.Database.Connected or
521 <    not assigned(FGetFieldNames.Transaction) then
522 <  begin
523 <    Messagedlg('No Database Connected',mtError,[mbOK],0);
524 <    Exit;
525 <  end;
526 <  SelectSQL := 'Select';
527 <  Separator := ' A.';
528 <  for I := 0 to FieldNames.Count - 1 do
529 <  begin
530 <    if QuotedStrings then
531 <      SelectSQL := SelectSQL + Separator + '"' + FieldNames[I] + '"'
532 <    else
533 <      SelectSQL := SelectSQL + Separator + FieldNames[I];
534 <    Separator := ', A.';
535 <  end;
536 <  SelectSQL := SelectSQL + ' From ' + TableName + ' A';
537 <  SQL.Add(SelectSQL);
538 < end;
539 <
540 < procedure TIBSystemTables.GenerateRefreshSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
541 < begin
542 <  GenerateSelectSQL(TableName,QuotedStrings,FieldNames,SQL);
543 <  AddWhereClause(TableName,QuotedStrings,SQL)
544 < end;
545 <
546 < procedure TIBSystemTables.GenerateInsertSQL(TableName: string;
547 <  QuotedStrings: boolean; FieldNames,SQL: TStrings);
548 < var InsertSQL: string;
549 <    Separator: string;
550 <    I: integer;
551 < begin
552 <  SQL.Clear;
553 <  InsertSQL := 'Insert Into ' + TableName + '(';
554 <  Separator := '';
555 <  for I := 0 to FieldNames.Count - 1 do
556 <    begin
557 <      if QuotedStrings then
558 <         InsertSQL := InsertSQL + Separator + '"' + FieldNames[I] + '"'
559 <      else
560 <         InsertSQL := InsertSQL + Separator +  FieldNames[I] ;
561 <      Separator := ', ';
562 <    end;
563 <  InsertSQL := InsertSQL + ')';
564 <  SQL.Add(InsertSQL);
565 <  InsertSQL := 'Values(';
566 <  Separator := ':';
567 <  for I := 0 to FieldNames.Count - 1 do
568 <    begin
569 <       InsertSQL := InsertSQL + Separator +  FieldNames[I] ;
570 <       Separator := ', :';
571 <    end;
572 <  InsertSQL := InsertSQL + ')';
573 <  SQL.Add(InsertSQL);
574 < end;
575 <
576 < procedure TIBSystemTables.GenerateModifySQL(TableName: string; QuotedStrings: boolean;
577 <          FieldNames,SQL: TStrings);
578 < var UpdateSQL: string;
579 <    Separator: string;
580 <    I: integer;
581 < begin
582 <  SQL.Clear;
583 <  Separator := #$0d#$0a'  A.';
584 <  UpdateSQL := 'Update ' + TableName + ' A Set ';
585 <  for I := 0 to FieldNames.Count - 1 do
586 <    begin
587 <      if QuotedStrings then
588 <        UpdateSQL := UpdateSQL + Separator + '"' + FieldNames[I] + '" = :' + FieldNames[I]
589 <      else
590 <        UpdateSQL := UpdateSQL + Separator + FieldNames[I] + ' = :' + FieldNames[I];
591 <      Separator := ','#$0d#$0a'  A.';
592 <    end;
593 <  SQL.Add(UpdateSQL);
594 <  AddWhereClause(TableName,QuotedStrings,SQL,true)
595 < end;
596 <
597 < procedure TIBSystemTables.GenerateDeleteSQL(TableName: string; QuotedStrings: boolean; SQL: TStrings);
598 < begin
599 <  SQL.Clear;
600 <  SQL.Add('Delete From ' + TableName + ' A');
601 <  AddWhereClause(TableName,QuotedStrings,SQL)
602 < end;
603 <
604 < procedure TIBSystemTables.GenerateExecuteSQL(ProcName: string;
605 <  QuotedStrings: boolean; ExecuteOnly: boolean; InputParams, OutputParams,
606 <  ExecuteSQL: TStrings);
607 < var SQL: string;
608 <    I: integer;
609 <    Separator: string;
610 < begin
611 <  Separator := '';
612 <  if not ExecuteOnly and (OutputParams.Count > 0) then //Select Query
613 <  begin
614 <    SQL := 'Select ';
615 <    for I := 0 to OutputParams.Count - 1 do
616 <    begin
617 <      if QuotedStrings then
618 <        SQL := SQL + Separator + '"' + OutputParams[I] + '"'
619 <      else
620 <        SQL := SQL + Separator + OutputParams[I];
621 <      Separator := ', ';
622 <    end;
623 <    SQL := SQL + ' From ' + ProcName;
624 <    if InputParams.Count > 0 then
625 <    begin
626 <      Separator := '(:';
627 <      for I := 0 to InputParams.Count - 1 do
628 <      begin
629 <        SQL := SQL + Separator + InputParams[I];
630 <        Separator := ', :';
631 <      end;
632 <      SQL := SQL + ')'
633 <    end
634 <  end
635 <  else // Execute Procedure
636 <  begin
637 <    if QuotedStrings then
638 <      SQL := 'Execute Procedure "' + ProcName + '"'
639 <    else
640 <      SQL := 'Execute Procedure ' + ProcName;
641 <    if InputParams.Count > 0 then
642 <    begin
643 <      Separator := ' :';
644 <      for I := 0 to InputParams.Count - 1 do
645 <      begin
646 <        if QuotedStrings then
647 <          SQL := SQL + Separator + '"' + InputParams[I] + '"'
648 <        else
649 <          SQL := SQL + Separator + InputParams[I];
650 <        Separator := ', :';
651 <      end;
652 <    end
653 <  end;
654 <  ExecuteSQL.Text := SQL
655 < end;
656 <
657 < function TIBSystemTables.GetStatementType(SQL: string; var IsStoredProcedure: boolean): TIBSQLTypes;
658 < var TableName: string;
659 < begin
660 <  Result := sqlUnknown;
661 <  if not assigned(FTestSQL.Database) or not FTestSQL.Database.Connected or
662 <    not assigned(FTestSQL.Transaction) or (Trim(SQL) = '') then
663 <    Exit;
664 <  IsStoredProcedure := false;
665 <  FTestSQL.SQL.Text := SQL;
666 <  try
667 <    FTestSQL.Prepare;
668 <    Result := FTestSQL.SQLType
669 <  except on E:EIBError do
670 < //      ShowMessage(E.Message);
671 <  end;
672 <  if (Result = SQLSelect) and (FTestSQL.Current.Count > 0)  then
673 <  begin
674 <    TableName := strpas(FTestSQL.Current.Vars[0].Data^.relname);
675 <    FTestSQL.SQL.Text := sqlCheckProcedureNames;
676 <    FTestSQL.Prepare;
677 <    FTestSQL.ParamByName('ProcName').AsString := TableName;
678 <    FTestSQL.ExecQuery;
679 <    try
680 <      IsStoredProcedure := not FTestSQL.EOF;
681 <    finally
682 <      FTestSQL.Close
683 <    end;
684 <  end;
685 < end;
686 <
687 < function TIBSystemTables.GetFieldNames(FieldList: TListBox): TStrings;
688 < var I: integer;
689 < begin
690 <  Result := TStringList.Create;
691 <  try
692 <    if FieldList.SelCount = 0 then
693 <      Result.Assign(FieldList.Items)
694 <    else
695 <      for I := 0 to FieldList.Items.Count - 1 do
696 <        if FieldList.Selected[I] then
697 <          Result.Add(FieldList.Items[I]);
698 <  except
699 <    Result.Free;
700 <    raise
701 <  end;
702 < end;
703 <
704 < procedure TIBSystemTables.TestSQL(SQL: string);
705 < begin
706 <  if not assigned(FTestSQL.Database) or not FTestSQL.Database.Connected or
707 <    not assigned(FTestSQL.Transaction) then
708 <  begin
709 <    Messagedlg('No Database Connected',mtError,[mbOK],0);
710 <    Exit;
711 <  end;
712 <  FTestSQL.SQL.Text := SQL;
713 <  try
714 <    FTestSQL.Prepare;
715 <    ShowMessage('SQL '+ GetSQLType(FTestSQL.SQLType) + ' Statement Looks OK');
716 <  except on E:EIBError do
717 <      ShowMessage(E.Message);
718 <  end;
719 < end;
720 <
721 < end.
722 <
1 > (*
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 Tony Whyman, MWA Software
19 > *  (http://www.mwasoftware.co.uk).
20 > *
21 > *  All Rights Reserved.
22 > *
23 > *  Contributor(s): ______________________________________.
24 > *
25 > *)
26 >
27 > unit IBSystemTables;
28 >
29 > {$mode objfpc}{$H+}
30 >
31 > interface
32 >
33 > uses
34 >  Classes, SysUtils, IBSQL, IBDatabase, StdCtrls;
35 >
36 > type
37 >
38 >  { TIBSystemTables }
39 >
40 >  TIBSystemTables = class
41 >  private
42 >    FGetTableNames: TIBSQL;
43 >    FGetFieldNames: TIBSQL;
44 >    FGetPrimaryKeys: TIBSQL;
45 >    FTestSQL: TIBSQL;
46 >    FTableAndColumnSQL: TIBSQL;
47 >    FGetGeneratorsSQL: TIBSQL;
48 >    FGetProcedures: TIBSQL;
49 >    FGetProcedureParams: TIBSQL;
50 >    FGetProcedureInfo: TIBSQL;
51 >    function GetSQLType(SQLType: TIBSQLTypes): string;
52 >    procedure AddWhereClause(TableName: string; QuotedStrings: boolean; SQL: TStrings;
53 >       UseOldValues: boolean = false);
54 >    procedure GetProcParams(ProcName: string; ParamList: TStrings; InputParams: boolean); overload;
55 >    function GetWord(S: string; WordNo: integer): string;
56 > public
57 >    constructor Create;
58 >    destructor Destroy; override;
59 >    procedure SelectDatabase(Database: TIBDatabase; Transaction: TIBTransaction);
60 >    procedure GetTableNames(TableNames: TStrings);
61 >    procedure GetFieldNames(TableName: string; FieldNames: TStrings;
62 >              IncludePrimaryKeys:boolean=true; IncludeReadOnlyFields: boolean = true);
63 >    procedure GetPrimaryKeys(TableName: string; PrimaryKeys: TStrings);
64 >    procedure GetTableAndColumns(SelectSQL: string; var FirstTableName: string;
65 >                Columns: TStrings);
66 >    procedure GetProcedureNames(ProcNames: TStrings; WithOutputParams: boolean=false);
67 >    procedure GetProcParams(ProcName: string; var ExecuteOnly: boolean;
68 >                            InputParams, OutputParams: TStrings); overload;
69 >    procedure GetGenerators(GeneratorNames: TStrings);
70 >    procedure GenerateSelectSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
71 >    procedure GenerateRefreshSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
72 >    procedure GenerateInsertSQL(TableName: string; QuotedStrings: boolean; FieldNames, SQL: TStrings);
73 >    procedure GenerateModifySQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
74 >    procedure GenerateDeleteSQL(TableName: string; QuotedStrings: boolean; SQL: TStrings);
75 >    procedure GenerateExecuteSQL(ProcName: string; QuotedStrings: boolean; ExecuteOnly: boolean;
76 >              InputParams, OutputParams, ExecuteSQL: TStrings);
77 >    function GetStatementType(SQL: string; var IsStoredProcedure: boolean): TIBSQLTypes;
78 >    function GetFieldNames(FieldList: TListBox): TStrings;
79 >    procedure TestSQL(SQL: string);
80 >  end;
81 >
82 > implementation
83 >
84 > uses IB, Dialogs;
85 >
86 > { TIBSystemTables }
87 >
88 > const
89 >  sqlGETTABLES = 'Select Trim(RDB$RELATION_NAME) as TableName From RDB$RELATIONS ' +
90 >                 'Where RDB$SYSTEM_FLAG = 0 ' +
91 >                 'Order by 1';
92 >
93 >  sqlGETALLFIELDS = 'Select Trim(RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS ' +
94 >                 'Where RDB$RELATION_NAME = :TableName ' +
95 >                 'order by RDB$FIELD_POSITION asc ';
96 >
97 >  sqlGETFIELDS = 'Select Trim(RF.RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
98 >                 'JOIN RDB$FIELDS B On B.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
99 >                 'Where RF.RDB$RELATION_NAME = :TableName and B.RDB$COMPUTED_SOURCE is NULL ' +
100 >                 'order by RF.RDB$FIELD_POSITION asc ';
101 >
102 >  sqlGETPRIMARYKEYS = 'Select Trim(S.RDB$FIELD_NAME) as ColumnName From '+
103 >                      '(Select RDB$INDEX_NAME,RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS Order by RDB$FIELD_POSITION ASC) S ' +
104 >                      'JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME ' +
105 >                      'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and RDB$RELATION_NAME = :TableName';
106 >
107 >  sqlUPDATEFIELDS = 'Select Trim(RF.RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
108 >                    'JOIN RDB$FIELDS B On B.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
109 >                    'Where RF.RDB$RELATION_NAME = :TableName  and RF.RDB$FIELD_NAME not in ' +
110 >                    '(Select RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS S JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME '+
111 >                     'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and C.RDB$RELATION_NAME = RF.RDB$RELATION_NAME) and B.RDB$COMPUTED_SOURCE is NULL ' +
112 >                     'order by 1 asc ';
113 >
114 >  sqlALLUPDATEFIELDS = 'Select Trim(RDB$FIELD_NAME) as ColumnName FROM RDB$RELATION_FIELDS RF ' +
115 >                    'Where RF.RDB$RELATION_NAME = :TableName  and RDB$FIELD_NAME not in ' +
116 >                    '(Select RDB$FIELD_NAME FROM RDB$INDEX_SEGMENTS S JOIN RDB$RELATION_CONSTRAINTS C On C.RDB$INDEX_NAME = S.RDB$INDEX_NAME '+
117 >                     'Where C.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' and C.RDB$RELATION_NAME = RF.RDB$RELATION_NAME)' +
118 >                     'order by 1 asc ';
119 >
120 >  sqlGETGENERATORNAMES = 'Select RDB$GENERATOR_NAME FROM RDB$GENERATORS '+
121 >                         'Where RDB$SYSTEM_FLAG = 0 '+
122 >                         'Order by 1 asc';
123 >
124 >  sqlGETPROCEDURES = 'Select Trim(RDB$PROCEDURE_NAME) as ProcName, RDB$PROCEDURE_INPUTS, '+
125 >                     'RDB$PROCEDURE_OUTPUTS From RDB$PROCEDURES '+
126 >                     'Where RDB$SYSTEM_FLAG = 0 and RDB$PROCEDURE_TYPE <= :ProcType Order by 1 asc';
127 >
128 >  sqlGETPROCPARAM  = 'Select Trim(P.RDB$PARAMETER_NAME) as ParamName '+
129 >                     'From RDB$PROCEDURE_PARAMETERS P '+
130 >                     'JOIN RDB$FIELDS F On F.RDB$FIELD_NAME = P.RDB$FIELD_SOURCE '+
131 >                     'Where P.RDB$SYSTEM_FLAG = 0 and P.RDB$PROCEDURE_NAME = :ProcName and P.RDB$PARAMETER_TYPE = :type '+
132 >                     'Order by P.RDB$PARAMETER_NUMBER asc';
133 >
134 >  sqlCheckProcedureNames = 'Select * From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
135 >
136 >  sqlGETPROCEDUREINFO = 'Select RDB$PROCEDURE_TYPE From RDB$PROCEDURES Where Upper(Trim(RDB$PROCEDURE_NAME)) = Upper(:ProcName)';
137 >
138 > function TIBSystemTables.GetSQLType(SQLType: TIBSQLTypes): string;
139 > begin
140 >  case SQLType of
141 >  SQLUnknown:              Result := 'Unknown';
142 >  SQLSelect:               Result := 'Select';
143 >  SQLInsert:               Result := 'Insert';
144 >  SQLUpdate:               Result := 'Update';
145 >  SQLDelete:               Result := 'Delete';
146 >  SQLDDL:                  Result := 'DDL';
147 >  SQLGetSegment:           Result := 'GetSegment';
148 >  SQLPutSegment:           Result := 'PutSegment';
149 >  SQLExecProcedure:        Result := 'Execute Procedure';
150 >  SQLStartTransaction:     Result := 'StartTransaction';
151 >  SQLCommit:               Result := 'Commit';
152 >  SQLRollback:             Result := 'Rollback';
153 >  SQLSelectForUpdate:      Result := 'Select for Update';
154 >  SQLSetGenerator:         Result := 'Set Generator';
155 >  end;
156 > end;
157 >
158 > procedure TIBSystemTables.AddWhereClause(TableName: string;
159 >  QuotedStrings: boolean; SQL: TStrings; UseOldValues: boolean);
160 > var WhereClause: string;
161 >    Separator: string;
162 >    Count: integer;
163 >    Prefix: string;
164 > begin
165 >  if not assigned(FGetPrimaryKeys.Database) or not FGetPrimaryKeys.Database.Connected or
166 >    not assigned(FGetPrimaryKeys.Transaction) then
167 >    Exit;
168 >  Count := 0;
169 >  WhereClause := 'Where';
170 >  Separator := ' A.';
171 >  if UseOldValues then
172 >    Prefix := ':OLD_'
173 >  else
174 >    Prefix := ':';
175 >  FGetPrimaryKeys.Prepare;
176 >  FGetPrimaryKeys.ParamByName('TableName').AsString := TableName;
177 >  FGetPrimaryKeys.ExecQuery;
178 >  try
179 >    while not FGetPrimaryKeys.EOF do
180 >    begin
181 >      Inc(Count);
182 >      if QuotedStrings then
183 >        WhereClause := WhereClause + Separator + '"' + FGetPrimaryKeys.FieldByName('ColumnName').AsString +
184 >               '" = ' + Prefix+ FGetPrimaryKeys.FieldByName('ColumnName').AsString
185 >      else
186 >        WhereClause := WhereClause + Separator + FGetPrimaryKeys.FieldByName('ColumnName').AsString +
187 >               ' = ' + Prefix + FGetPrimaryKeys.FieldByName('ColumnName').AsString;
188 >      Separator := ' AND A.';
189 >      FGetPrimaryKeys.Next
190 >    end;
191 >  finally
192 >    FGetPrimaryKeys.Close
193 >  end;
194 >  if Count > 0 then
195 >    SQL.Add(WhereClause)
196 > end;
197 >
198 > procedure TIBSystemTables.GetProcParams(ProcName: string; ParamList: TStrings;
199 >  InputParams: boolean);
200 > begin
201 >  if not assigned(FGetProcedureParams.Database) or not FGetProcedureParams.Database.Connected or
202 >    not assigned(FGetProcedureParams.Transaction) then
203 >    Exit;
204 >  ParamList.Clear;
205 >  with FGetProcedureParams do
206 >  begin
207 >    with Transaction do
208 >      if not InTransaction then StartTransaction;
209 >    Prepare;
210 >    ParamByName('ProcName').AsString := ProcName;
211 >    if InputParams then
212 >      ParamByName('type').AsInteger := 0
213 >    else
214 >      ParamByName('type').AsInteger := 1;
215 >    ExecQuery;
216 >    try
217 >      while not EOF do
218 >      begin
219 >        ParamList.Add(FieldByName('ParamName').AsString);
220 >        Next;
221 >      end;
222 >    finally
223 >      Close
224 >    end;
225 >  end;
226 > end;
227 >
228 > function TIBSystemTables.GetWord(S: string; WordNo: integer): string;
229 > const
230 >    SpaceChars = [' ',#$0a,#$0d,#$09,'('];
231 > var I: integer;
232 >    StartIdx: integer;
233 >    InWhiteSpace: boolean;
234 > begin
235 >  Result := '';
236 >  StartIdx := 1;
237 >  InWhiteSpace := true;
238 >  for I := 1 to Length(S) do
239 >  begin
240 >    if InWhiteSpace then
241 >    begin
242 >      if not (S[I] in SpaceChars) then
243 >      begin
244 >        StartIdx := I;
245 >        InWhiteSpace := false
246 >      end
247 >    end
248 >    else
249 >    begin
250 >      if S[I] in SpaceChars then
251 >      begin
252 >        Dec(WordNo);
253 >        if WordNo = 0 then
254 >        begin
255 >          Result := System.copy(S,StartIdx,I - StartIdx);
256 >          Exit
257 >        end;
258 >        InWhiteSpace := true
259 >      end
260 >    end
261 >  end;
262 > end;
263 >
264 > constructor TIBSystemTables.Create;
265 > begin
266 >  FGetTableNames := TIBSQL.Create(nil);
267 >  FGetFieldNames := TIBSQL.Create(nil);
268 >  FGetPrimaryKeys := TIBSQL.Create(nil);
269 >  FGetProcedures := TIBSQL.Create(nil);
270 >  FTestSQL := TIBSQL.Create(nil);
271 >  FTableAndColumnSQL := TIBSQL.Create(nil);
272 >  FGetGeneratorsSQL := TIBSQL.Create(nil);
273 >  FGetProcedureParams := TIBSQL.Create(nil);
274 >  FGetProcedureInfo := TIBSQL.Create(nil);
275 > end;
276 >
277 > destructor TIBSystemTables.Destroy;
278 > begin
279 >  if assigned(FGetFieldNames) then FGetFieldNames.Free;
280 >  if assigned(FGetTableNames) then FGetTableNames.Free;
281 >  if assigned(FTestSQL) then FTestSQL.Free;
282 >  if assigned(FGetPrimaryKeys) then FGetPrimaryKeys.Free;
283 >  if assigned(FTableAndColumnSQL) then FTableAndColumnSQL.Free;
284 >  if assigned(FGetGeneratorsSQL) then FGetGeneratorsSQL.Free;
285 >  if assigned(FGetProcedures) then FGetProcedures.Free;
286 >  if assigned(FGetProcedureParams) then FGetProcedureParams.Free;
287 >  if assigned(FGetProcedureInfo) then FGetProcedureInfo.Free;
288 >  inherited Destroy;
289 > end;
290 >
291 > procedure TIBSystemTables.SelectDatabase(Database: TIBDatabase;
292 >  Transaction: TIBTransaction);
293 > begin
294 >    FGetTableNames.Database := Database;
295 >    FGetTableNames.Transaction := Transaction;
296 >    FGetTableNames.SQL.Text := sqlGETTABLES;
297 >    FGetFieldNames.Database := Database;
298 >    FGetFieldNames.Transaction := Transaction;
299 >    FGetFieldNames.SQL.Text := sqlGETFIELDS;
300 >    FTestSQL.Database := Database;
301 >    FTestSQL.Transaction := Transaction;
302 >    FGetPrimaryKeys.Database := Database;
303 >    FGetPrimaryKeys.Transaction := Transaction;
304 >    FGetPrimaryKeys.SQL.Text := sqlGETPRIMARYKEYS;
305 >    FTableAndColumnSQL.Database := Database;
306 >    FTableAndColumnSQL.Transaction := Transaction;
307 >    FGetGeneratorsSQL.Database := Database;
308 >    FGetGeneratorsSQL.Transaction := Transaction;
309 >    FGetGeneratorsSQL.SQL.Text := sqlGETGENERATORNAMES;
310 >    FGetProcedureParams.Database := Database;
311 >    FGetProcedureParams.Transaction := Transaction;
312 >    FGetProcedureParams.SQL.Text := sqlGETPROCPARAM;
313 >    FGetProcedureInfo.Database := Database;
314 >    FGetProcedureInfo.Transaction := Transaction;
315 >    FGetProcedureInfo.SQL.Text := sqlGETPROCEDUREINFO;
316 >    FGetProcedures.Database := Database;
317 >    FGetProcedures.Transaction := Transaction;
318 >    FGetProcedures.SQL.Text := sqlGETPROCEDURES;
319 > end;
320 >
321 > procedure TIBSystemTables.GetTableNames(TableNames: TStrings);
322 > begin
323 >  if not assigned(FGetTableNames.Database) or not FGetTableNames.Database.Connected or
324 >    not assigned(FGetTableNames.Transaction) then
325 >    Exit;
326 >  with FGetTableNames.Transaction do
327 >    if not InTransaction then StartTransaction;
328 >  TableNames.Clear;
329 >  FGetTableNames.ExecQuery;
330 >  try
331 >    while not FGetTableNames.EOF do
332 >    begin
333 >      TableNames.Add(FGetTableNames.FieldByName('TableName').AsString);
334 >      FGetTableNames.Next
335 >    end;
336 >  finally
337 >    FGetTableNames.Close
338 >  end;
339 > end;
340 >
341 > procedure TIBSystemTables.GetFieldNames(TableName: string;
342 >  FieldNames: TStrings; IncludePrimaryKeys: boolean;
343 >  IncludeReadOnlyFields: boolean);
344 > begin
345 >  if not assigned(FGetFieldNames.Database) or not FGetFieldNames.Database.Connected or
346 >    not assigned(FGetFieldNames.Transaction) then
347 >    Exit;
348 >  with FGetFieldNames.Transaction do
349 >    if not InTransaction then StartTransaction;
350 >  FieldNames.Clear;
351 >  if IncludePrimaryKeys then
352 >  begin
353 >    if IncludeReadOnlyFields then
354 >      FGetFieldNames.SQL.Text := sqlGETALLFIELDS
355 >    else
356 >      FGetFieldNames.SQL.Text := sqlGETFIELDS
357 >  end
358 >  else
359 >  if  IncludeReadOnlyFields then
360 >    FGetFieldNames.SQL.Text := sqlALLUPDATEFIELDS
361 >  else
362 >      FGetFieldNames.SQL.Text := sqlUPDATEFIELDS;
363 >  FGetFieldNames.Prepare;
364 >  FGetFieldNames.ParamByName('TableName').AsString := TableName;
365 >  FGetFieldNames.ExecQuery;
366 >  try
367 >    while not FGetFieldNames.EOF do
368 >    begin
369 >      FieldNames.Add(FGetFieldNames.FieldByName('ColumnName').AsString);
370 >      FGetFieldNames.Next
371 >    end;
372 >  finally
373 >    FGetFieldNames.Close
374 >  end;
375 > end;
376 >
377 > procedure TIBSystemTables.GetPrimaryKeys(TableName: string; PrimaryKeys: TStrings);
378 > begin
379 >  if not assigned(FGetPrimaryKeys.Database) or not FGetPrimaryKeys.Database.Connected or
380 >    not assigned(FGetPrimaryKeys.Transaction) then
381 >    Exit;
382 >  with FGetPrimaryKeys.Transaction do
383 >    if not InTransaction then StartTransaction;
384 >  PrimaryKeys.Clear;
385 >  FGetPrimaryKeys.Prepare;
386 >  FGetPrimaryKeys.ParamByName('TableName').AsString := TableName;
387 >  FGetPrimaryKeys.ExecQuery;
388 >  try
389 >    while not FGetPrimaryKeys.EOF do
390 >    begin
391 >      PrimaryKeys.Add(FGetPrimaryKeys.FieldByName('ColumnName').AsString);
392 >      FGetPrimaryKeys.Next
393 >    end;
394 >  finally
395 >    FGetPrimaryKeys.Close
396 >  end;
397 > end;
398 >
399 > procedure TIBSystemTables.GetTableAndColumns(SelectSQL: string;
400 >  var FirstTableName: string; Columns: TStrings);
401 > var I: integer;
402 > begin
403 >  FirstTableName := '';
404 >  if not assigned(FTableAndColumnSQL.Database) or not FTableAndColumnSQL.Database.Connected or
405 >    not assigned(FTableAndColumnSQL.Transaction) or (Trim(SelectSQL) = '') then
406 >    Exit;
407 >  with FTableAndColumnSQL.Transaction do
408 >    if not InTransaction then StartTransaction;
409 >  FTableAndColumnSQL.SQL.Text := SelectSQL;
410 >  try
411 >    FTableAndColumnSQL.Prepare;
412 >    case FTableAndColumnSQL.SQLType of
413 >    SQLSelect:
414 >      begin
415 >        if FTableAndColumnSQL.Current.Count > 0 then
416 >          FirstTableName := strpas(FTableAndColumnSQL.Current.Vars[0].Data^.relname)
417 >        else
418 >          FirstTableName := '';
419 >        if assigned(Columns) then
420 >        begin
421 >          Columns.Clear;
422 >          for I := 0 to FTableAndColumnSQL.Current.Count - 1 do
423 >              Columns.Add(FTableAndColumnSQL.Current.Vars[I].Name)
424 >        end;
425 >      end;
426 >    { If not a select statement then return table or procedure name
427 >      as First Table Name }
428 >    SQLUpdate:
429 >      FirstTableName := GetWord(SelectSQL,2);
430 >
431 >    else
432 >      FirstTableName := GetWord(SelectSQL,3);
433 >    end
434 >  except on E:EIBError do
435 > //      ShowMessage(E.Message);
436 >  end;
437 > end;
438 >
439 > procedure TIBSystemTables.GetProcedureNames(ProcNames: TStrings; WithOutputParams: boolean);
440 > begin
441 >  if not assigned(FGetProcedures.Database) or not FGetProcedures.Database.Connected or
442 >    not assigned(FGetProcedures.Transaction) then
443 >    Exit;
444 >  ProcNames.Clear;
445 >  with FGetProcedures do
446 >  begin
447 >    with Transaction do
448 >      if not InTransaction then StartTransaction;
449 >    Prepare;
450 >    if WithOutputParams then
451 >      ParamByName('ProcType').AsInteger := 1
452 >    else
453 >      ParamByName('ProcType').AsInteger := 2;
454 >    ExecQuery;
455 >    try
456 >      while not EOF do
457 >      begin
458 >        ProcNames.Add(FieldByName('ProcName').AsString);
459 >        Next;
460 >      end;
461 >    finally
462 >      Close
463 >    end;
464 >  end;
465 > end;
466 >
467 > procedure TIBSystemTables.GetProcParams(ProcName: string;
468 >  var ExecuteOnly: boolean; InputParams, OutputParams: TStrings);
469 > begin
470 >  GetProcParams(ProcName,InputParams,true);
471 >  GetProcParams(ProcName,OutputParams,false);
472 >  ExecuteOnly := OutputParams.Count = 0;
473 >  if not ExecuteOnly then
474 >  with FGetProcedureInfo do
475 >  begin
476 >    with Transaction do
477 >      if not InTransaction then StartTransaction;
478 >    Prepare;
479 >    ParamByName('ProcName').AsString := ProcName;
480 >    ExecQuery;
481 >    try
482 >      if not EOF then
483 >        ExecuteOnly := FieldByName('RDB$PROCEDURE_TYPE').AsInteger = 2
484 >    finally
485 >      Close
486 >    end;
487 >  end;
488 > end;
489 >
490 > procedure TIBSystemTables.GetGenerators(GeneratorNames: TStrings);
491 > begin
492 >  if not assigned(FGetGeneratorsSQL.Database) or not FGetGeneratorsSQL.Database.Connected or
493 >    not assigned(FGetGeneratorsSQL.Transaction) then
494 >    Exit;
495 >  GeneratorNames.Clear;
496 >  with FGetGeneratorsSQL do
497 >  begin
498 >    with Transaction do
499 >      if not InTransaction then StartTransaction;
500 >    ExecQuery;
501 >    try
502 >      while not EOF do
503 >      begin
504 >        GeneratorNames.Add(FieldByName('RDB$GENERATOR_NAME').AsString);
505 >        Next;
506 >      end;
507 >    finally
508 >      Close
509 >    end;
510 >  end;
511 >
512 > end;
513 >
514 > procedure TIBSystemTables.GenerateSelectSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
515 > var SelectSQL: string;
516 >    Separator : string;
517 >    I: integer;
518 > begin
519 >  SQL.Clear;
520 >  if not assigned(FGetFieldNames.Database) or not FGetFieldNames.Database.Connected or
521 >    not assigned(FGetFieldNames.Transaction) then
522 >  begin
523 >    Messagedlg('No Database Connected',mtError,[mbOK],0);
524 >    Exit;
525 >  end;
526 >  SelectSQL := 'Select';
527 >  Separator := ' A.';
528 >  for I := 0 to FieldNames.Count - 1 do
529 >  begin
530 >    if QuotedStrings then
531 >      SelectSQL := SelectSQL + Separator + '"' + FieldNames[I] + '"'
532 >    else
533 >      SelectSQL := SelectSQL + Separator + FieldNames[I];
534 >    Separator := ', A.';
535 >  end;
536 >  SelectSQL := SelectSQL + ' From ' + TableName + ' A';
537 >  SQL.Add(SelectSQL);
538 > end;
539 >
540 > procedure TIBSystemTables.GenerateRefreshSQL(TableName: string; QuotedStrings: boolean; FieldNames,SQL: TStrings);
541 > begin
542 >  GenerateSelectSQL(TableName,QuotedStrings,FieldNames,SQL);
543 >  AddWhereClause(TableName,QuotedStrings,SQL)
544 > end;
545 >
546 > procedure TIBSystemTables.GenerateInsertSQL(TableName: string;
547 >  QuotedStrings: boolean; FieldNames,SQL: TStrings);
548 > var InsertSQL: string;
549 >    Separator: string;
550 >    I: integer;
551 > begin
552 >  SQL.Clear;
553 >  InsertSQL := 'Insert Into ' + TableName + '(';
554 >  Separator := '';
555 >  for I := 0 to FieldNames.Count - 1 do
556 >    begin
557 >      if QuotedStrings then
558 >         InsertSQL := InsertSQL + Separator + '"' + FieldNames[I] + '"'
559 >      else
560 >         InsertSQL := InsertSQL + Separator +  FieldNames[I] ;
561 >      Separator := ', ';
562 >    end;
563 >  InsertSQL := InsertSQL + ')';
564 >  SQL.Add(InsertSQL);
565 >  InsertSQL := 'Values(';
566 >  Separator := ':';
567 >  for I := 0 to FieldNames.Count - 1 do
568 >    begin
569 >       InsertSQL := InsertSQL + Separator +  FieldNames[I] ;
570 >       Separator := ', :';
571 >    end;
572 >  InsertSQL := InsertSQL + ')';
573 >  SQL.Add(InsertSQL);
574 > end;
575 >
576 > procedure TIBSystemTables.GenerateModifySQL(TableName: string; QuotedStrings: boolean;
577 >          FieldNames,SQL: TStrings);
578 > var UpdateSQL: string;
579 >    Separator: string;
580 >    I: integer;
581 > begin
582 >  SQL.Clear;
583 >  Separator := #$0d#$0a'  A.';
584 >  UpdateSQL := 'Update ' + TableName + ' A Set ';
585 >  for I := 0 to FieldNames.Count - 1 do
586 >    begin
587 >      if QuotedStrings then
588 >        UpdateSQL := UpdateSQL + Separator + '"' + FieldNames[I] + '" = :' + FieldNames[I]
589 >      else
590 >        UpdateSQL := UpdateSQL + Separator + FieldNames[I] + ' = :' + FieldNames[I];
591 >      Separator := ','#$0d#$0a'  A.';
592 >    end;
593 >  SQL.Add(UpdateSQL);
594 >  AddWhereClause(TableName,QuotedStrings,SQL,true)
595 > end;
596 >
597 > procedure TIBSystemTables.GenerateDeleteSQL(TableName: string; QuotedStrings: boolean; SQL: TStrings);
598 > begin
599 >  SQL.Clear;
600 >  SQL.Add('Delete From ' + TableName + ' A');
601 >  AddWhereClause(TableName,QuotedStrings,SQL)
602 > end;
603 >
604 > procedure TIBSystemTables.GenerateExecuteSQL(ProcName: string;
605 >  QuotedStrings: boolean; ExecuteOnly: boolean; InputParams, OutputParams,
606 >  ExecuteSQL: TStrings);
607 > var SQL: string;
608 >    I: integer;
609 >    Separator: string;
610 > begin
611 >  Separator := '';
612 >  if not ExecuteOnly and (OutputParams.Count > 0) then //Select Query
613 >  begin
614 >    SQL := 'Select ';
615 >    for I := 0 to OutputParams.Count - 1 do
616 >    begin
617 >      if QuotedStrings then
618 >        SQL := SQL + Separator + '"' + OutputParams[I] + '"'
619 >      else
620 >        SQL := SQL + Separator + OutputParams[I];
621 >      Separator := ', ';
622 >    end;
623 >    SQL := SQL + ' From ' + ProcName;
624 >    if InputParams.Count > 0 then
625 >    begin
626 >      Separator := '(:';
627 >      for I := 0 to InputParams.Count - 1 do
628 >      begin
629 >        SQL := SQL + Separator + InputParams[I];
630 >        Separator := ', :';
631 >      end;
632 >      SQL := SQL + ')'
633 >    end
634 >  end
635 >  else // Execute Procedure
636 >  begin
637 >    if QuotedStrings then
638 >      SQL := 'Execute Procedure "' + ProcName + '"'
639 >    else
640 >      SQL := 'Execute Procedure ' + ProcName;
641 >    if InputParams.Count > 0 then
642 >    begin
643 >      Separator := ' :';
644 >      for I := 0 to InputParams.Count - 1 do
645 >      begin
646 >        if QuotedStrings then
647 >          SQL := SQL + Separator + '"' + InputParams[I] + '"'
648 >        else
649 >          SQL := SQL + Separator + InputParams[I];
650 >        Separator := ', :';
651 >      end;
652 >    end
653 >  end;
654 >  ExecuteSQL.Text := SQL
655 > end;
656 >
657 > function TIBSystemTables.GetStatementType(SQL: string; var IsStoredProcedure: boolean): TIBSQLTypes;
658 > var TableName: string;
659 > begin
660 >  Result := sqlUnknown;
661 >  if not assigned(FTestSQL.Database) or not FTestSQL.Database.Connected or
662 >    not assigned(FTestSQL.Transaction) or (Trim(SQL) = '') then
663 >    Exit;
664 >  IsStoredProcedure := false;
665 >  FTestSQL.SQL.Text := SQL;
666 >  try
667 >    FTestSQL.Prepare;
668 >    Result := FTestSQL.SQLType
669 >  except on E:EIBError do
670 > //      ShowMessage(E.Message);
671 >  end;
672 >  if (Result = SQLSelect) and (FTestSQL.Current.Count > 0)  then
673 >  begin
674 >    TableName := strpas(FTestSQL.Current.Vars[0].Data^.relname);
675 >    FTestSQL.SQL.Text := sqlCheckProcedureNames;
676 >    FTestSQL.Prepare;
677 >    FTestSQL.ParamByName('ProcName').AsString := TableName;
678 >    FTestSQL.ExecQuery;
679 >    try
680 >      IsStoredProcedure := not FTestSQL.EOF;
681 >    finally
682 >      FTestSQL.Close
683 >    end;
684 >  end;
685 > end;
686 >
687 > function TIBSystemTables.GetFieldNames(FieldList: TListBox): TStrings;
688 > var I: integer;
689 > begin
690 >  Result := TStringList.Create;
691 >  try
692 >    if FieldList.SelCount = 0 then
693 >      Result.Assign(FieldList.Items)
694 >    else
695 >      for I := 0 to FieldList.Items.Count - 1 do
696 >        if FieldList.Selected[I] then
697 >          Result.Add(FieldList.Items[I]);
698 >  except
699 >    Result.Free;
700 >    raise
701 >  end;
702 > end;
703 >
704 > procedure TIBSystemTables.TestSQL(SQL: string);
705 > begin
706 >  if not assigned(FTestSQL.Database) or not FTestSQL.Database.Connected or
707 >    not assigned(FTestSQL.Transaction) then
708 >  begin
709 >    Messagedlg('No Database Connected',mtError,[mbOK],0);
710 >    Exit;
711 >  end;
712 >  FTestSQL.SQL.Text := SQL;
713 >  try
714 >    FTestSQL.Prepare;
715 >    ShowMessage('SQL '+ GetSQLType(FTestSQL.SQLType) + ' Statement Looks OK');
716 >  except on E:EIBError do
717 >      ShowMessage(E.Message);
718 >  end;
719 > end;
720 >
721 > end.
722 >

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines