ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/design/IBSystemTables.pas
(Generate patch)

Comparing ibx/trunk/design/IBSystemTables.pas (file contents):
Revision 32 by tony, Thu Feb 26 10:33:34 2015 UTC vs.
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines