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

Properties

Name Value
svn:eol-style native