ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/udr/source/FBUDRController.pas
Revision: 373
Committed: Thu Jan 6 14:14:57 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 81952 byte(s)
Log Message:
Fixes Merged

File Contents

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