ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/udr/source/FBUDRController.pas
Revision: 371
Committed: Wed Jan 5 15:21:22 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 80120 byte(s)
Log Message:
Beta Release 0.1

File Contents

# Content
1 (*
2 * Firebird UDR Support (fbudr). The fbudr components provide a set of
3 * Pascal language bindings for the Firebird API in support of server
4 * side User Defined Routines (UDRs). The fbudr package is an extension
5 * to the Firebird Pascal API.
6 *
7 * The contents of this file are subject to the Initial Developer's
8 * Public License Version 1.0 (the "License"); you may not use this
9 * file except in compliance with the License. You may obtain a copy
10 * of the License here:
11 *
12 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
13 *
14 * Software distributed under the License is distributed on an "AS
15 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
16 * implied. See the License for the specific language governing rights
17 * and limitations under the License.
18 *
19 * The Initial Developer of the Original Code is Tony Whyman.
20 *
21 * The Original Code is (C) 2021 Tony Whyman, MWA Software
22 * (http://www.mwasoftware.co.uk).
23 *
24 * All Rights Reserved.
25 *
26 * Contributor(s): ______________________________________.
27 *
28 *)
29 unit FBUDRController;
30
31 {$IFDEF MSWINDOWS}
32 {$DEFINE WINDOWS}
33 {$WRITEABLECONST ON}
34 {$ENDIF}
35
36 {$IFDEF FPC}
37 {$mode delphi}
38 {$codepage UTF8}
39 {$interfaces COM}
40 {$ENDIF}
41
42 interface
43
44 uses
45 Classes, SysUtils, SyncObjs,Firebird, IB, FBUDRIntf, FBSQLData,
46 FB30Statement, IniFiles;
47
48 type
49 {The Controller is based on the UnloadDetector class in <firebird>/src/include/firebird/UdrCppEngine.h
50 It provides the entry point for the library and is also responsible for cleaning
51 up on library unload.
52
53 It order to operate similar to a C++ static class such as UnloadDetector, when
54 instantiated, it saves a reference to itself as a COM interface in a private
55 class var. This is a managed variable and hence automatically initialised to
56 nil, and automatically freed on exit.
57
58 The controller also handles the registration of UDRs, access to a configuration
59 file and logging.
60 }
61
62 TFBUDRControllerLogOption = (loLogFunctions, loLogProcedures, loLogTriggers, loLogFetches,
63 loModifyQueries, loReadOnlyQueries, loDetails);
64 TFBUDRControllerLogOptions = set of TFBUDRControllerLogOption;
65
66 { In order to customise log handling, the logging options may be
67 statically set by overridding the values of the writable constant
68 FBControllerLogOptions, or through configuration file overrides.
69 }
70
71 TFBUDRControllerOptions = record
72 ModuleName: AnsiString;
73 AllowConfigFileOverrides: boolean;
74 LogFileNameTemplate: AnsiString;
75 ConfigFileNameTemplate: AnsiString;
76 ForceWriteJournalEntries: boolean;
77 LogOptions: TFBUDRControllerLogOptions;
78 ThreadSafeLogging: boolean;
79 end;
80
81 {LogFileNameTemplate, ConfigFileName and DebugLogTemplate macros:
82 $LOGDIR = Firebird log directory
83 $UDRDIR = Firebird UDR directory
84 $TEMP = System temp directory
85 $MODULE = Module Name
86 $TIMESTAMP = date/time in "yyyymmddhhnnss format
87 }
88
89 const FBUDRControllerOptions: TFBUDRControllerOptions = (
90 ModuleName: 'untitled';
91 AllowConfigFileOverrides: false;
92 LogFileNameTemplate:'$LOGDIR$TIMESTAMP$MODULE.log';
93 ConfigFileNameTemplate: '$UDRDIR$MODULE.conf';
94 ForceWriteJournalEntries: false;
95 LogOptions: [];
96 ThreadSafeLogging: false);
97
98 {$if declared(TStringArray)}
99 FalseStrings: TStringArray = ['false','no'];
100 TrueStrings: TStringArray = ['true','yes'];
101 {$ifend}
102 type
103
104 { TFBUDRController }
105
106 TFBUDRController = class(TInterfacedObject)
107 private
108 class var FFBController: IUnknown; {A Managed object and hence should be initialised
109 by the compiler to nil. Also, guaranteed to be
110 destoyed on exit. No need for finalization clause.}
111 class var FUDRFactoryList: TStringList;
112 class var FMyUnloadFlag: boolean;
113 function CharSetIDToText(att: IAttachment; id: integer): AnsiString;
114 function GetStrValue(item: TColumnMetaData): Ansistring;
115 function LogOptionsToStr(aLogOptions: TFBUDRControllerLogOptions
116 ): AnsiString;
117 private
118 const sLogFormat = '@%s:%s';
119 private
120 FTheirUnloadFlag: Firebird.BooleanPtr;
121 FLogStream: TStream;
122 FCriticalSection: TCriticalSection;
123 FMaster: IMaster;
124 FMessageBuffer: AnsiString;
125 FConfigFile: TIniFile;
126 FJnlOpenAppend: boolean;
127 function GetDateTimeFmt: AnsiString;
128 procedure RegisterUDRFactories(status: Firebird.IStatus; udrPlugin: Firebird.IUdrPlugin);
129 procedure RegisterUDRFactory(status: Firebird.IStatus; udrPlugin: Firebird.IUdrPlugin;
130 aName: AnsiString; factory: TObject);
131 procedure FreeFactoryList;
132 procedure LoadConfig;
133 public
134 constructor Create(status: Firebird.IStatus; udrPlugin: Firebird.IUdrPlugin;
135 aTheirUnloadFlag: booleanPtr; var aMyUnloadFlag: booleanPtr);
136 destructor Destroy; override;
137 procedure FBSetStatusFromException(E: Exception; aStatus: Firebird.IStatus);
138 function GetLogStream: TStream;
139 function ProcessTemplateMacros(aTemplate: AnsiString): AnsiString;
140 procedure WriteToLog(Msg: AnsiString); overload;
141 procedure WriteToLog(aTitle: AnsiString; Params: IFBUDRInputParams); overload;
142 procedure WriteToLog(aTitle: AnsiString; OutputData: IFBUDROutputData); overload;
143 procedure StartJournaling(context: IFBUDRExternalContext);
144 function HasConfigFile: boolean;
145 function ReadConfigString(Section, Ident, DefaultValue: AnsiString): AnsiString;
146 function ReadConfigInteger(Section, Ident: AnsiString; DefaultValue: integer): integer;
147 function ReadConfigBool(Section, Ident: AnsiString; DefaultValue: boolean): boolean;
148 end;
149
150 TFBUDRInputParams = class(TResults,IFBUDRInputParams);
151 TFBUDROutputParams = class(TSQLParams,IFBUDROutputData);
152
153 {TFBUDROutParamsSQLDA subclasses a TIBXINPUTSQLDA. TIBXINPUTSQLDA is defined
154 in support of executable statements and is usually used to prepare the
155 input parameters to a query. Here, a TFBUDROutParamsSQLDA is used to record the
156 values returned by a function or procedure in the "outMsg" buffer provided
157 when the UDR is invoked.
158 }
159
160 { TFBUDROutParamsSQLDA }
161
162 TFBUDROutParamsSQLDA = class(TIBXINPUTSQLDA) {note semantics reversed}
163 private
164 FBuffer: PByte;
165 FAttachment: IAttachment;
166 FTransaction: ITransaction;
167 protected
168 procedure AllocMessageBuffer(len: integer); override;
169 procedure FreeMessageBuffer; override;
170 function GetAttachment: IAttachment; override;
171 function GetTransaction: ITransaction; override;
172 public
173 {created with the UDR output metadata and a pointer to the outMsg buffer.}
174 constructor Create(context: IFBUDRExternalContext; aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
175
176 {We override CanChangeMetaData to stop a UDR writer trying to change the output
177 metadata and hence invalidate the outMsg buffer.}
178 function CanChangeMetaData: boolean; override;
179
180 {Finalise is called after the UDR completes and copies the output variable values
181 into the outMsg buffer}
182 procedure Finalise;
183 end;
184
185 {TFBUDRTriggerNewValuesSQLDA additionally initialises the field values to
186 those found in the messagebuffer. This is appropriate for "before" triggers
187 only}
188
189 TFBUDRTriggerNewValuesSQLDA = class(TFBUDROutParamsSQLDA)
190 public
191 {created with the UDR output metadata and a pointer to the outMsg buffer.}
192 constructor Create(context: IFBUDRExternalContext; aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
193 end;
194
195 {TFBUDRInParamsSQLDA subclasses TIBXOUTPUTSQLDA. TIBXOUTPUTSQLDA is defined
196 in support of executable statements and is usually used to return either
197 a singleton or multiple rows from a query. Here, a TFBUDRInParamsSQLDA is used to
198 hold the input parameter values to a function, procedure or trigger, as provided
199 in the "inMsg" buffer.
200 }
201
202 { TFBUDRInParamsSQLDA }
203
204 TFBUDRInParamsSQLDA = class(TIBXOUTPUTSQLDA) {note semantics reversed}
205 private
206 FBuffer: PByte;
207 FAttachment: IAttachment;
208 FTransaction: ITransaction;
209 protected
210 procedure AllocMessageBuffer(len: integer); override;
211 procedure FreeMessageBuffer; override;
212 function GetAttachment: IAttachment; override;
213 function GetTransaction: ITransaction; override;
214 public
215 {created with the input messge metadata and a pointer to the inMsg buffer}
216 constructor Create(context: IFBUDRExternalContext;
217 aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
218 end;
219
220 {A TFBUDRFunction object is instantiated by a TUDRFunctionFactory when a
221 "newItem" is requested. This is an abstract class and is subclassed by a
222 UDR writer for each UDR function required. TFBUDRFunction subclasses and their
223 "Routine Name" are registered at initialisation time by the RegisterUDRFunction
224 procedure.
225
226 { TFBUDRFunction }
227
228 { TFBUDRFunction }
229
230 TFBUDRFunction = class(Firebird.IExternalFunctionImpl)
231 private
232 FController: TFBUDRController;
233 FName: AnsiString;
234 FExternalContext: IFBUDRExternalContext;
235 FRoutineMetadata: IFBUDRRoutineMetadata;
236 FFieldNames: TStrings;
237 procedure SetFieldNames(SQLDA: TFBUDRInParamsSQLDA);
238 public
239 constructor Create(aController: TFBUDRController;
240 aName: AnsiString;
241 context: IFBUDRExternalContext;
242 routineMetadata: IFBUDRRoutineMetadata;
243 aFieldNames: TStrings);
244 public
245 {External Function Implementation}
246
247 {Override getCharSet when the function returns strings in a different charset
248 to that used by the database connection.}
249 function getCharSet(context: IFBUDRExternalContext): AnsiString; overload; virtual;
250
251 {Execute must be overridden by each subclass in order to define a new UDR
252 function. The function returns its output value in a variant. The value
253 contained in the variant must be type compatible with the result type in
254 the SQL function declaration.}
255 function Execute(context: IFBUDRExternalContext;
256 ProcMetadata: IFBUDRProcMetadata;
257 InputParams: IFBUDRInputParams;
258 ResultSQLType: cardinal): variant; overload; virtual;
259
260 {alternatively, you can override this version to return any value that ISQLParam
261 can take. The Result is returned as a procedure parameter rather than
262 as a function result}
263 procedure Execute(context: IFBUDRExternalContext;
264 ProcMetadata: IFBUDRProcMetadata;
265 InputParams: IFBUDRInputParams;
266 ReturnValue: ISQLParam); overload; virtual;
267
268 {setup is a class procedure and called by the UDR's Function factory when its
269 setup procedure is called. This is typically called the first time a
270 function factory is first used and may be used to initialise any class vars
271 used by the Execute function. This is normally only required with stateful
272 functions.}
273 class procedure setup(context: IFBUDRExternalContext;
274 metadata: IFBUDRRoutineMetadata;
275 inBuilder: IFBUDRMetadataBuilder;
276 outBuilder: IFBUDRMetadataBuilder); virtual;
277 property Name: AnsiString read FName;
278 public
279 {IExternalFunction}
280 procedure dispose(); override;
281 procedure getCharSet(status: Firebird.IStatus; context: Firebird.IExternalContext;
282 name: PAnsiChar; nameSize: Cardinal); overload; override;
283 procedure execute(status: Firebird.IStatus; context: Firebird.IExternalContext;
284 inMsg: Pointer; outMsg: Pointer); overload; override;
285 end;
286
287 TFBUDRFunctionClass = class of TFBUDRFunction;
288
289 {A new instance of TFBUDRFunctionFactory is instantiated for each UDR function
290 registered with the controller. It is called by the Firebird engine to "setup"
291 each UDR function and to create a new instance of each UDR function.
292 TFBUDRFunctionFactory is used internally by the UDR Controller and may be ignored
293 by a UDR writer.}
294
295 {see <firebird>/src/plugins/udr_engine/UdrEngine.cpp for how Firebird UDR Engine
296 uses the factory classes}
297
298 { TFBUDRFunctionFactory }
299
300 TFBUDRFunctionFactory = class(Firebird.IUdrFunctionFactoryImpl)
301 private
302 FController: TFBUDRController;
303 FName: AnsiString;
304 FFieldNames: TStringList;
305 FFunction: TFBUDRFunctionClass;
306 FFBContext: IFBUDRExternalContext;
307 procedure UpdateFieldNames(att: IAttachment; aFunctionName: AnsiString);
308 public
309 constructor Create(aName: AnsiString; aFunction: TFBUDRFunctionClass);
310 destructor Destroy; override;
311 property Controller: TFBUDRController read FController write FController;
312 public
313 {IUdrFunctionFactory}
314 procedure dispose(); override;
315 procedure setup(status: Firebird.IStatus; context: Firebird.IExternalContext;
316 metadata: Firebird.IRoutineMetadata;
317 inBuilder: Firebird.IMetadataBuilder;
318 outBuilder: Firebird.IMetadataBuilder); override;
319 function newItem(status: Firebird.IStatus; context: Firebird.IExternalContext; metadata:
320 Firebird.IRoutineMetadata): Firebird.IExternalFunction; override;
321 end;
322
323 {A TFBUDRProcedure object is instantiated by a TUDRPRocedureFactory when a
324 "newItem" is requested. This is an abstract class and is the base class for
325 UDR Execute Procedures (TUDRExecuteProcedure) and UDR Select Procedures (TUDRSelectProcedure).
326 }
327
328 { TFBUDRProcedure }
329
330 TFBUDRProcedure = class(Firebird.IExternalProcedureImpl)
331 private
332 FController: TFBUDRController;
333 FName: AnsiString;
334 FExternalContext: IFBUDRExternalContext;
335 FRoutineMetadata: IFBUDRRoutineMetadata;
336 FRefCount: integer;
337 protected
338 FInArgNames: TStrings;
339 FOutArgNames: TStrings;
340 procedure SetFieldNames(SQLDA: TSQLDataArea);
341 public
342 constructor Create(aController: TFBUDRController;
343 aName: AnsiString;
344 context: IFBUDRExternalContext;
345 routineMetadata: IFBUDRRoutineMetadata;
346 aInArgNames, aOutArgNames: TStrings);
347 public
348 {External Procedure Implementation}
349
350 {Override getCharSet when the procedure returns strings in a different charset
351 to that used by the database connection.}
352 function getCharSet(context: IFBUDRExternalContext): AnsiString; overload; virtual;
353
354 {setup is a class procedure and called by the UDR's Procedure factory when its
355 setup procedure is called. This is typically called the first time a
356 procedure factory is first used and may be used to initialise any class vars
357 used by the procedure. This is normally only required with stateful
358 procedures.}
359 class procedure setup(context: IFBUDRExternalContext;
360 metadata: IFBUDRRoutineMetadata;
361 inBuilder: IFBUDRMetadataBuilder;
362 outBuilder: IFBUDRMetadataBuilder); virtual;
363 property Name: AnsiString read FName;
364 public
365 {IExternalProcedure}
366 procedure dispose(); override;
367 procedure getCharSet(status: Firebird.IStatus; context: Firebird.IExternalContext;
368 name: PAnsiChar; nameSize: Cardinal); overload; override;
369 end;
370
371 TFBUDRProcedureClass = class of TFBUDRProcedure;
372
373 {The Firebird UDR model requires that a procedure's "open" function returns a
374 Firebird.IExternalResultSet object. The TFBUDRExternalResultsSet is used to implement
375 this object and is subclassed separately to provide the results set for
376 Execute and Select Procedures.
377 }
378
379 { TFBUDRExternalResultsSet }
380
381 TFBUDRExternalResultsSet = class(Firebird.IExternalResultSetImpl)
382 private
383 FUDRProcedure: TFBUDRProcedure;
384 FOutputDataSQLDA: TFBUDROutParamsSQLDA;
385 FOutputData: IFBUDROutputData;
386 FOutArgNames: TStrings;
387 procedure SetFieldNames(SQLDA: TSQLDataArea);
388 protected
389 procedure Close; virtual;
390 public
391 constructor Create(UDRProcedure: TFBUDRProcedure; context: IFBUDRExternalContext;
392 aOutArgNames: TStrings;
393 metadata: Firebird.IMessageMetadata;
394 outMsg: pointer);
395 destructor Destroy; override;
396 property OutputData: IFBUDROutputData read FOutputData;
397 public
398 {IExternalResultSetImpl}
399 procedure dispose(); override;
400 end;
401
402 {TFBUDRSingletonRow subclasses TFBUDRExternalResultsSet in order to provide the
403 Firebird.IExternalResultSet object returned by an Execute procedure. In a
404 TFBUDRExecuteProcedure, the output parameters are set in the main body of
405 the UDR writer's Execute procedure and are returned to the Firebird engine
406 via the "fetch" function implemented by this object.
407 }
408
409 { TFBUDRSingletonRow }
410
411 TFBUDRSingletonRow = class(TFBUDRExternalResultsSet)
412 private
413 FFetchCalled: boolean;
414 public
415 {IExternalResultSetImpl}
416 function fetch(status: Firebird.IStatus): Boolean; override;
417 end;
418
419 {TFBUDRResultsCursor subclasses TFBUDRExternalResultsSet in order to provide the
420 Firebird.IExternalResultSet object returned by s Select procedure. In a
421 TUDRSelectProcedure, the work is divided into two methods "open" and "fetch".
422 The former initialises procedure, while "fetch" is called to return each row
423 in the output dataset. A "close" nethod may also be provided to perform any
424 tidy up following the last call to "fetch".
425
426 }
427 { TFBUDRResultsCursor }
428
429 TFBUDRResultsCursor = class(TFBUDRExternalResultsSet)
430 private
431 FDone: boolean;
432 protected
433 procedure Close; override;
434 public
435 {IExternalResultSetImpl}
436 function fetch(status: Firebird.IStatus): Boolean; override;
437 end;
438
439 {TFBUDRExecuteProcedure subclasses a TFBUDRProcedure for a UDR Execute Procedure.
440 A TFBUDRExecuteProcedure object is instantiated by a TUDRProcedureFactory when a
441 "newItem" is requested. This is an abstract class and is subclassed by a
442 UDR writer for each UDR Execute procedure required. TFBUDRExecuteProcedure
443 subclasses and their "Routine Name" are registered at initialisation time by
444 the RegisterUDRProcedure procedure.
445 }
446
447 { TFBUDRExecuteProcedure }
448
449 TFBUDRExecuteProcedure = class(TFBUDRProcedure)
450 public
451 {Execute must be overridden by each subclass in order to define a new UDR
452 Execute Procedure. The procedure may read its input parameter values from the
453 InputParams interface, and return the output parameter values using the
454 outputData interface.}
455 procedure Execute(context: IFBUDRExternalContext;
456 ProcMetadata: IFBUDRProcMetadata;
457 InputParams: IFBUDRInputParams;
458 OutputData: IFBUDROutputData); virtual; abstract;
459 public
460 {IExternalProcedure}
461 function open(status: Firebird.IStatus; context: Firebird.IExternalContext;
462 inMsg: Pointer; outMsg: Pointer): Firebird.IExternalResultSet; override;
463 end;
464
465 {TFBUDRSelectProcedure subclasses a TFBUDRProcedure for a UDR Select Procedure.
466 A TFBUDRSelectProcedure object is instantiated by a TUDRProcedureFactory when a
467 "newItem" is requested. This is an abstract class and is subclassed by a
468 UDR writer for each UDR Select procedure required. TFBUDRSelectProcedure
469 subclasses and their "Routine Name" are registered at initialisation time by
470 the RegisterUDRProcedure procedure.
471 }
472
473 { TFBUDRSelectProcedure }
474
475 TFBUDRSelectProcedure = class(TFBUDRProcedure)
476 public
477 {open must be overridden by a subclass in order to process the input parameter
478 values and to set up the select procedure. }
479 procedure open(context: IFBUDRExternalContext;
480 ProcMetadata: IFBUDRProcMetadata;
481 InputParams: IFBUDRInputParams); overload; virtual; abstract;
482
483 {After "open" returns the "fetch" method is called by the Firebird engine
484 to return each row in the output dataset. The values of the row's columns
485 are retuned in the Outputdata. Fetch returns false to indicate End of data.}
486 function fetch(OutputData: IFBUDROutputData): boolean; virtual;
487
488 {The "close" method is called after "fetch" returns false and may be overridden
489 in order to tidy up if necessary.}
490 procedure close; virtual;
491 public
492 {IExternalProcedure}
493 function open(status: Firebird.IStatus; context: Firebird.IExternalContext;
494 inMsg: Pointer; outMsg: Pointer): Firebird.IExternalResultSet; overload; override;
495 end;
496
497 {A new instance of TFBUDRProcedureFactory is instantiated for each UDR procedure
498 registered with the controller. It is called by the Firebird engine to "setup"
499 each UDR procedure and to create a new instance of each UDR procedure.
500 TFBUDRProcedureFactory is used internally by the UDR Controller and may be ignored
501 by a UDR writer.}
502
503 { TFBUDRProcedureFactory }
504
505 TFBUDRProcedureFactory = class(Firebird.IUdrProcedureFactoryImpl)
506 private
507 FController: TFBUDRController;
508 FName: AnsiString;
509 FProcedure: TFBUDRProcedureClass;
510 FFBContext: IFBUDRExternalContext;
511 FInArgNames: TStringList;
512 FOutArgNames: TStringList;
513 procedure UpdateArgNames(att: IAttachment; aProcName: AnsiString);
514 public
515 constructor Create(aName: AnsiString; aProcedure: TFBUDRProcedureClass);
516 destructor Destroy; override;
517 property Controller: TFBUDRController read FController write FController;
518 public
519 {IUdrProcedureFactory}
520 procedure dispose(); override;
521 procedure setup(status: Firebird.IStatus; context: Firebird.IExternalContext;
522 metadata:Firebird.IRoutineMetadata; inBuilder: Firebird.IMetadataBuilder;
523 outBuilder: Firebird.IMetadataBuilder); override;
524 function newItem(status: Firebird.IStatus; context: Firebird.IExternalContext;
525 metadata: Firebird.IRoutineMetadata): IExternalProcedure; override;
526 end;
527
528 TFBUDRTriggerAction = (taInsert, taUpdate, taDelete, taConnect, taDisconnect,
529 taTransactionStart, taTransactionCommit, taTransactionRollback,
530 taDDL);
531 {A TFBUDRTrigger object is instantiated by a TUDRTriggerFactory when a
532 "newItem" is requested. This is an abstract class and is subclassed by a
533 UDR writer for each UDR Trigger required. TFBUDRTrigger subclasses and their
534 "Routine Name" are registered at initialisation time by the RegisterUDRTrigger
535 procedure.}
536
537 { TFBUDRTrigger }
538
539 TFBUDRTrigger = class(Firebird.IExternalTriggerImpl)
540 private
541 FController: TFBUDRController;
542 FName: AnsiString;
543 FExternalContext: IFBUDRExternalContext;
544 FRoutineMetadata: IFBUDRRoutineMetadata;
545 FFieldNames: TStrings;
546 procedure SetFieldNames(SQLDA: TSQLDataArea);
547 public
548 constructor Create(aController: TFBUDRController;
549 aName: AnsiString;
550 context: IFBUDRExternalContext;
551 routineMetadata: IFBUDRRoutineMetadata;
552 aFieldNames: TStrings);
553 public
554 {External Trigger Implementation}
555
556 {Override getCharSet when the Trigger returns (?) strings in a different charset
557 to that used by the database connection.}
558 function getCharSet(context: IFBUDRExternalContext): AnsiString; overload; virtual;
559
560 {Override AfterTrigger in order to carry out an after trigger's function.
561 Separate interfaces are used to provide the "old" and "new" values of each
562 of the parent dataset's columns. Note that these are both read only for an
563 after trigger}
564
565 procedure AfterTrigger(context: IFBUDRExternalContext;
566 TriggerMetaData: IFBUDRTriggerMetaData;
567 action: TFBUDRTriggerAction;
568 OldParams: IFBUDRInputParams;
569 NewParams: IFBUDRInputParams); virtual;
570
571
572 {Override BeforeTrigger in order to carry out a before trigger's function.
573 Separate interfaces are used to provide the "old" and "new" values of each
574 of the parent dataset's columns. Note that the new values are writeable for an
575 after trigger}
576
577 procedure BeforeTrigger(context: IFBUDRExternalContext;
578 TriggerMetaData: IFBUDRTriggerMetaData;
579 action: TFBUDRTriggerAction;
580 OldParams: IFBUDRInputParams;
581 NewParams: IFBUDROutputData); virtual;
582
583
584 {Override DatabaseTrigger in order to carry out a before trigger's function.
585 Note that a database trigger does not have any input values}
586
587 procedure DatabaseTrigger(context: IFBUDRExternalContext;
588 TriggerMetaData: IFBUDRTriggerMetaData); virtual;
589
590 {setup is a class procedure and called by the UDR's Trigger factory when its
591 setup procedure is called. This is typically called the first time a
592 trigger factory is first used and may be used to initialise any class vars
593 used by the Execute function. This is normally only required with stateful
594 triggers.}
595
596 class procedure setup(context: IFBUDRExternalContext;
597 metadata: IFBUDRRoutineMetadata;
598 fieldsBuilder: IFBUDRMetadataBuilder); virtual;
599
600 property Name: AnsiString read FName;
601 public
602 {IExternalTrigger}
603 procedure dispose(); override;
604 procedure getCharSet(status: Firebird.IStatus; context: Firebird.IExternalContext;
605 name: PAnsiChar; nameSize: Cardinal); overload; override;
606 procedure execute(status: Firebird.IStatus; context: Firebird.IExternalContext;
607 action: Cardinal; oldMsg: Pointer; newMsg: Pointer); overload; override;
608 end;
609
610 TFBUDRTriggerClass = class of TFBUDRTrigger;
611
612 {A new instance of TFBUDRTriggerFactory is instantiated for each UDR trigger
613 registered with the controller. It is called by the Firebird engine to "setup"
614 each UDR trigger and to create a new instance of each UDR trigger.
615 TFBUDRTriggerFactory is used internally by the UDR Controller and may be ignored
616 by a UDR writer.}
617
618 { TFBUDRTriggerFactory }
619
620 TFBUDRTriggerFactory = class(Firebird.IUdrTriggerFactoryImpl)
621 private
622 FController: TFBUDRController;
623 FName: AnsiString;
624 FTrigger: TFBUDRTriggerClass;
625 FFieldNames: TStringList;
626 FFBContext: IFBUDRExternalContext;
627 procedure UpdateFieldNames(att: IAttachment; aTableName: AnsiString);
628 public
629 constructor Create(aName: AnsiString; aTrigger: TFBUDRTriggerClass);
630 destructor Destroy; override;
631 property Controller: TFBUDRController read FController write FController;
632 public
633 procedure dispose(); override;
634 procedure setup(status: Firebird.IStatus; context: Firebird.IExternalContext;
635 metadata: Firebird.IRoutineMetadata;
636 fieldsBuilder: Firebird.IMetadataBuilder); override;
637 function newItem(status: Firebird.IStatus; context: Firebird.IExternalContext;
638 metadata: Firebird.IRoutineMetadata): Firebird.IExternalTrigger; override;
639 end;
640
641 {firebird_udr_plugin is the UDR library entry point and must be exported by the
642 library.}
643
644 function firebird_udr_plugin(status: Firebird.IStatus; aTheirUnloadFlag: Firebird.BooleanPtr;
645 udrPlugin: Firebird.IUdrPlugin): Firebird.BooleanPtr; cdecl;
646
647 {The register functions are called at initialisation time to register each function,
648 procedure and trigger defined by the library. Note: "aName" is the routine name
649 in the corresponding SQL declaration for the function, procedure or trigger.}
650
651 procedure FBRegisterUDRFunction(aName: AnsiString; aFunction: TFBUDRFunctionClass);
652 procedure FBRegisterUDRProcedure (aName: AnsiString; aProcedure: TFBUDRProcedureClass);
653 procedure FBRegisterUDRTrigger(aName: AnsiString; aTrigger: TFBUDRTriggerClass);
654
655 implementation
656
657 uses FBUDRUtils, FBUDRMessage, IBUtils, FBClientAPI, FB30ClientAPI, IBErrorCodes,
658 IBExternals;
659
660 resourcestring
661 SFetchCalled = 'Fetch called for ';
662 SOpenExecuteProc = 'Open Execute Procedure ';
663 SOpenSelectProc = 'Open Select Procedure ';
664 SSetupTrigger = 'Setup Trigger ';
665 STriggerDisposed = 'Trigger %s: dispose called';
666 STriggerCharset = 'GetCharSet for Trigger %s charset name = "%s"';
667 STriggerExecute = 'Execute Trigger ';
668 STriggerNew = 'New Field Values:';
669 STriggerOld = 'Old Field Values:';
670 SProcSetup = 'Setup Procedure ';
671 SProcDispose = 'Procedure %s: dispose called with refcount = %d';
672 SProcCharset = 'GetCharSet for Procedure %s charset name = "%s"';
673 sFuncCreated = 'Function %s created';
674 SInputParams = 'Input Parameters';
675 SOutputParams = 'Output Parameters';
676 SFuncDispose = 'Function %s: dispose called';
677 SFuncCharset = 'GetCharSet for Function %s charset name = "%s"';
678 SFuncExecute = 'Execute Function ';
679 SFuncSetup = 'Setup Function ';
680 SRoutineMetadata = 'Routine Metadata';
681 SExceptionRaised = 'Exception raised';
682 SFuncRegister = 'Registering Function ';
683 SProcRegister = 'Registering Procedure ';
684 STriggerRegister = 'Registering Trigger ';
685 SBadLogOptionsStr = 'Malformed LogOptions Config string "%s" at position %d';
686 SNoConfigFile = 'Unable to find/load configuration file';
687 SReadingConfigFile = 'Reading Configuration File: %s';
688 SFuncNotOverridden = 'UDR Function %s is undefined';
689 SNoReturnValue = 'Function %s does not have a return value!';
690 STriggerIsNotImplemented = 'Trigger %s is not implemented';
691 STriggerNewAfter = 'New Field Values after trigger execution';
692
693 function firebird_udr_plugin(status: Firebird.IStatus;
694 aTheirUnloadFlag: Firebird.BooleanPtr; udrPlugin: Firebird.IUdrPlugin
695 ): Firebird.BooleanPtr; cdecl;
696 begin
697 if TFBUDRController.FFBController = nil then
698 TFBUDRController.Create(status,udrPlugin,aTheirUnloadFlag,Result); {create a default instance}
699 end;
700
701 procedure RegisterUDRFactory(aName: AnsiString; aFactory: TObject);
702 begin
703 if TFBUDRController.FUDRFactoryList = nil then
704 TFBUDRController.FUDRFactoryList := TStringList.Create;
705
706 TFBUDRController.FUDRFactoryList.AddObject(aName,aFactory);
707 end;
708
709 procedure FBRegisterUDRFunction(aName: AnsiString; aFunction: TFBUDRFunctionClass);
710 begin
711 RegisterUDRFactory(aName,TFBUDRFunctionFactory.Create(aName,aFunction));
712 end;
713
714 procedure FBRegisterUDRProcedure(aName: AnsiString;
715 aProcedure: TFBUDRProcedureClass);
716 begin
717 RegisterUDRFactory(aName,TFBUDRProcedureFactory.Create(aName,aProcedure));
718 end;
719
720 procedure FBRegisterUDRTrigger(aName: AnsiString; aTrigger: TFBUDRTriggerClass);
721 begin
722 RegisterUDRFactory(aName,TFBUDRTriggerFactory.Create(aName,aTrigger));
723 end;
724
725 { TFBUDRTriggerNewValuesSQLDA }
726
727 constructor TFBUDRTriggerNewValuesSQLDA.Create(context: IFBUDRExternalContext;
728 aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
729 var i: integer;
730 SQLNullIndicator: PShort;
731 data: PByte;
732 strlen: integer;
733 rs: rawbytestring;
734 begin
735 inherited Create(context,aMetadata,aBuffer);
736 for i := 0 to Count - 1 do
737 with TIBXSQLVar(Column[i]) do
738 begin
739 SQLNullIndicator := PShort(aBuffer + aMetaData.getNullOffset(context.getStatus,i));
740 context.CheckStatus;
741 if SQLNullIndicator^ = -1 then
742 IsNull := true
743 else
744 begin
745 IsNull := false;
746 data := aBuffer + aMetaData.getOffset(context.getStatus,i);
747 context.CheckStatus;
748 if SQLType = SQL_VARYING then
749 begin
750 strlen := (context.GetFirebirdAPI as TFBClientAPI).DecodeInteger(data,2);
751 DataLength := strlen;
752 setLength(rs,strlen);
753 Move((data+2)^,rs[1],strlen);
754 SetCodePage(rs,CodePage,false);
755 SetString(rs);
756 end
757 else
758 Move(data^,SQLData^,DataLength);
759 end;
760 end;
761 end;
762
763 { TFBUDRResultsCursor }
764
765 procedure TFBUDRResultsCursor.Close;
766 begin
767 inherited Close;
768 if not FDone then
769 (FUDRProcedure as TFBUDRSelectProcedure).Close;
770 FDone := true;
771 end;
772
773 function TFBUDRResultsCursor.fetch(status: Firebird.IStatus): Boolean;
774 begin
775 try
776 if loLogFetches in FBUDRControllerOptions.LogOptions then
777 FUDRProcedure.FController.WriteToLog(SFetchCalled + FUDRProcedure.FName);
778
779 if FOutputDataSQLDA <> nil then
780 begin
781 Result := (FUDRProcedure as TFBUDRSelectProcedure).fetch(FOutputData);
782 if [loLogFetches,loDetails] <= FBUDRControllerOptions.LogOptions then
783 FUDRProcedure.FController.WriteToLog(SOutputParams,FOutputData);
784 FOutputDataSQLDA.Finalise;
785 end
786 else
787 Result := false;
788
789 if not Result then
790 begin
791 if not FDone then
792 (FUDRProcedure as TFBUDRSelectProcedure).Close;
793 FDone := true;
794 end;
795 except on E: Exception do
796 FUDRProcedure.FController.FBSetStatusFromException(E,status);
797 end;
798 end;
799
800 { TFBUDRSingletonRow }
801
802 function TFBUDRSingletonRow.fetch(status: Firebird.IStatus): Boolean;
803 begin
804 try
805 if FOutputDataSQLDA <> nil then
806 begin
807 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
808 FUDRProcedure.FController.WriteToLog(SOutputParams,FOutputData);
809 FOutputDataSQLDA.Finalise; {copy output row to outMsg}
810 Result := not FFetchCalled;
811 FFetchCalled := true;
812 end
813 else
814 Result := false;
815 except on E: Exception do
816 FUDRProcedure.FController.FBSetStatusFromException(E,status);
817 end;
818 end;
819
820 { TFBUDRExecuteProcedure }
821
822 function TFBUDRExecuteProcedure.open(status: Firebird.IStatus;
823 context: Firebird.IExternalContext; inMsg: Pointer; outMsg: Pointer
824 ): Firebird.IExternalResultSet;
825 var aProcMetadata: IFBUDRProcMetadata;
826 InputParamsSQLDA: TFBUDRInParamsSQLDA;
827 InputParams: IFBUDRInputParams;
828 metadata: Firebird.IMessageMetadata;
829 begin
830 InputParams := nil;
831 InputParamsSQLDA := nil;
832 try
833 if loLogProcedures in FBUDRControllerOptions.LogOptions then
834 FController.WriteToLog(SOpenExecuteProc + FName);
835
836 if FRoutineMetadata.QueryInterface(IFBUDRProcMetadata,aProcMetadata) <> S_OK then
837 FBUDRError(ibxeNoProcMetadata,[nil])
838 else
839 begin
840 with (FExternalContext as TFBUDRExternalContext) do
841 begin
842 Assign(context);
843 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
844 FController.WriteToLog(AsText);
845 end;
846
847 if FRoutineMetadata.HasInputMetadata then
848 begin
849 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getInputMetadata;
850 try
851 InputParamsSQLDA := TFBUDRInParamsSQLDA.Create(FExternalContext,
852 metadata,
853 inMsg);
854 SetFieldNames(InputParamsSQLDA);
855 finally
856 metadata.release;
857 end;
858 end;
859
860 try
861 if InputParamsSQLDA <> nil then
862 begin
863 InputParams := TFBUDRInputParams.Create(InputParamsSQLDA);
864 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
865 FController.WriteToLog(SInputParams,InputParams);
866 end;
867
868 metadata := nil;
869 if FRoutineMetadata.HasOutputMetadata then
870 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getOutputMetadata;
871
872 try
873 Result := TFBUDRSingletonRow.Create(self, FExternalContext, FOutArgNames,
874 metadata,
875 outMsg);
876
877 finally
878 if metadata <> nil then
879 metadata.release;
880 end;
881
882 Execute(FExternalContext,aProcMetadata,InputParams,
883 (Result as TFBUDRSingletonRow).OutputData);
884 finally
885 InputParams := nil;
886 if InputParamsSQLDA <> nil then
887 InputParamsSQLDA.Free;
888 end;
889
890 end;
891 except on E: Exception do
892 FController.FBSetStatusFromException(E,status);
893 end;
894 end;
895
896 { TFBUDRSelectProcedure }
897
898 function TFBUDRSelectProcedure.fetch(OutputData: IFBUDROutputData): boolean;
899 begin
900 Result := false;
901 end;
902
903 procedure TFBUDRSelectProcedure.close;
904 begin
905 //override this method to tidy up once all rows have been returned
906 end;
907
908 function TFBUDRSelectProcedure.open(status: Firebird.IStatus;
909 context: Firebird.IExternalContext; inMsg: Pointer; outMsg: Pointer
910 ): Firebird.IExternalResultSet;
911 var aProcMetadata: IFBUDRProcMetadata;
912 InputParamsSQLDA: TFBUDRInParamsSQLDA;
913 InputParams: IFBUDRInputParams;
914 metadata: Firebird.IMessageMetadata;
915 begin
916 try
917 if loLogProcedures in FBUDRControllerOptions.LogOptions then
918 FController.WriteToLog(SOpenSelectProc + FName);
919
920 InputParamsSQLDA := nil;
921 InputParams := nil;
922 if FRoutineMetadata.QueryInterface(IFBUDRProcMetadata,aProcMetadata) <> S_OK then
923 FBUDRError(ibxeNoProcMetadata,[nil])
924 else
925 begin
926 with (FExternalContext as TFBUDRExternalContext) do
927 begin
928 Assign(context);
929 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
930 FController.WriteToLog(AsText);
931 end;
932
933 if FRoutineMetadata.HasInputMetadata then
934 begin
935 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getInputMetadata;
936 try
937 InputParamsSQLDA := TFBUDRInParamsSQLDA.Create(FExternalContext,
938 metadata,
939 inMsg);
940 finally
941 metadata.release;
942 end;
943 end;
944
945 try
946 if InputParamsSQLDA <> nil then
947 begin
948 InputParams := TFBUDRInputParams.Create(InputParamsSQLDA);
949 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
950 FController.WriteToLog(SInputParams,InputParams);
951 end;
952
953 metadata := nil;
954 if FRoutineMetadata.HasOutputMetadata then
955 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getOutputMetadata;
956
957 try
958 open(FExternalContext,aProcMetadata,InputParams);
959 Result := TFBUDRResultsCursor.Create(self, FExternalContext,
960 FOutArgNames,
961 metadata,
962 outMsg);
963 finally
964 if metadata <> nil then
965 metadata.release;
966 end;
967 finally
968 InputParams := nil;
969 if InputParamsSQLDA <> nil then
970 InputParamsSQLDA.Free;
971 end;
972 end;
973 except on E: Exception do
974 FController.FBSetStatusFromException(E,status);
975 end;
976 end;
977
978 const
979 sGetFieldNamesSQL = 'Select Trim(RF.RDB$FIELD_NAME) as ColumnName '+
980 'FROM RDB$RELATION_FIELDS RF '+
981 'JOIN RDB$FIELDS B On B.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
982 'Where RF.RDB$RELATION_NAME = ? ' +
983 'order by RF.RDB$FIELD_POSITION asc';
984
985 { TFBUDRTriggerFactory }
986
987 procedure TFBUDRTriggerFactory.UpdateFieldNames(att: IAttachment;
988 aTableName: AnsiString);
989 var FieldNames: IResultSet;
990 begin
991 FFieldNames.Clear;
992 if aTableName = '' then
993 Exit;
994 FieldNames := att.OpenCursorAtStart(sGetFieldNamesSQL,[aTableName]);
995 while not FieldNames.IsEOF do
996 begin
997 FFieldNames.Add(FieldNames[0].AsString);
998 FieldNames.FetchNext;
999 end;
1000 end;
1001
1002 constructor TFBUDRTriggerFactory.Create(aName: AnsiString;
1003 aTrigger: TFBUDRTriggerClass);
1004 begin
1005 inherited Create;
1006 FName := aName;
1007 FTrigger := aTrigger;
1008 FFBContext := TFBUDRExternalContext.Create(FController);
1009 FFieldNames := TStringList.Create;
1010 end;
1011
1012 destructor TFBUDRTriggerFactory.Destroy;
1013 begin
1014 if FFieldNames <> nil then
1015 FFieldNames.Free;
1016 inherited Destroy;
1017 end;
1018
1019 procedure TFBUDRTriggerFactory.dispose();
1020 begin
1021 Free;
1022 end;
1023
1024 procedure TFBUDRTriggerFactory.setup(status: Firebird.IStatus;
1025 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
1026 fieldsBuilder: Firebird.IMetadataBuilder);
1027 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1028 FBFieldsBuilder: IFBUDRMetadataBuilder;
1029 begin
1030 FBFieldsBuilder := nil;
1031 try
1032 if loLogTriggers in FBUDRControllerOptions.LogOptions then
1033 FController.WriteToLog(SSetupTrigger + FName);
1034
1035 (FFBContext as TFBUDRExternalContext).Assign(context);
1036 FController.StartJournaling(FFBContext);
1037
1038 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1039
1040 if fieldsBuilder <> nil then
1041 FBFieldsBuilder := TFBUDRMetadataBuilder.Create(FFBContext,fieldsBuilder);
1042 TFBUDRTrigger.setup(FFBContext,FBRoutineMetadata,FBFieldsBuilder)
1043 except on E: Exception do
1044 FController.FBSetStatusFromException(E,status);
1045 end;
1046 end;
1047
1048 function TFBUDRTriggerFactory.newItem(status: Firebird.IStatus;
1049 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata
1050 ): Firebird.IExternalTrigger;
1051 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1052 begin
1053 try
1054 (FFBContext as TFBUDRExternalContext).Assign(context);
1055 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1056 {Now get the Field Names}
1057 UpdateFieldNames(FFBContext.GetAttachment,FBRoutineMetadata.getTriggerTable);
1058 Result := FTrigger.Create(FController,FName,FFBContext,FBRoutineMetadata,FFieldNames);
1059 except on E: Exception do
1060 FController.FBSetStatusFromException(E,status);
1061 end;
1062 end;
1063
1064 { TFBUDRTrigger }
1065
1066 procedure TFBUDRTrigger.SetFieldNames(SQLDA: TSQLDataArea);
1067 var i: integer;
1068 begin
1069 for i := 0 to FFieldNames.Count - 1 do
1070 if i < SQLDA.Count then
1071 SQLDA[i].Name := FFieldNames[i];
1072 end;
1073
1074 constructor TFBUDRTrigger.Create(aController: TFBUDRController;
1075 aName: AnsiString; context: IFBUDRExternalContext;
1076 routineMetadata: IFBUDRRoutineMetadata; aFieldNames: TStrings);
1077 begin
1078 inherited Create;
1079 FName := aName;
1080 FController := aController;
1081 FExternalContext := context;
1082 FRoutineMetaData := routineMetadata;
1083 FFieldNames := aFieldNames;
1084 end;
1085
1086 function TFBUDRTrigger.getCharSet(context: IFBUDRExternalContext): AnsiString;
1087 begin
1088 Result := '';
1089 end;
1090
1091 procedure TFBUDRTrigger.AfterTrigger(context: IFBUDRExternalContext;
1092 TriggerMetaData: IFBUDRTriggerMetaData; action: TFBUDRTriggerAction;
1093 OldParams: IFBUDRInputParams; NewParams: IFBUDRInputParams);
1094 begin
1095 raise Exception.CreateFmt(STriggerIsNotImplemented,[FName]);
1096 end;
1097
1098 procedure TFBUDRTrigger.BeforeTrigger(context: IFBUDRExternalContext;
1099 TriggerMetaData: IFBUDRTriggerMetaData; action: TFBUDRTriggerAction;
1100 OldParams: IFBUDRInputParams; NewParams: IFBUDROutputData);
1101 begin
1102 raise Exception.CreateFmt(STriggerIsNotImplemented,[FName]);
1103 end;
1104
1105 procedure TFBUDRTrigger.DatabaseTrigger(context: IFBUDRExternalContext;
1106 TriggerMetaData: IFBUDRTriggerMetaData);
1107 begin
1108 raise Exception.CreateFmt(STriggerIsNotImplemented,[FName]);
1109 end;
1110
1111 class procedure TFBUDRTrigger.setup(context: IFBUDRExternalContext;
1112 metadata: IFBUDRRoutineMetadata; fieldsBuilder: IFBUDRMetadataBuilder);
1113 begin
1114 //Override in subclass
1115 end;
1116
1117 procedure TFBUDRTrigger.dispose();
1118 begin
1119 if loLogTriggers in FBUDRControllerOptions.LogOptions then
1120 FController.WriteToLog(Format(STriggerDisposed,[FName]));
1121
1122 Free;
1123 end;
1124
1125 procedure TFBUDRTrigger.getCharSet(status: Firebird.IStatus;
1126 context: Firebird.IExternalContext; name: PAnsiChar; nameSize: Cardinal);
1127 var charset: AnsiString;
1128 begin
1129 try
1130 (FExternalContext as TFBUDRExternalContext).Assign(context);
1131 charset := getCharSet(FExternalContext);
1132 if charset <> '' then
1133 begin
1134 StrPLCopy(name,charset,nameSize);
1135 if loLogTriggers in FBUDRControllerOptions.LogOptions then
1136 FController.WriteToLog(Format(STriggerCharset,[FName,charset]));
1137 end;
1138 except on E: Exception do
1139 FController.FBSetStatusFromException(E,status);
1140 end;
1141 end;
1142
1143 procedure TFBUDRTrigger.execute(status: Firebird.IStatus;
1144 context: Firebird.IExternalContext; action: Cardinal; oldMsg: Pointer;
1145 newMsg: Pointer);
1146 var aTriggerMetadata: IFBUDRTriggerMetaData;
1147 OldParamsSQLDA: TFBUDRInParamsSQLDA;
1148 NewParamsSQLDA: TFBUDRInParamsSQLDA;
1149 WritableParamsSQLDA: TFBUDRTriggerNewValuesSQLDA;
1150 OldParams: IFBUDRInputParams;
1151 NewParams: IFBUDRInputParams;
1152 NewWritableParams: IFBUDROutputData;
1153 TriggerAction: TFBUDRTriggerAction;
1154
1155 procedure SetUpOldParams;
1156 var metadata: Firebird.IMessageMetadata;
1157 begin
1158 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getTriggerMetadata;
1159 try
1160 OldParamsSQLDA := TFBUDRInParamsSQLDA.Create(FExternalContext,
1161 metadata,
1162 oldMsg);
1163 SetFieldNames(OldParamsSQLDA);
1164 OldParams := TFBUDRInputParams.Create(OldParamsSQLDA);
1165 if [loLogTriggers,loDetails] <= FBUDRControllerOptions.LogOptions then
1166 begin
1167 FController.WriteToLog(STriggerOld,OldParams);
1168 end;
1169 finally
1170 metadata.release;
1171 end;
1172 end;
1173
1174 procedure SetupNewParams;
1175 var metadata: Firebird.IMessageMetadata;
1176 begin
1177 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getTriggerMetadata;
1178 try
1179 NewParamsSQLDA := TFBUDRInParamsSQLDA.Create(FExternalContext,
1180 metadata,
1181 newMsg);
1182 SetFieldNames(NewParamsSQLDA);
1183 NewParams := TFBUDRInputParams.Create(NewParamsSQLDA);
1184 if [loLogTriggers,loDetails] <= FBUDRControllerOptions.LogOptions then
1185 begin
1186 FController.WriteToLog(STriggerNew,NewParams);
1187 end;
1188 finally
1189 metadata.release;
1190 end;
1191 end;
1192
1193 procedure SetupWritableNewParams;
1194 var metadata: Firebird.IMessageMetadata;
1195 begin
1196 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getTriggerMetadata;
1197 try
1198 WritableParamsSQLDA := TFBUDRTriggerNewValuesSQLDA.Create(FExternalContext,
1199 metadata,
1200 newMsg);
1201 SetFieldNames(WritableParamsSQLDA);
1202 NewWritableParams := TFBUDROutputParams.Create(WritableParamsSQLDA);
1203 if [loLogTriggers,loDetails] <= FBUDRControllerOptions.LogOptions then
1204 begin
1205 FController.WriteToLog(STriggerNew,NewWritableParams);
1206 end;
1207 finally
1208 metadata.release;
1209 end;
1210 end;
1211
1212 begin
1213 try
1214 if loLogTriggers in FBUDRControllerOptions.LogOptions then
1215 FController.WriteToLog(STriggerExecute + FName);
1216 OldParamsSQLDA := nil;
1217 NewParamsSQLDA := nil;
1218 WritableParamsSQLDA := nil;
1219 OldParams := nil;
1220 NewParams := nil;
1221 NewWritableParams := nil;
1222
1223 if FRoutineMetadata.QueryInterface(IFBUDRTriggerMetaData,aTriggerMetadata) <> S_OK then
1224 FBUDRError(ibxeNoTriggerMetadata,[nil])
1225 else
1226 begin
1227 (FExternalContext as TFBUDRExternalContext).Assign(context);
1228
1229 with Firebird.IExternalTrigger do
1230 case action of
1231 ACTION_INSERT:
1232 TriggerAction := taInsert;
1233 ACTION_UPDATE:
1234 TriggerAction := taUpdate;
1235 ACTION_DELETE:
1236 TriggerAction := taDelete;
1237 ACTION_CONNECT:
1238 TriggerAction := taConnect;
1239 ACTION_DISCONNECT:
1240 TriggerAction := taDisconnect;
1241 ACTION_TRANS_START:
1242 TriggerAction := taTransactionStart;
1243 ACTION_TRANS_COMMIT:
1244 TriggerAction := taTransactionCommit;
1245 ACTION_TRANS_ROLLBACK:
1246 TriggerAction := taTransactionRollback;
1247 ACTION_DDL:
1248 TriggerAction := taDDL;
1249 else
1250 FBUDRError(ibxeUnknownTransactionAction,[action]);
1251 end;
1252
1253 try
1254 case FRoutineMetadata.getTriggerType of
1255 ttBefore:
1256 begin
1257 if FRoutineMetadata.HasTriggerMetadata then
1258 begin
1259 if TriggerAction in [taUpdate, taDelete] then
1260 SetUpOldParams;
1261 if TriggerAction in [taInsert,taUpdate] then
1262 SetupWritableNewParams;
1263 end;
1264 BeforeTrigger(FExternalContext,aTriggerMetadata,TriggerAction,OldParams,NewWritableParams);
1265 WritableParamsSQLDA.Finalise;
1266 if [loLogTriggers,loDetails] <= FBUDRControllerOptions.LogOptions then
1267 FController.WriteToLog(STriggerNewAfter,NewWritableParams);
1268 end;
1269 ttAfter:
1270 begin
1271 if FRoutineMetadata.HasTriggerMetadata then
1272 begin
1273 if TriggerAction in [taUpdate, taDelete] then
1274 SetUpOldParams;
1275 if TriggerAction in [taInsert,taUpdate] then
1276 SetupNewParams;
1277 AfterTrigger(FExternalContext,aTriggerMetadata,TriggerAction,OldParams,NewParams);
1278 end;
1279 end;
1280 ttDatabase:
1281 begin
1282 DatabaseTrigger(FExternalContext,aTriggerMetadata);
1283 end;
1284 end;
1285 finally
1286 NewParams := nil;
1287 OldParams := nil;
1288 NewWritableParams := nil;
1289 if OldParamsSQLDA <> nil then
1290 OldParamsSQLDA.Free;
1291 if NewParamsSQLDA <> nil then
1292 NewParamsSQLDA.Free;
1293 if WritableParamsSQLDA <> nil then
1294 WritableParamsSQLDA.Free;
1295 end;
1296 end;
1297 except on E: Exception do
1298 FController.FBSetStatusFromException(E,status);
1299 end;
1300 end;
1301
1302 const
1303 sGetProcArgsSQL =
1304 'SELECT Trim(RDB$PARAMETER_NAME) ' +
1305 ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' +
1306 ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
1307 'WHERE ' +
1308 ' PRM.RDB$PROCEDURE_NAME = ? AND ' +
1309 ' PRM.RDB$PARAMETER_TYPE = ? ' +
1310 'ORDER BY PRM.RDB$PARAMETER_NUMBER';
1311
1312
1313 { TFBUDRProcedureFactory }
1314
1315 procedure TFBUDRProcedureFactory.UpdateArgNames(att: IAttachment;
1316 aProcName: AnsiString);
1317
1318 procedure UpdateFieldNames(paramType: integer; list: TStrings);
1319 var FieldNames: IResultSet;
1320 begin
1321 list.Clear;
1322 if aProcName = '' then
1323 Exit;
1324 FieldNames := att.OpenCursorAtStart(sGetProcArgsSQL,[aProcName,paramType]);
1325 while not FieldNames.IsEOF do
1326 begin
1327 list.Add(FieldNames[0].AsString);
1328 FieldNames.FetchNext;
1329 end;
1330 end;
1331
1332 begin
1333 UpdateFieldNames(0,FInArgNames);
1334 UpdateFieldNames(1,FOutArgNames);
1335 end;
1336
1337 constructor TFBUDRProcedureFactory.Create(aName: AnsiString;
1338 aProcedure: TFBUDRProcedureClass);
1339 begin
1340 inherited Create;
1341 FName := aName;
1342 FProcedure := aProcedure;
1343 FFBContext := TFBUDRExternalContext.Create(Controller);
1344 FInArgNames := TStringList.Create;
1345 FOutArgNames := TStringList.Create;
1346 end;
1347
1348 destructor TFBUDRProcedureFactory.Destroy;
1349 begin
1350 if FInArgNames <> nil then
1351 FInArgNames.Free;
1352 if FOutArgNames <> nil then
1353 FOutArgNames.Free;
1354 inherited Destroy;
1355 end;
1356
1357 procedure TFBUDRProcedureFactory.dispose();
1358 begin
1359 Free;
1360 end;
1361
1362 procedure TFBUDRProcedureFactory.setup(status: Firebird.IStatus;
1363 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
1364 inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
1365 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1366 FBInBuilder: IFBUDRMetadataBuilder;
1367 FBOutBuilder: IFBUDRMetadataBuilder;
1368 begin
1369 try
1370 if loLogProcedures in FBUDRControllerOptions.LogOptions then
1371 FController.WriteToLog(SProcSetup + FName);
1372
1373 FBInBuilder := nil;
1374 FBOutBuilder := nil;
1375 (FFBContext as TFBUDRExternalContext).Assign(context);
1376 FController.StartJournaling(FFBContext);
1377
1378 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1379 if inBuilder <> nil then
1380 FBInBuilder := TFBUDRMetadataBuilder.Create(FFBContext,inBuilder);
1381 if outBuilder <> nil then
1382 FBOutBuilder := TFBUDRMetadataBuilder.Create(FFBContext,outBuilder);
1383 TFBUDRProcedure.setup(FFBContext,FBRoutineMetadata,FBInBuilder,FBOutBuilder)
1384 except on E: Exception do
1385 FController.FBSetStatusFromException(E,status);
1386 end;
1387 end;
1388
1389 function TFBUDRProcedureFactory.newItem(status: Firebird.IStatus;
1390 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata
1391 ): IExternalProcedure;
1392 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1393 begin
1394 try
1395 (FFBContext as TFBUDRExternalContext).Assign(context);
1396 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1397 {Now get the Field Names}
1398 UpdateArgNames(FFBContext.GetAttachment,FBRoutineMetadata.getName);
1399 Result := FProcedure.Create(FController,FName,FFBContext,FBRoutineMetadata,
1400 FInArgNames,FOutArgNames);
1401 except on E: Exception do
1402 FController.FBSetStatusFromException(E,status);
1403 end;
1404 end;
1405
1406 { TFBUDRExternalResultsSet }
1407
1408 procedure TFBUDRExternalResultsSet.SetFieldNames(SQLDA: TSQLDataArea);
1409 var i: integer;
1410 begin
1411 for i := 0 to FOutArgNames.Count - 1 do
1412 if i < SQLDA.Count then
1413 SQLDA[i].Name := FOutArgNames[i];
1414 end;
1415
1416 procedure TFBUDRExternalResultsSet.Close;
1417 begin
1418 //do nothing by default
1419 end;
1420
1421 constructor TFBUDRExternalResultsSet.Create(UDRProcedure: TFBUDRProcedure;
1422 context: IFBUDRExternalContext; aOutArgNames: TStrings;
1423 metadata: Firebird.IMessageMetadata; outMsg: pointer);
1424 begin
1425 inherited Create;
1426 FUDRProcedure := UDRProcedure;
1427 FOutArgNames := aOutArgNames;
1428 Inc(FUDRProcedure.FRefCount);
1429 if metadata <> nil then
1430 begin
1431 FOutputDataSQLDA := TFBUDROutParamsSQLDA.Create(context,metadata,outMsg);
1432 SetFieldNames(FOutputDataSQLDA);
1433 FOutputData := TFBUDROutputParams.Create(FOutputDataSQLDA);
1434 if [loLogProcedures,loDetails] <= FBUDRControllerOptions.LogOptions then
1435 FUDRProcedure.FController.WriteToLog(SOutputParams,FOutputData);
1436 end;
1437 end;
1438
1439 destructor TFBUDRExternalResultsSet.Destroy;
1440 begin
1441 FOutputData := nil;
1442 if FOutputDataSQLDA <> nil then
1443 FOutputDataSQLDA.Free;
1444 inherited Destroy;
1445 end;
1446
1447 procedure TFBUDRExternalResultsSet.dispose();
1448 begin
1449 Close;
1450 FUDRProcedure.dispose;
1451 Free;
1452 end;
1453
1454 { TFBUDRProcedure }
1455
1456 procedure TFBUDRProcedure.SetFieldNames(SQLDA: TSQLDataArea);
1457 var i: integer;
1458 begin
1459 for i := 0 to FInArgNames.Count - 1 do
1460 if i < SQLDA.Count then
1461 SQLDA[i].Name := FInArgNames[i];
1462 end;
1463
1464 constructor TFBUDRProcedure.Create(aController: TFBUDRController;
1465 aName: AnsiString; context: IFBUDRExternalContext;
1466 routineMetadata: IFBUDRRoutineMetadata; aInArgNames, aOutArgNames: TStrings);
1467 begin
1468 inherited Create;
1469 FController := aController;
1470 FName := aName;
1471 FRefCount := 1;
1472 FExternalContext := context;
1473 FRoutineMetaData := routineMetadata;
1474 FInArgNames := aInArgNames;
1475 FOutArgNames := aOutArgNames;
1476 end;
1477
1478 function TFBUDRProcedure.getCharSet(context: IFBUDRExternalContext): AnsiString;
1479 begin
1480 Result := '';
1481 end;
1482
1483 class procedure TFBUDRProcedure.setup(context: IFBUDRExternalContext;
1484 metadata: IFBUDRRoutineMetadata; inBuilder: IFBUDRMetadataBuilder;
1485 outBuilder: IFBUDRMetadataBuilder);
1486 begin
1487 //Override in subclass
1488 end;
1489
1490 procedure TFBUDRProcedure.dispose();
1491 begin
1492 if loLogProcedures in FBUDRControllerOptions.LogOptions then
1493 FController.WriteToLog(Format(SProcDispose,[FName,FRefCount]));
1494
1495 Dec(FRefCount);
1496 if FRefCount = 0 then Free;
1497 end;
1498
1499 procedure TFBUDRProcedure.getCharSet(status: Firebird.IStatus;
1500 context: Firebird.IExternalContext; name: PAnsiChar; nameSize: Cardinal);
1501 var charset: AnsiString;
1502 begin
1503 try
1504 (FExternalContext as TFBUDRExternalContext).Assign(context);
1505 charset := getCharSet(FExternalContext);
1506 if charset <> '' then
1507 begin
1508 StrPLCopy(name,charset,nameSize);
1509 if loLogProcedures in FBUDRControllerOptions.LogOptions then
1510 FController.WriteToLog(Format(SProcCharset,[FName,charset]));
1511 end;
1512 except on E: Exception do
1513 FController.FBSetStatusFromException(E,status);
1514 end;
1515 end;
1516
1517 { TFBUDRInParamsSQLDA }
1518
1519 procedure TFBUDRInParamsSQLDA.AllocMessageBuffer(len: integer);
1520 begin
1521 FMessageBuffer := FBuffer;
1522 FMsgLength := len;
1523 end;
1524
1525 procedure TFBUDRInParamsSQLDA.FreeMessageBuffer;
1526 begin
1527 FBuffer := nil;
1528 FMsgLength := 0;
1529 end;
1530
1531 function TFBUDRInParamsSQLDA.GetAttachment: IAttachment;
1532 begin
1533 Result := FAttachment;
1534 end;
1535
1536 function TFBUDRInParamsSQLDA.GetTransaction: ITransaction;
1537 begin
1538 Result := FTransaction;
1539 end;
1540
1541 constructor TFBUDRInParamsSQLDA.Create(context: IFBUDRExternalContext;
1542 aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
1543 begin
1544 inherited Create(context.GetFirebirdAPI);
1545 FAttachment := context.GetAttachment;
1546 FTransaction := context.GetTransaction;
1547 FBuffer := aBuffer;
1548 Bind(aMetaData);
1549 end;
1550
1551 { TFBUDROutParamsSQLDA }
1552
1553 procedure TFBUDROutParamsSQLDA.AllocMessageBuffer(len: integer);
1554 begin
1555 FMessageBuffer := FBuffer;
1556 FMsgLength := len;
1557 end;
1558
1559 procedure TFBUDROutParamsSQLDA.FreeMessageBuffer;
1560 begin
1561 FMessageBuffer := nil;
1562 FMsgLength := 0;
1563 end;
1564
1565 function TFBUDROutParamsSQLDA.GetAttachment: IAttachment;
1566 begin
1567 Result := FAttachment;
1568 end;
1569
1570 function TFBUDROutParamsSQLDA.GetTransaction: ITransaction;
1571 begin
1572 Result := FTransaction;
1573 end;
1574
1575 constructor TFBUDROutParamsSQLDA.Create(context: IFBUDRExternalContext;
1576 aMetadata: Firebird.IMessageMetaData; aBuffer: PByte);
1577 begin
1578 inherited Create(context.GetFirebirdAPI);
1579 FAttachment := context.GetAttachment;
1580 FTransaction := context.GetTransaction;
1581 FBuffer := aBuffer;
1582 Bind(aMetadata);
1583 end;
1584
1585 function TFBUDROutParamsSQLDA.CanChangeMetaData: boolean;
1586 begin
1587 Result := false;
1588 end;
1589
1590 procedure TFBUDROutParamsSQLDA.Finalise;
1591 begin
1592 PackBuffer;
1593 end;
1594
1595 { TFBUDRFunction }
1596
1597 procedure TFBUDRFunction.SetFieldNames(SQLDA: TFBUDRInParamsSQLDA);
1598 var i: integer;
1599 begin
1600 for i := 0 to FFieldNames.Count - 1 do
1601 if i < SQLDA.Count then
1602 SQLDA[i].Name := FFieldNames[i];
1603 end;
1604
1605 constructor TFBUDRFunction.Create(aController: TFBUDRController;
1606 aName: AnsiString; context: IFBUDRExternalContext;
1607 routineMetadata: IFBUDRRoutineMetadata; aFieldNames: TStrings);
1608 begin
1609 inherited Create;
1610 FController := aController;
1611 FName := aName;
1612 FFieldNames := aFieldNames;
1613 FExternalContext := context;
1614 FRoutineMetaData := routineMetadata;
1615 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1616 begin
1617 FController.WriteToLog(Format(sFuncCreated,[aName]));
1618 if loDetails in FBUDRControllerOptions.LogOptions then
1619 FController.WriteToLog((FRoutineMetaData as TFBUDRRoutineMetadata).AsText);
1620 end;
1621 end;
1622
1623 function TFBUDRFunction.getCharSet(context: IFBUDRExternalContext): AnsiString;
1624 begin
1625 Result := '';
1626 end;
1627
1628 function TFBUDRFunction.Execute(context: IFBUDRExternalContext;
1629 ProcMetadata: IFBUDRProcMetadata; InputParams: IFBUDRInputParams;
1630 ResultSQLType: cardinal): variant;
1631 begin
1632 raise Exception.CreateFmt(SFuncNotOverridden,[FName]);
1633 end;
1634
1635 procedure TFBUDRFunction.Execute(context: IFBUDRExternalContext;
1636 ProcMetadata: IFBUDRProcMetadata; InputParams: IFBUDRInputParams;
1637 ReturnValue: ISQLParam);
1638 begin
1639 ReturnValue.AsVariant := Execute(context,ProcMetadata,InputParams,ReturnValue.GetSQLType);
1640 end;
1641
1642 class procedure TFBUDRFunction.setup(context: IFBUDRExternalContext;
1643 metadata: IFBUDRRoutineMetadata; inBuilder: IFBUDRMetadataBuilder;
1644 outBuilder: IFBUDRMetadataBuilder);
1645 begin
1646 //Do nothing be default
1647 end;
1648
1649 procedure TFBUDRFunction.dispose();
1650 begin
1651 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1652 FController.WriteToLog(Format(SFuncDispose,[FName]));
1653
1654 Free;
1655 end;
1656
1657 procedure TFBUDRFunction.getCharSet(status: Firebird.IStatus;
1658 context: Firebird.IExternalContext; name: PAnsiChar; nameSize: Cardinal);
1659 var charset: AnsiString;
1660 begin
1661 try
1662 (FExternalContext as TFBUDRExternalContext).Assign(context);
1663 charset := getCharSet(FExternalContext);
1664 if charset <> '' then
1665 begin
1666 StrPLCopy(name,charset,nameSize);
1667 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1668 FController.WriteToLog(Format(SFuncCharset,[FName,charset]));
1669 end;
1670 except on E: Exception do
1671 FController.FBSetStatusFromException(E,status);
1672 end;
1673 end;
1674
1675 procedure TFBUDRFunction.execute(status: Firebird.IStatus;
1676 context: Firebird.IExternalContext; inMsg: Pointer; outMsg: Pointer);
1677 var aProcMetadata: IFBUDRProcMetadata;
1678 OutParamsSQLDA: TFBUDROutParamsSQLDA;
1679 InParamsSQLDA: TFBUDRInParamsSQLDA;
1680 InputParams: IFBUDRInputParams;
1681 OutputData: IFBUDROutputData;
1682 metadata: Firebird.IMessageMetadata;
1683 begin
1684 try
1685 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1686 FController.WriteToLog(SFuncExecute + FName);
1687
1688 OutParamsSQLDA := nil;
1689 InParamsSQLDA := nil;
1690 InputParams := nil;
1691 OutputData := nil;
1692 if FRoutineMetadata.QueryInterface(IFBUDRProcMetadata,aProcMetadata) <> S_OK then
1693 FBUDRError(ibxeNoProcMetadata,[nil])
1694 else
1695 begin
1696 with FExternalContext as TFBUDRExternalContext do
1697 begin
1698 Assign(context);
1699 if [loLogFunctions,loDetails] <= FBUDRControllerOptions.LogOptions then
1700 FController.WriteToLog(AsText);
1701 end;
1702
1703 try
1704 if FRoutineMetadata.HasInputMetadata then
1705 begin
1706 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getInputMetadata;
1707 try
1708 InParamsSQLDA := TFBUDRInParamsSQLDA.Create(FExternalContext,
1709 metadata,
1710 inMsg);
1711 SetFieldNames(InParamsSQLDA);
1712 finally
1713 metadata.release;
1714 end;
1715
1716 InputParams := TFBUDRInputParams.Create(InParamsSQLDA);
1717 if [loLogFunctions,loDetails] <= FBUDRControllerOptions.LogOptions then
1718 FController.WriteToLog(SInputParams,InputParams);
1719 end;
1720
1721 if FRoutineMetadata.HasOutputMetadata then
1722 begin
1723 metadata := (FRoutineMetadata as TFBUDRRoutineMetadata).getOutputMetadata;
1724 try
1725 OutParamsSQLDA := TFBUDROutParamsSQLDA.Create(FExternalContext,
1726 metadata,
1727 outMsg);
1728 finally
1729 metadata.release;
1730 end;
1731 OutputData := TFBUDROutputParams.Create(OutParamsSQLDA);
1732 end
1733 else
1734 raise Exception.CreateFmt(SNoReturnValue,[FName]);
1735
1736 Execute(FExternalContext,aProcMetadata,InputParams,OutputData[0]);
1737
1738 if [loLogFunctions,loDetails] <= FBUDRControllerOptions.LogOptions then
1739 FController.WriteToLog(SOutputParams,OutputData);
1740
1741 OutParamsSQLDA.Finalise; {copy result to OutMsg buffer}
1742 finally
1743 OutputData := nil;
1744 InputParams := nil;
1745 if OutParamsSQLDA <> nil then
1746 OutParamsSQLDA.Free;
1747 if InParamsSQLDA <> nil then
1748 InParamsSQLDA.Free;
1749 end;
1750 end;
1751 except on E: Exception do
1752 FController.FBSetStatusFromException(E,status);
1753 end;
1754 end;
1755
1756 { TFBUDRFunctionFactory }
1757
1758 const
1759 FunctionArgsSQL =
1760 'SELECT Trim(RDB$ARGUMENT_NAME) FROM RDB$FUNCTION_ARGUMENTS RFA JOIN RDB$FIELDS FLD ' +
1761 'ON RFA.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME '+
1762 'WHERE RDB$FUNCTION_NAME = ? AND RDB$ARGUMENT_POSITION > 0' +
1763 'ORDER BY RDB$ARGUMENT_POSITION';
1764
1765 procedure TFBUDRFunctionFactory.UpdateFieldNames(att: IAttachment;
1766 aFunctionName: AnsiString);
1767 var FieldNames: IResultSet;
1768 begin
1769 FFieldNames.Clear;
1770 if aFunctionName = '' then
1771 Exit;
1772 FieldNames := att.OpenCursorAtStart(FunctionArgsSQL,[aFunctionName]);
1773 while not FieldNames.IsEOF do
1774 begin
1775 FFieldNames.Add(FieldNames[0].AsString);
1776 FieldNames.FetchNext;
1777 end;
1778 end;
1779
1780 constructor TFBUDRFunctionFactory.Create(aName: AnsiString;
1781 aFunction: TFBUDRFunctionClass);
1782 begin
1783 inherited Create;
1784 FName := aName;
1785 FFunction := aFunction;
1786 FFBContext := TFBUDRExternalContext.Create(Controller);
1787 FFieldNames := TStringList.Create;
1788 end;
1789
1790 destructor TFBUDRFunctionFactory.Destroy;
1791 begin
1792 if FFieldNames <> nil then
1793 FFieldNames.Free;
1794 inherited Destroy;
1795 end;
1796
1797 procedure TFBUDRFunctionFactory.dispose();
1798 begin
1799 Free;
1800 end;
1801
1802 procedure TFBUDRFunctionFactory.setup(status: Firebird.IStatus;
1803 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
1804 inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
1805 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1806 FBInBuilder: IFBUDRMetadataBuilder;
1807 FBOutBuilder: IFBUDRMetadataBuilder;
1808 begin
1809 FBInBuilder := nil;
1810 FBOutBuilder := nil;
1811 try
1812 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1813 FController.WriteToLog(SFuncSetup + FName);
1814
1815 (FFBContext as TFBUDRExternalContext).Assign(context);
1816
1817 FController.StartJournaling(FFBContext);
1818
1819 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1820
1821 if inBuilder <> nil then
1822 FBInBuilder := TFBUDRMetadataBuilder.Create(FFBContext,inBuilder);
1823 if outBuilder <> nil then
1824 FBOutBuilder := TFBUDRMetadataBuilder.Create(FFBContext,outBuilder);
1825 if [loLogFunctions, loDetails] <= FBUDRControllerOptions.LogOptions then
1826 FController.WriteToLog(SRoutineMetadata + LineEnding + (FBRoutineMetadata as TFBUDRRoutineMetadata).AsText);
1827
1828 TFBUDRFunction.setup(FFBContext,FBRoutineMetadata,FBInBuilder,FBOutBuilder)
1829 except on E: Exception do
1830 FController.FBSetStatusFromException(E,status);
1831 end;
1832 end;
1833
1834 function TFBUDRFunctionFactory.newItem(status: Firebird.IStatus;
1835 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata
1836 ): Firebird.IExternalFunction;
1837 var FBRoutineMetadata: IFBUDRRoutineMetadata;
1838 begin
1839 try
1840 (FFBContext as TFBUDRExternalContext).Assign(context);
1841 FBRoutineMetadata := TFBUDRRoutineMetadata.Create(FFBContext,metadata);
1842 {Now get the argument Names}
1843 UpdateFieldNames(FFBContext.GetAttachment,FBRoutineMetadata.getName);
1844 Result := FFunction.Create(FController,FName,FFBContext,FBRoutineMetadata,FFieldNames);
1845 except on E: Exception do
1846 FController.FBSetStatusFromException(E,status);
1847 end;
1848 end;
1849
1850 { TFBUDRController }
1851
1852 function TFBUDRController.GetDateTimeFmt: AnsiString;
1853 begin
1854 {$IF declared(DefaultFormatSettings)}
1855 with DefaultFormatSettings do
1856 {$ELSE}
1857 {$IF declared(FormatSettings)}
1858 with FormatSettings do
1859 {$IFEND}
1860 {$IFEND}
1861 Result := ShortDateFormat + ' ' + LongTimeFormat + '.zzzz'
1862 end;
1863
1864 function TFBUDRController.ProcessTemplateMacros(aTemplate: AnsiString
1865 ): AnsiString;
1866
1867 function CleanDirName(aDirName: PAnsiChar): AnsiString;
1868 begin
1869 Result := Trim(strpas(aDirName));
1870 {$IFDEF WINDOWS}
1871 Result := StringReplace(Result,'/',DirectorySeparator,[rfReplaceAll]);
1872 {$ELSE}
1873 Result := StringReplace(Result,'\',DirectorySeparator,[rfReplaceAll]);
1874 {$ENDIF}
1875 if (Length(Result) > 0) and (Result[Length(aDirName)] <> DirectorySeparator) then
1876 Result := Result + DirectorySeparator;
1877 end;
1878
1879 var udr_config: Firebird.IConfig;
1880 config_entry: Firebird.IConfigEntry;
1881 aStatus: Firebird.IStatus;
1882 begin
1883 if assigned(FMaster) then
1884 with FMaster.getConfigManager do
1885 begin
1886 Result := StringReplace(aTemplate,'$LOGDIR',CleanDirName(getDirectory(DIR_LOG)),[rfReplaceAll, rfIgnoreCase]);
1887 udr_config := getPluginConfig('UDR');
1888 if udr_config <> nil then
1889 try
1890 aStatus := FMaster.getStatus;
1891 try
1892 config_entry := udr_config.find(aStatus,'path');
1893 with aStatus do
1894 if (getState and STATE_ERRORS) <> 0 then
1895 raise EFBUDRException.Create(aStatus);
1896 finally
1897 aStatus.dispose;
1898 end;
1899
1900 if config_entry <> nil then
1901 try
1902 with config_entry do
1903 Result := StringReplace(Result,'$UDRDIR',CleanDirName(config_entry.getValue),[rfReplaceAll, rfIgnoreCase]);
1904 finally
1905 config_entry.release;
1906 end;
1907 finally
1908 udr_config.release();
1909 end;
1910 end;
1911 Result := StringReplace(Result,'$TEMP',GetTempDir,[rfReplaceAll, rfIgnoreCase]);
1912 Result := StringReplace(Result,'$MODULE',FBUDRControllerOptions.ModuleName,[rfReplaceAll, rfIgnoreCase]);
1913 Result := StringReplace(Result,'$TIMESTAMP',FormatDateTime('yyyymmddhhnnss',Now),[rfReplaceAll, rfIgnoreCase]);
1914 end;
1915
1916 procedure TFBUDRController.RegisterUDRFactories(status: Firebird.IStatus;
1917 udrPlugin: Firebird.IUdrPlugin);
1918 var i: integer;
1919 begin
1920 if FUDRFactoryList <> nil then
1921 for i := 0 to FUDRFactoryList.Count - 1 do
1922 try
1923 RegisterUDRFactory(status,udrPlugin,FUDRFactoryList[i], FUDRFactoryList.Objects[i]);
1924 with status do
1925 if (getState and STATE_ERRORS) <> 0 then break;
1926 except on E: Exception do
1927 FBSetStatusFromException(E,status);
1928 end;
1929 end;
1930
1931 procedure TFBUDRController.RegisterUDRFactory(status: Firebird.IStatus;
1932 udrPlugin: Firebird.IUdrPlugin; aName: AnsiString; factory: TObject);
1933 begin
1934 if factory is TFBUDRFunctionFactory then
1935 begin
1936 if loLogFunctions in FBUDRControllerOptions.LogOptions then
1937 WriteToLog(SFuncRegister + aName);
1938 udrPlugin.registerFunction(status,PAnsiChar(aName),Firebird.IUdrFunctionFactory(factory));
1939 TFBUDRFunctionFactory(factory).Controller := self;
1940 end
1941 else
1942 if factory is TFBUDRProcedureFactory then
1943 begin
1944 if loLogProcedures in FBUDRControllerOptions.LogOptions then
1945 WriteToLog(SProcRegister + aName);
1946 udrPlugin.registerProcedure(status,PAnsiChar(aName),Firebird.IUdrProcedureFactory(factory));
1947 TFBUDRProcedureFactory(factory).Controller := self;
1948 end
1949 else
1950 if factory is TFBUDRTriggerFactory then
1951 begin
1952 if loLogTriggers in FBUDRControllerOptions.LogOptions then
1953 WriteToLog(STriggerRegister + aName);
1954 udrPlugin.registerTrigger(status,PAnsiChar(aName),Firebird.IUdrTriggerFactory(factory));
1955 TFBUDRTriggerFactory(factory).Controller := self;
1956 end
1957 else
1958 FBUDRError(ibxeInvalidFactoryObject,[factory.ClassName,aName]);
1959 end;
1960
1961 procedure TFBUDRController.FreeFactoryList;
1962 //var i: integer;
1963 begin
1964 {if FUDRFactoryList <> nil then
1965 for i := 0 to FUDRFactoryList.Count - 1 do
1966 if FUDRFactoryList.Objects[i] <> nil then
1967 FUDRFactoryList.Objects[i].Free;} {disposed of by Firebird Engine}
1968 FreeAndNil(FUDRFactoryList);
1969 end;
1970
1971 const
1972 LogOptionsTable: array [TFBUDRControllerLogOption] of AnsiString = (
1973 'loLogFunctions',
1974 'loLogProcedures',
1975 'loLogTriggers',
1976 'loLogFetches',
1977 'loModifyQueries',
1978 'loReadOnlyQueries',
1979 'loDetails'
1980 );
1981
1982 procedure TFBUDRController.LoadConfig;
1983
1984 function GetLogOptions(LogOptionsStr: AnsiString; var aLogOptions: TFBUDRControllerLogOptions): boolean;
1985 var s: AnsiString;
1986 p1, p2, len: integer;
1987 i: TFBUDRControllerLogOption;
1988 found: boolean;
1989 begin
1990 Result := LogOptionsStr <> '';
1991 if Result then
1992 begin
1993 aLogOptions := [];
1994 p2 := 1;
1995 {skip past opening square bracket}
1996 while (p2 <= length(LogOptionsStr)) and (LogOptionsStr[p2] <> '[') do
1997 Inc(p2);
1998
1999 {parse into words separated by commas}
2000 Inc(p2);
2001 p1 := p2;
2002 while p2 <= length(LogOptionsStr) do
2003 begin
2004 if LogOptionsStr[p2] in [',',']'] then
2005 begin
2006 s := Trim(system.copy(LogOptionsStr,p1,p2-p1));
2007
2008 {Now convert string to LogOption}
2009 found := false;
2010 for i := low(TFBUDRControllerLogOption) to high(TFBUDRControllerLogOption) do
2011 if CompareText(s,LogOptionsTable[i]) = 0 then
2012 begin
2013 aLogOptions := aLogOptions + [i];
2014 found := true;
2015 break;
2016 end;
2017 if not found then
2018 WriteToLog(Format(SBadLogOptionsStr,[LogOptionsStr,p2]));
2019 if LogOptionsStr[p2] = ']' then
2020 break;
2021 p1 := p2 + 1;
2022 end;
2023 Inc(p2);
2024 end;
2025 if p2 > length(LogOptionsStr) then
2026 WriteToLog(Format(SBadLogOptionsStr,[LogOptionsStr,p2]));
2027 Result := true;
2028 end;
2029 end;
2030
2031 var aLogOptions: TFBUDRControllerLogOptions;
2032 aConfigFileName: Ansistring;
2033 begin
2034 aConfigFileName := ProcessTemplateMacros(FBUDRControllerOptions.ConfigFileNameTemplate);
2035 if (FConfigFile = nil) and FileExists(aConfigFileName) then
2036 begin
2037 FConfigFile := TIniFile.Create(aConfigFileName);
2038 {$if declared(TStringArray)}
2039 FConfigFile.BoolFalseStrings := FalseStrings;
2040 FConfigFile.BoolTrueStrings := TrueStrings;
2041 {$ifend}
2042 WriteToLog(Format(SReadingConfigFile,[aConfigFileName]));
2043 with FBUDRControllerOptions do
2044 if AllowConfigFileOverrides then
2045 begin
2046 LogFileNameTemplate := FConfigFile.ReadString('Controller','LogFileNameTemplate',LogFileNameTemplate);
2047 WriteToLog('LogFileNameTemplate = ' + LogFileNameTemplate);
2048 ForceWriteJournalEntries := FConfigFile.ReadBool('Controller','ForceWriteJournalEntries',ForceWriteJournalEntries);
2049 WriteToLog('ForceWriteJournalEntries = ' + BooleanToStr(ForceWriteJournalEntries ,'true','false'));
2050 ThreadSafeLogging := FConfigFile.ReadBool('Controller','ThreadSafeLogging',ThreadSafeLogging);
2051 WriteToLog('ThreadSafeLogging = ' + BooleanToStr(ThreadSafeLogging,'true','false'));
2052 if GetLogOptions( FConfigFile.ReadString('Controller','LogOptions',''),aLogOptions) then
2053 LogOptions := aLogOptions;
2054 WriteToLog('LogOptions = ' + LogOptionsToStr(LogOptions));
2055 end;
2056 end;
2057 end;
2058
2059 function TFBUDRController.LogOptionsToStr(aLogOptions: TFBUDRControllerLogOptions): AnsiString;
2060 var i: TFBUDRControllerLogOption;
2061 separator: AnsiString;
2062 begin
2063 Result := '[';
2064 separator := '';
2065 for i := low(TFBUDRControllerLogOption) to high(TFBUDRControllerLogOption) do
2066 if i in aLogOptions then
2067 begin
2068 Result := Result + separator + LogOptionsTable[i];
2069 separator := ',';
2070 end;
2071 Result := Result + ']';
2072 end;
2073
2074 constructor TFBUDRController.Create(status: Firebird.IStatus;
2075 udrPlugin: Firebird.IUdrPlugin; aTheirUnloadFlag: booleanPtr;
2076 var aMyUnloadFlag: booleanPtr);
2077 begin
2078 try
2079 inherited Create;
2080 FFBController := self;
2081 FTheirUnloadFlag := aTheirUnloadFlag;
2082 FMyUnloadFlag := false;
2083 aMyUnloadFlag := @FMyUnloadFlag;
2084 FMaster := udrPlugin.getMaster;
2085 FCriticalSection := TCriticalSection.Create;
2086 RegisterUDRFactories(status,udrPlugin);
2087 LoadConfig;
2088 except on E: Exception do
2089 FBSetStatusFromException(E,status);
2090 end;
2091 end;
2092
2093 destructor TFBUDRController.Destroy;
2094 begin
2095 if FConfigFile <> nil then
2096 FConfigFile.Free;
2097 if FLogStream <> nil then
2098 FLogStream.Free;
2099 FreeFactoryList;
2100 if FCriticalSection <> nil then
2101 FCriticalSection.Free;
2102 if (FTheirUnloadFlag <> nil) and not FMyUnloadFlag then
2103 FTheirUnloadFlag^ := true; {notify unload of module}
2104 inherited Destroy;
2105 end;
2106
2107 procedure TFBUDRController.FBSetStatusFromException(E: Exception; aStatus: Firebird.IStatus);
2108 var StatusVector: TStatusVector;
2109 begin
2110 if E is EFBUDRException then
2111 aStatus.setErrors((E as EFBUDRException).Status.getErrors())
2112 else
2113 if E is EIBInterBaseError then
2114 aStatus.setErrors(NativeIntPtr(((E as EIBInterBaseError).Status as TFB30Status).GetStatus.getErrors))
2115 else
2116 begin
2117 FMessageBuffer := E.Message;
2118 StatusVector[0] := isc_arg_gds;
2119 StatusVector[1] := NativeInt(isc_random);
2120 StatusVector[2] := isc_arg_string;
2121 StatusVector[3] := NativeInt(PAnsiChar(FMessageBuffer));
2122 StatusVector[4] := isc_arg_end;
2123 astatus.setErrors(@StatusVector);
2124 end;
2125 WriteToLog(SExceptionRaised + LineEnding + E.Message);
2126 end;
2127
2128 function TFBUDRController.GetLogStream: TStream;
2129 var FilePathName: AnsiString;
2130 begin
2131 if FLogStream = nil then
2132 begin
2133 FilePathName := ProcessTemplateMacros(FBUDRControllerOptions.LogFileNameTemplate);
2134 if FJnlOpenAppend then
2135 begin
2136 FLogStream := TFileStream.Create(FilePathName,fmOpenWrite);
2137 FLogStream.Seek(0, soFromEnd);
2138 end
2139 else
2140 FLogStream := TFileStream.Create(FilePathName,fmCreate);
2141 end;
2142 Result := FLogStream;
2143 FJnlOpenAppend := true;
2144 end;
2145
2146 procedure TFBUDRController.WriteToLog(Msg: AnsiString);
2147 var LogEntry: AnsiString;
2148 begin
2149 LogEntry := Format(sLogFormat,[FBFormatDateTime(GetDateTimeFmt,Now),Msg]) + LineEnding;
2150 if FBUDRControllerOptions.ThreadSafeLogging then
2151 begin
2152 FCriticalSection.Enter;
2153 try
2154 GetLogStream.Write(LogEntry[1],Length(LogEntry));
2155 if FBUDRControllerOptions.ForceWriteJournalEntries then
2156 FreeAndNil(FLogStream);
2157 finally
2158 FCriticalSection.Leave;
2159 end;
2160 end
2161 else
2162 GetLogStream.Write(LogEntry[1],Length(LogEntry));
2163 end;
2164
2165 function TFBUDRController.CharSetIDToText(att: IAttachment; id: integer): AnsiString;
2166 begin
2167 if att = nil then
2168 Result := IntToStr(id)
2169 else
2170 Result := att.GetCharsetName(id);
2171 end;
2172
2173 procedure TFBUDRController.WriteToLog(aTitle: AnsiString; Params: IFBUDRInputParams
2174 );
2175 var i: integer;
2176 Msg: AnsiString;
2177 begin
2178 Msg := aTitle + LineEnding;
2179 for i := 0 to Params.getCount - 1 do
2180 with Params[i] do
2181 begin
2182 Msg := Msg +
2183 'Parameter ' + IntToStr(i) + ':' + NewLineTAB +
2184 'Field Name = ' + getName + NewLineTab +
2185 'Alias Name = ' + getAliasName + NewLineTab +
2186 'SQLType = ' + GetSQLTypeName + NewLineTAB +
2187 'sub type = ' + IntToStr(getSubType) + NewLineTAB +
2188 'Scale = ' + IntToStr(getScale) + NewLineTAB +
2189 'Charset = ' + CharSetIDToText(Params.GetAttachment,getCharSetID) + NewLineTAB +
2190 BooleanToStr(getIsNullable,'Nullable','Not Nullable') + NewLineTAB +
2191 'Size = ' + IntToStr(GetSize) + NewLineTAB +
2192 'Value = ' + BooleanToStr(IsNull,'NULL',GetStrValue(Params[i] as TColumnMetaData)) + LineEnding;
2193 end;
2194 WriteToLog(Msg);
2195 end;
2196
2197 function TFBUDRController.GetStrValue(item: TColumnMetaData): Ansistring;
2198
2199 function HexString(s: AnsiString): AnsiString;
2200 var i: integer;
2201 begin
2202 Result := '';
2203 for i := 1 to length(s) do
2204 Result := Result + Format('%x ',[byte(s[i])]);
2205 end;
2206
2207 begin
2208 with Item do
2209 case SQLType of
2210 SQL_ARRAY:
2211 Result := '(array)';
2212 SQL_BLOB:
2213 if getSubtype = 1 then
2214 begin
2215 if GetCharSetID = 1 then
2216 Result := HexString(AsString)
2217 else
2218 Result := AsString;
2219 end
2220 else
2221 Result := '(Blob)';
2222 SQL_TEXT,SQL_VARYING:
2223 if GetCharSetID = 1 then
2224 Result := HexString(AsString)
2225 else
2226 Result := TrimRight(AsString);
2227 else
2228 Result := AsString;
2229 end;
2230 end;
2231
2232 procedure TFBUDRController.WriteToLog(aTitle: AnsiString; OutputData: IFBUDROutputData);
2233 var i: integer;
2234 Msg: AnsiString;
2235 begin
2236 Msg := aTitle + LineEnding;
2237 for i := 0 to OutputData.getCount - 1 do
2238 with OutputData[i] do
2239 begin
2240 Msg := Msg + 'Column ' + IntToStr(i) + NewLineTAB +
2241 'Field Name = ' + getName + NewLineTab +
2242 'SQLType = ' + GetSQLTypeName + NewLineTAB +
2243 'sub type = ' + IntToStr(getSubType) + NewLineTAB +
2244 'Scale = ' + IntToStr(getScale) + NewLineTAB +
2245 'Charset = ' + CharSetIDToText(OutputData.GetAttachment,getCharSetID) + NewLineTAB +
2246 BooleanToStr(getIsNullable,'Nullable','Not Nullable') + NewLineTAB +
2247 'Size = ' + IntToStr(GetSize) + NewLineTAB +
2248 'Value = ' + BooleanToStr(IsNull,'NULL', GetStrValue(OutputData[i] as TColumnMetaData)) + LineEnding;
2249 end;
2250 WriteToLog(Msg);
2251 end;
2252
2253 procedure TFBUDRController.StartJournaling(context: IFBUDRExternalContext);
2254 var JnlOptions: TJournalOptions;
2255 begin
2256 JnlOptions := [joNoServerTable];
2257 if loModifyQueries in FBUDRControllerOptions.LogOptions then
2258 JnlOptions := JnlOptions + [joModifyQueries];
2259 if loReadOnlyQueries in FBUDRControllerOptions.LogOptions then
2260 JnlOptions := JnlOptions + [joReadOnlyQueries];
2261 if JnlOptions <> [] then
2262 context.GetAttachment.StartJournaling(GetLogStream,JnlOptions);
2263 end;
2264
2265 function TFBUDRController.HasConfigFile: boolean;
2266 begin
2267 Result := FConfigFile <> nil;
2268 end;
2269
2270 function TFBUDRController.ReadConfigString(Section, Ident,
2271 DefaultValue: AnsiString): AnsiString;
2272 begin
2273 if HasConfigFile then
2274 Result := FConfigFile.ReadString(Section, Ident, DefaultValue)
2275 else
2276 raise Exception.Create(SNoConfigFile);
2277 end;
2278
2279 function TFBUDRController.ReadConfigInteger(Section, Ident: AnsiString;
2280 DefaultValue: integer): integer;
2281 begin
2282 if HasConfigFile then
2283 Result := FConfigFile.ReadInteger(Section, Ident, DefaultValue)
2284 else
2285 raise Exception.Create(SNoConfigFile);
2286 end;
2287
2288 function TFBUDRController.ReadConfigBool(Section, Ident: AnsiString;
2289 DefaultValue: boolean): boolean;
2290 begin
2291 if HasConfigFile then
2292 Result := FConfigFile.ReadBool(Section, Ident, DefaultValue)
2293 else
2294 raise Exception.Create(SNoConfigFile);
2295 end;
2296
2297 end.
2298