ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/udr/source/FBUDRController.pas
Revision: 395
Committed: Mon Feb 14 11:31:04 2022 UTC (2 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 79563 byte(s)
Log Message:
Doc update + init methods for UDR classes

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

Properties

Name Value
svn:eol-style native