ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/udr/testbed/FBUdrPlugin.pas
Revision: 381
Committed: Sat Jan 15 00:06:22 2022 UTC (7 months ago) by tony
File size: 33668 byte(s)
Log Message:
Release Candidate 1
Line File contents
1 (*
2 * Firebird UDR Support (fbudrtested). 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 FBUdrPlugin;
30
31 {$IFDEF MSWINDOWS}
32 {$DEFINE WINDOWS}
33 {$ENDIF}
34
35 {$IFDEF FPC}
36 {$mode delphi}
37 {$codepage UTF8}
38 {$interfaces COM}
39 {$ENDIF}
40
41 interface
42
43 uses
44 Classes, SysUtils, Firebird, IB, FBUDRIntf, FBUDRController, FB30Statement;
45
46 type
47 TFBUdrPluginEmulator = class;
48
49 { TEmulatedExternalContext }
50
51 TEmulatedExternalContext = class(Firebird.IExternalContextImpl)
52 private
53 FAttachmentIntf: Firebird.IAttachment;
54 FStatement: IStatement;
55 FTransaction: ITransaction;
56 FUserNameBuffer: Ansistring;
57 FClientCharSet: AnsiString;
58 FDatabaseName: AnsiString;
59 public
60 constructor Create(aStatement: IStatement);
61 destructor Destroy; override;
62 property Transaction: ITransaction read FTransaction write FTransaction;
63 public
64 {IExternalContext}
65 function getMaster(): Firebird.IMaster; override;
66 function getEngine(status: Firebird.IStatus): Firebird.IExternalEngine; override;
67 function getAttachment(status: Firebird.IStatus): Firebird.IAttachment; override;
68 function getTransaction(status: Firebird.IStatus): Firebird.ITransaction; override;
69 function getUserName(): PAnsiChar; override;
70 function getDatabaseName(): PAnsiChar; override;
71 function getClientCharSet(): PAnsiChar; override;
72 function obtainInfoCode(): Integer; override;
73 function getInfo(code: Integer): Pointer; override;
74 function setInfo(code: Integer; value: Pointer): Pointer; override;
75 end;
76
77 { TEmulatedRoutineMetadata }
78
79 TEmulatedRoutineMetadata = class(IRoutineMetadataImpl)
80 private
81 FManager: TFBUdrPluginEmulator;
82 FName: AnsiString;
83 FPackageName: AnsiString;
84 FStatement: IStatement;
85 FEntryPoint: AnsiString;
86 FTableName: AnsiString;
87 FTriggerType: cardinal;
88 FInputMetadata: firebird.IMessageMetadata;
89 FOutputMetadata: firebird.IMessageMetadata;
90 FTriggerMetadata: firebird.IMessageMetadata;
91 public
92 constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString; aStatement: IStatement);
93 destructor Destroy; override;
94 procedure SetTriggerInfo(aTableName: AnsiString; aTriggerType: cardinal);
95 public
96 {IRoutineMetadata}
97 function getPackage(status: Firebird.IStatus): PAnsiChar; override;
98 function getName(status: Firebird.IStatus): PAnsiChar; override;
99 function getEntryPoint(status: Firebird.IStatus): PAnsiChar; override;
100 function getBody(status: Firebird.IStatus): PAnsiChar; override;
101 function getInputMetadata(status: Firebird.IStatus): IMessageMetadata; override;
102 function getOutputMetadata(status: Firebird.IStatus): IMessageMetadata; override;
103 function getTriggerMetadata(status: Firebird.IStatus): IMessageMetadata; override;
104 function getTriggerTable(status: Firebird.IStatus): PAnsiChar; override;
105 function getTriggerType(status: Firebird.IStatus): Cardinal; override;
106 end;
107
108 { TExternalWrapper }
109
110 TExternalWrapper = class
111 protected
112 FManager: TFBUdrPluginEmulator;
113 FName: AnsiString;
114 FPreparedStatement: IStatement;
115 FContext: TEmulatedExternalContext;
116 FRoutineMetadata: TEmulatedRoutineMetadata;
117 FStatus: Firebird.IStatus;
118 FInputParams: ISQLParams;
119 procedure CheckStatus;
120 procedure ChangeResultsCharset(FromID, toID: integer);
121 procedure Setup;
122 procedure DoSetup(status: Firebird.IStatus;
123 context: Firebird.IExternalContext;
124 metadata: Firebird.IRoutineMetadata;
125 inBuilder: Firebird.IMetadataBuilder;
126 outBuilder: Firebird.IMetadataBuilder); virtual; abstract;
127 public
128 constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString;
129 preparedStmt: IStatement);
130 destructor Destroy; override;
131 end;
132
133 { TExternalFunctionWrapper }
134
135 TExternalFunctionWrapper = class(TExternalWrapper)
136 private
137 FFunctionFactory: TFBUDRFunctionFactory;
138 protected
139 procedure DoSetup(status: Firebird.IStatus;
140 context: Firebird.IExternalContext;
141 metadata: Firebird.IRoutineMetadata;
142 inBuilder: Firebird.IMetadataBuilder;
143 outBuilder: Firebird.IMetadataBuilder); override;
144 public
145 constructor Create(aManager: TFBUdrPluginEmulator;aName, aPackageName, aEntryPoint: AnsiString;
146 aFunctionFactory: TFBUDRFunctionFactory;
147 preparedStmt: IStatement);
148 function Execute(aTransaction: ITransaction): ISQLData;
149 property InputParams: ISQLParams read FInputParams;
150 end;
151
152 {IProcedureResults is a cut down version of IResultsSet}
153
154 IProcedureResults = interface
155 ['{1b851373-a7c2-493e-b457-6a19980e0f5f}']
156 function getCount: integer;
157 function ByName(Idx: AnsiString): ISQLData;
158 function getSQLData(index: integer): ISQLData;
159 function FetchNext: boolean; {fetch next record}
160 function IsEof: boolean;
161 property Data[index: integer]: ISQLData read getSQLData; default;
162 property Count: integer read getCount;
163 end;
164
165 { TExternalProcedureWrapper }
166
167 TExternalProcedureWrapper = class(TExternalWrapper)
168 private
169 FProcedureFactory: TFBUDRProcedureFactory;
170 protected
171 procedure DoSetup(status: Firebird.IStatus;
172 context: Firebird.IExternalContext;
173 metadata: Firebird.IRoutineMetadata;
174 inBuilder: Firebird.IMetadataBuilder;
175 outBuilder: Firebird.IMetadataBuilder); override;
176 public
177 constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString;
178 aProcedureFactory: TFBUDRProcedureFactory;
179 preparedStmt: IStatement);
180 function Execute(aTransaction: ITransaction): IProcedureResults;
181 property InputParams: ISQLParams read FInputParams;
182 end;
183
184 { TFBTriggerSQLDA }
185
186 TFBTriggerSQLDA = class(TIBXINPUTSQLDA)
187 private
188 FAttachment: IAttachment;
189 protected
190 function GetAttachment: IAttachment; override;
191 function CanChangeMetaData: boolean; override;
192 public
193 {created with the input messge metadata and a pointer to the inMsg buffer}
194 constructor Create(att: IAttachment; aMetadata: Firebird.IMessageMetaData);
195 procedure Finalise;
196 end;
197
198 { TExternalTriggerWrapper }
199
200 TExternalTriggerWrapper = class(TExternalWrapper)
201 private
202 FTriggerFactory: TFBUDRTriggerFactory;
203 FTriggerOldSQLDA: TFBTriggerSQLDA;
204 FTriggerNewSQLDA: TFBTriggerSQLDA;
205 FOldValues: IFBUDROutputData;
206 FNewValues: IFBUDROutputData;
207 protected
208 procedure DoSetup(status: Firebird.IStatus;
209 context: Firebird.IExternalContext;
210 metadata: Firebird.IRoutineMetadata;
211 inBuilder: Firebird.IMetadataBuilder;
212 outBuilder: Firebird.IMetadataBuilder); override;
213 public
214 constructor Create(aManager: TFBUdrPluginEmulator; aName, aTableName, aEntryPoint: AnsiString;
215 aTriggerType: cardinal;
216 aTriggerFactory: TFBUDRTriggerFactory;
217 preparedStmt: IStatement);
218 destructor Destroy; override;
219 procedure Execute(aTransaction: ITransaction; action: cardinal);
220 property OldValues: IFBUDROutputData read FOldValues;
221 property NewValues: IFBUDROutputData read FNewValues;
222 end;
223
224 { TFBUdrPluginEmulator }
225
226 TFBUdrPluginEmulator = class(Firebird.IUdrPluginImpl)
227 private
228 FModuleName: AnsiString;
229 FTheirUnloadFlag: booleanPtr;
230 FMyUnloadFlag: boolean;
231 FStatus: Firebird.IStatus;
232 FAttachment: IAttachment;
233 FFunctionFactories: TStringList;
234 FProcedureFactories: TStringList;
235 FTriggerFactories: TStringList;
236 procedure CheckStatus;
237 procedure FreeList(var list: TStringList);
238 function CreateSelectFunctionSQL(aFunctionName: AnsiString): AnsiString;
239 function CreateExecProcedureSQL(aProcName: AnsiString): AnsiString;
240 procedure SetAttachment(AValue: IAttachment);
241 public
242 {IUdrPluginImpl}
243 function getMaster(): IMaster; override;
244 procedure registerFunction(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrFunctionFactory); override;
245 procedure registerProcedure(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrProcedureFactory); override;
246 procedure registerTrigger(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrTriggerFactory); override;
247 public
248 constructor Create(aModuleName: AnsiString);
249 destructor Destroy; override;
250 function makeFunction(aFunctionName, aPackageName,
251 aEntryPoint: AnsiString): TExternalFunctionWrapper;
252 function makeProcedure(aProcName, aPackageName, aEntryPoint: AnsiString): TExternalProcedureWrapper;
253 function makeTrigger(aName, aEntryPoint, datasetName: AnsiString; aTriggerType: cardinal
254 ): TExternalTriggerWrapper;
255 property Attachment: IAttachment read FAttachment write SetAttachment;
256 property ModuleName: AnsiString read FModuleName;
257 end;
258
259 implementation
260
261 uses FBClientLib, IBUtils, FB30Attachment, FB30Transaction,
262 FBSQLData, FBUDRUtils;
263
264 resourcestring
265 SNoMasterInterface = 'A Master Interface is required - legacy API not supported';
266 SNoAttachment = 'An attachment must be provided before a statement can be prepared';
267
268 type
269 { TProcedureResults }
270
271 TProcedureResults = class(TInterfacedObject,IProcedureResults)
272 private
273 FExternalResultSet: Firebird.IExternalResultSet;
274 FResults: IResults;
275 FIsEof: boolean;
276 FManager: TFBUdrPluginEmulator;
277 public
278 constructor Create(aManager: TFBUdrPluginEmulator;
279 aExternalResultSet: Firebird.IExternalResultSet;
280 aSQLRecord: TIBXOUTPUTSQLDA);
281 destructor Destroy; override;
282 public
283 {IProcedureResults}
284 function getCount: integer;
285 function ByName(Idx: AnsiString): ISQLData;
286 function getSQLData(index: integer): ISQLData;
287 function FetchNext: boolean; {fetch next record}
288 function IsEof: boolean;
289 end;
290
291 { TFBTriggerSQLDA }
292
293 function TFBTriggerSQLDA.GetAttachment: IAttachment;
294 begin
295 Result := FAttachment;
296 end;
297
298 function TFBTriggerSQLDA.CanChangeMetaData: boolean;
299 begin
300 Result := false;
301 end;
302
303 constructor TFBTriggerSQLDA.Create(att: IAttachment;
304 aMetadata: Firebird.IMessageMetaData);
305 begin
306 inherited Create(FirebirdAPI);
307 FAttachment := att;
308 Bind(aMetaData);
309 end;
310
311 procedure TFBTriggerSQLDA.Finalise;
312 begin
313 PackBuffer;
314 end;
315
316 { TExternalTriggerWrapper }
317
318 procedure TExternalTriggerWrapper.DoSetup(status: Firebird.IStatus;
319 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
320 inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
321 begin
322 FTriggerFactory.setup(status,context,metadata,outBuilder);
323 end;
324
325 constructor TExternalTriggerWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
326 aTableName, aEntryPoint: AnsiString; aTriggerType: cardinal;
327 aTriggerFactory: TFBUDRTriggerFactory; preparedStmt: IStatement);
328 begin
329 inherited Create(aManager,aName,'',aEntryPoint, preparedStmt);
330 FTriggerFactory := aTriggerFactory;
331 FRoutineMetadata.SetTriggerInfo(aTableName,aTriggerType);
332 FTriggerOldSQLDA := TFBTriggerSQLDA.Create(FManager.Attachment,(preparedStmt as TFB30Statement).SQLRecord.GetMetaData);
333 FTriggerNewSQLDA := TFBTriggerSQLDA.Create(FManager.Attachment,(preparedStmt as TFB30Statement).SQLRecord.GetMetaData);
334 FOldValues := TFBUDROutputParams.Create(FTriggerOldSQLDA);
335 FOldValues.Clear;
336 FNewValues := TFBUDROutputParams.Create(FTriggerNewSQLDA);
337 FNewValues.Clear;
338 end;
339
340 destructor TExternalTriggerWrapper.Destroy;
341 begin
342 FOldValues := nil;
343 FNewValues := nil;
344 if FTriggerOldSQLDA <> nil then
345 FTriggerOldSQLDA.Free;
346 if FTriggerNewSQLDA <> nil then
347 FTriggerNewSQLDA.Free;
348 inherited Destroy;
349 end;
350
351 procedure TExternalTriggerWrapper.Execute(aTransaction: ITransaction;
352 action: cardinal);
353 var aTriggerInstance: Firebird.IExternalTrigger;
354 Buffer: array [0..512] of AnsiChar;
355 begin
356 (FContext as TEmulatedExternalContext).Transaction := aTransaction;
357 try
358 Setup;
359 aTriggerInstance := FTriggerFactory.newItem(FStatus,FContext,FRoutineMetadata);
360 try
361 Buffer[0] := #0;
362 aTriggerInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer)); {The UDR engine does this thus so do we}
363 CheckStatus;
364 FTriggerOldSQLDA.Finalise;
365 FTriggerNewSQLDA.Finalise;
366 aTriggerInstance.execute(FStatus,FContext,action,
367 FTriggerOldSQLDA.MessageBuffer,
368 FTriggerNewSQLDA.MessageBuffer
369 );
370 finally
371 aTriggerInstance.dispose;
372 end;
373 finally
374 (FContext as TEmulatedExternalContext).Transaction := nil;
375 end;
376 end;
377
378 { TExternalProcedureWrapper }
379
380 procedure TExternalProcedureWrapper.DoSetup(status: Firebird.IStatus;
381 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
382 inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
383 begin
384 FProcedureFactory.setup(status,context,metadata,inBuilder,outBuilder);
385 end;
386
387 constructor TExternalProcedureWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
388 aPackageName, aEntryPoint: AnsiString;
389 aProcedureFactory: TFBUDRProcedureFactory; preparedStmt: IStatement);
390 begin
391 inherited Create(aManager,aName, aPackageName, aEntryPoint, preparedStmt);
392 FProcedureFactory := aProcedureFactory;
393 end;
394
395 function TExternalProcedureWrapper.Execute(aTransaction: ITransaction
396 ): IProcedureResults;
397 var aProcedureInstance: Firebird.IExternalProcedure;
398 Buffer: array [0..512] of AnsiChar;
399 ResultsSet: IExternalResultSet;
400 OutputData: IResults;
401 begin
402 Result := nil;
403 (FContext as TEmulatedExternalContext).Transaction := aTransaction;
404 try
405 Setup;
406 aProcedureInstance := FProcedureFactory.newItem(FStatus,FContext,FRoutineMetadata);
407 try
408 Buffer[0] := #0;
409 aProcedureInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer));
410 CheckStatus;
411 ResultsSet := aProcedureInstance.open(FStatus,FContext,
412 (FPreparedStatement as TFB30Statement).SQLParams.MessageBuffer,
413 (FPreparedStatement as TFB30Statement).SQLRecord.MessageBuffer);
414 CheckStatus;
415 if ResultsSet <> nil then
416 Result := TProcedureResults.Create(FManager,ResultsSet,(FPreparedStatement as TFB30Statement).SQLRecord);
417 finally
418 aProcedureInstance.dispose;
419 end;
420 finally
421 (FContext as TEmulatedExternalContext).Transaction := nil;
422 end;
423 end;
424
425 { TProcedureResults }
426
427 constructor TProcedureResults.Create(aManager: TFBUdrPluginEmulator;
428 aExternalResultSet: Firebird.IExternalResultSet; aSQLRecord: TIBXOUTPUTSQLDA);
429 begin
430 inherited Create;
431 FManager := aManager;
432 FExternalResultSet := aExternalResultSet;
433 FResults := TResults.Create(aSQLRecord);
434 end;
435
436 destructor TProcedureResults.Destroy;
437 begin
438 if FExternalResultSet <> nil then
439 FExternalResultSet.dispose;
440 inherited Destroy;
441 end;
442
443 function TProcedureResults.getCount: integer;
444 begin
445 Result := FResults.Count;
446 end;
447
448 function TProcedureResults.ByName(Idx: AnsiString): ISQLData;
449 begin
450 Result := FResults.ByName(Idx);
451 end;
452
453 function TProcedureResults.getSQLData(index: integer): ISQLData;
454 begin
455 Result := FResults.getSQLData(index);
456 end;
457
458 function TProcedureResults.FetchNext: boolean;
459 begin
460 Result := FExternalResultSet.fetch(FManager.FStatus);
461 FManager.CheckStatus;
462 FIsEof := not Result;
463 end;
464
465 function TProcedureResults.IsEof: boolean;
466 begin
467 Result := FIsEOF;
468 end;
469
470 { TExternalWrapper }
471
472 procedure TExternalWrapper.CheckStatus;
473 var buffer: array [0..4096] of AnsiChar;
474 begin
475 with FStatus do
476 if (getState and STATE_ERRORS) <> 0 then
477 begin
478 FManager.getMaster.getUtilInterface.formatStatus(@buffer,sizeof(buffer),FStatus);
479 raise Exception.Create(strpas(PAnsiChar(@buffer)));
480 end;
481 end;
482
483 procedure TExternalWrapper.ChangeResultsCharset(FromID, toID: integer);
484 var i: integer;
485 begin
486 with (FPreparedStatement as TFB30Statement) do
487 for i := 0 to SQLRecord.Count - 1 do
488 if SQLRecord.Column[i].CharSetID = FromID then
489 SQLRecord.Column[i].CharSetID := ToID;
490 end;
491
492 procedure TExternalWrapper.Setup;
493 var inBuilder: Firebird.IMetadataBuilder;
494 outBuilder: Firebird.IMetadataBuilder;
495 inMetadata: Firebird.IMessageMetadata;
496 outMetadata: Firebird.IMessageMetadata;
497 begin
498 inMetadata := FRoutineMetadata.getInputMetadata(FStatus);
499 CheckStatus;
500 if inMetadata <> nil then
501 try
502 inBuilder := inMetadata.getBuilder(FStatus);
503 CheckStatus;
504 finally
505 inMetadata.release;
506 end
507 else
508 inBuilder := nil;
509
510 outMetadata := FRoutineMetadata.getOutputMetadata(FStatus);
511 CheckStatus;
512 if outMetadata <> nil then
513 try
514 outBuilder := outMetadata.getBuilder(FStatus);
515 CheckStatus;
516 finally
517 outMetadata.release;
518 end
519 else
520 outBuilder := nil;
521 DoSetup(FStatus,FContext,FRoutineMetadata,inBuilder,outBuilder);
522 CheckStatus;
523 end;
524
525 constructor TExternalWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
526 aPackageName, aEntryPoint: AnsiString; preparedStmt: IStatement);
527 begin
528 inherited Create;
529 FManager := aManager;
530 FName := aName;
531 FPreparedStatement := preparedStmt;
532 FContext := TEmulatedExternalContext.Create(FPreparedStatement);
533 FRoutineMetadata := TEmulatedRoutineMetadata.Create(aManager,aName,aPackageName,aEntryPoint,FPreparedStatement);
534 FStatus := FContext.getMaster.getStatus;
535 FInputParams := FPreparedStatement.SQLParams;
536 end;
537
538 destructor TExternalWrapper.Destroy;
539 begin
540 if FContext <> nil then
541 FContext.Free;
542 if FRoutineMetadata <> nil then
543 FRoutineMetadata.Free;
544 if FStatus <> nil then
545 FStatus.dispose;
546 inherited Destroy;
547 end;
548
549 { TEmulatedRoutineMetadata }
550
551 constructor TEmulatedRoutineMetadata.Create(aManager: TFBUdrPluginEmulator; aName,
552 aPackageName, aEntryPoint: AnsiString; aStatement: IStatement);
553 begin
554 inherited Create;
555 FManager := aManager;
556 FName := aName;
557 FPackageName := aPackageName;
558 FEntryPoint := aEntryPoint;
559 FStatement := aStatement;
560 end;
561
562 destructor TEmulatedRoutineMetadata.Destroy;
563 begin
564 if FInputMetadata <> nil then
565 FInputMetadata.release;
566 if FOutputMetadata <> nil then
567 FOutputMetadata.release;
568 if FTriggerMetadata <> nil then
569 FTriggerMetadata.release;
570 inherited Destroy;
571 end;
572
573 procedure TEmulatedRoutineMetadata.SetTriggerInfo(aTableName: AnsiString;
574 aTriggerType: cardinal);
575 begin
576 FTableName := aTableName;
577 FTriggerType := aTriggerType;
578 end;
579
580 function TEmulatedRoutineMetadata.getPackage(status: Firebird.IStatus
581 ): PAnsiChar;
582 begin
583 Result := PAnsiChar(FPackageName);
584 end;
585
586 function TEmulatedRoutineMetadata.getName(status: Firebird.IStatus): PAnsiChar;
587 begin
588 Result := PAnsiChar(FName);
589 end;
590
591 function TEmulatedRoutineMetadata.getEntryPoint(status: Firebird.IStatus
592 ): PAnsiChar;
593 begin
594 Result := PAnsiChar(FEntryPoint);
595 end;
596
597 function TEmulatedRoutineMetadata.getBody(status: Firebird.IStatus): PAnsiChar;
598 begin
599 Result := nil;
600 end;
601
602 function TEmulatedRoutineMetadata.getInputMetadata(status: Firebird.IStatus
603 ): IMessageMetadata;
604 begin
605 if (FTriggerType = 0) and (FInputMetadata = nil) then
606 FInputMetadata := (FStatement as TFB30Statement).SQLParams.GetMetaData ;
607 Result := FInputMetadata;
608 if Result <> nil then
609 Result.addRef();
610 end;
611
612 function TEmulatedRoutineMetadata.getOutputMetadata(status: Firebird.IStatus
613 ): IMessageMetadata;
614 begin
615 if (FTriggerType = 0) and (FOutputMetadata = nil) then
616 FOutputMetadata := (FStatement as TFB30Statement).SQLRecord.GetMetaData;
617 Result := FOutputMetadata;
618 if Result <> nil then
619 Result.addRef();
620 end;
621
622 function TEmulatedRoutineMetadata.getTriggerMetadata(status: Firebird.IStatus
623 ): IMessageMetadata;
624 begin
625 if (FTriggerType <> 0) and (FTriggerMetadata = nil) then
626 FTriggerMetadata := (FStatement as TFB30Statement).SQLRecord.GetMetaData;
627 Result := FTriggerMetadata;
628 if Result <> nil then
629 Result.addRef();
630 end;
631
632 function TEmulatedRoutineMetadata.getTriggerTable(status: Firebird.IStatus
633 ): PAnsiChar;
634 begin
635 Result := PAnsiChar(FTableName);
636 end;
637
638 function TEmulatedRoutineMetadata.getTriggerType(status: Firebird.IStatus
639 ): Cardinal;
640 begin
641 Result := FTriggerType;
642 end;
643
644 { TExternalFunctionWrapper }
645
646 constructor TExternalFunctionWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
647 aPackageName, aEntryPoint: AnsiString;
648 aFunctionFactory: TFBUDRFunctionFactory; preparedStmt: IStatement);
649 begin
650 inherited Create(aManager,aName, aPackageName, aEntryPoint, preparedStmt);
651 FFunctionFactory := aFunctionFactory;
652 end;
653
654 function TExternalFunctionWrapper.Execute(aTransaction: ITransaction): ISQLData;
655 var aFunctionInstance: Firebird.IExternalFunction;
656 Buffer: array [0..512] of AnsiChar;
657 CodePage: TSystemCodePage;
658 OutputData: IResults;
659 begin
660 (FContext as TEmulatedExternalContext).Transaction := aTransaction;
661 try
662 Setup;
663 aFunctionInstance := FFunctionFactory.newItem(FStatus,FContext,FRoutineMetadata);
664 try
665 Buffer[0] := #0;
666 aFunctionInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer));
667 CheckStatus;
668 aFunctionInstance.execute(FStatus,FContext,
669 (FPreparedStatement as TFB30Statement).SQLParams.MessageBuffer,
670 (FPreparedStatement as TFB30Statement).SQLRecord.MessageBuffer);
671 CheckStatus;
672 OutputData := TResults.Create( (FPreparedStatement as TFB30Statement).SQLRecord);
673 Result := OutputData[0];
674 finally
675 aFunctionInstance.dispose;
676 end;
677 finally
678 (FContext as TEmulatedExternalContext).Transaction := nil;
679 end;
680 end;
681
682 procedure TExternalFunctionWrapper.DoSetup(status: Firebird.IStatus;
683 context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
684 inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
685 begin
686 FFunctionFactory.setup(status,context,metadata,inBuilder,outBuilder);
687 end;
688
689 { TEmulatedExternalContext }
690
691 constructor TEmulatedExternalContext.Create(aStatement: IStatement);
692 begin
693 inherited Create;
694 FStatement := aStatement;
695 FAttachmentIntf := (FStatement.GetAttachment as TFB30Attachment).AttachmentIntf;
696 FAttachmentIntf.addRef;
697 end;
698
699 destructor TEmulatedExternalContext.Destroy;
700 begin
701 if FAttachmentIntf <> nil then
702 FAttachmentIntf.release;
703 inherited Destroy;
704 end;
705
706 function TEmulatedExternalContext.getMaster(): Firebird.IMaster;
707 var MasterProvider: IFBIMasterProvider;
708 begin
709 if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then
710 Result := MasterProvider.GetIMasterIntf
711 else
712 Result := nil;
713 end;
714
715 function TEmulatedExternalContext.getEngine(status: Firebird.IStatus
716 ): Firebird.IExternalEngine;
717 begin
718 Result := nil;
719 end;
720
721 function TEmulatedExternalContext.getAttachment(status: Firebird.IStatus
722 ): Firebird.IAttachment;
723 begin
724 Result := FAttachmentIntf;
725 end;
726
727 function TEmulatedExternalContext.getTransaction(status: Firebird.IStatus
728 ): Firebird.ITransaction;
729 begin
730 Result := (FTransaction as TFB30Transaction).TransactionIntf;
731 end;
732
733 function TEmulatedExternalContext.getUserName(): PAnsiChar;
734 var DPB: IDPB;
735 DPBItem: IDPBItem;
736 begin
737 Result := '';
738 DPB := FStatement.GetAttachment.getDPB;
739 DPBItem := DPB.Find(isc_dpb_user_name);
740 if DPBItem <> nil then
741 begin
742 FUserNameBuffer := DPBItem.AsString;
743 Result := PAnsiChar(FUserNameBuffer);
744 end;
745 end;
746
747 function TEmulatedExternalContext.getDatabaseName(): PAnsiChar;
748 var ServerName: AnsiString;
749 Protocol: TProtocolAll;
750 PortNo: AnsiString;
751 begin
752 Result := '';
753 if ParseConnectString(FStatement.getAttachment.GetConnectString,
754 ServerName,FDatabaseName,Protocol,PortNo) then
755 Result := PAnsiChar(FDatabaseName);
756 end;
757
758 function TEmulatedExternalContext.getClientCharSet(): PAnsiChar;
759 var DPB: IDPB;
760 DPBItem: IDPBItem;
761 begin
762 Result := '';
763 DPB := FStatement.GetAttachment.getDPB;
764 DPBItem := DPB.Find(isc_dpb_lc_ctype);
765 if DPBItem <> nil then
766 begin
767 FClientCharSet := DPBItem.AsString;
768 Result := PAnsiChar(FClientCharSet);
769 end;
770 end;
771
772 function TEmulatedExternalContext.obtainInfoCode(): Integer;
773 begin
774 Result := 0;
775 end;
776
777 function TEmulatedExternalContext.getInfo(code: Integer): Pointer;
778 begin
779 Result := nil;
780 end;
781
782 function TEmulatedExternalContext.setInfo(code: Integer; value: Pointer
783 ): Pointer;
784 begin
785 Result := nil;
786 end;
787
788 { TFBUdrPluginEmulator }
789
790 function TFBUdrPluginEmulator.getMaster(): IMaster;
791 var MasterProvider: IFBIMasterProvider;
792 begin
793 if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then
794 Result := MasterProvider.GetIMasterIntf
795 else
796 Result := nil;
797 end;
798
799 procedure TFBUdrPluginEmulator.registerFunction(status: Firebird.IStatus;
800 name: PAnsiChar; factory: Firebird.IUdrFunctionFactory);
801 begin
802 FFunctionFactories.AddObject(strpas(name),factory);
803 end;
804
805 procedure TFBUdrPluginEmulator.registerProcedure(status: Firebird.IStatus;
806 name: PAnsiChar; factory: Firebird.IUdrProcedureFactory);
807 begin
808 FProcedureFactories.AddObject(strpas(name),factory);
809 end;
810
811 procedure TFBUdrPluginEmulator.registerTrigger(status: Firebird.IStatus;
812 name: PAnsiChar; factory: Firebird.IUdrTriggerFactory);
813 begin
814 FTriggerFactories.AddObject(strpas(name),factory);
815 end;
816
817 constructor TFBUdrPluginEmulator.Create(aModuleName: AnsiString);
818 begin
819 inherited Create;
820 FModuleName := aModuleName;
821 FStatus := GetMaster.getStatus;
822 FFunctionFactories := TStringList.Create;
823 FProcedureFactories := TStringList.Create;
824 FTriggerFactories := TStringList.Create;
825 FTheirUnloadFlag := firebird_udr_plugin(FStatus,@FMyUnloadFlag,self);
826 CheckStatus;
827 end;
828
829 destructor TFBUdrPluginEmulator.Destroy;
830 begin
831 FreeList(FFunctionFactories);
832 FreeList(FProcedureFactories);
833 FreeList(FTriggerFactories);
834 if FStatus <> nil then
835 FStatus.dispose();
836 inherited Destroy;
837 end;
838
839 procedure TFBUdrPluginEmulator.CheckStatus;
840 var buffer: array [0..4096] of AnsiChar;
841 begin
842 with FStatus do
843 if (getState and STATE_ERRORS) <> 0 then
844 begin
845 getMaster.getUtilInterface.formatStatus(@buffer,sizeof(buffer),FStatus);
846 raise Exception.Create(strpas(PAnsiChar(@buffer)));
847 end;
848 end;
849
850 procedure TFBUdrPluginEmulator.FreeList(var list: TStringList);
851 var i: integer;
852 obj: TObject;
853 begin
854 if List = nil then Exit;
855
856 for i := 0 to List.Count - 1 do
857 begin
858 obj := List.Objects[i];
859 if obj <> nil then
860 begin
861 if obj is TFBUDRFunctionFactory then
862 TFBUDRFunctionFactory(obj).dispose
863 else
864 if obj is TFBUDRProcedureFactory then
865 TFBUDRProcedureFactory(obj).dispose
866 else
867 if obj is TFBUDRTriggerFactory then
868 TFBUDRTriggerFactory(obj).dispose;
869 end;
870 end;
871 FreeAndNil(List);
872 end;
873
874 function TFBUdrPluginEmulator.CreateSelectFunctionSQL(aFunctionName: AnsiString
875 ): AnsiString;
876 const
877 FunctionArgsSQL =
878 'SELECT * FROM RDB$FUNCTION_ARGUMENTS RFA JOIN RDB$FIELDS FLD ' +
879 'ON RFA.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME '+
880 'WHERE RDB$FUNCTION_NAME = ? ' +
881 'ORDER BY RDB$ARGUMENT_POSITION';
882 var args: IResultset;
883 arglist: AnsiString;
884 separator: AnsiString;
885 begin
886 if not FAttachment.HasFunction(aFunctionName) then
887 aFunctionName := AnsiUpperCase(aFunctionName);
888 args := FAttachment.OpenCursorAtStart(FunctionArgsSQL,[aFunctionName]);
889 arglist := '';
890 separator := ':';
891 while not args.IsEof do
892 begin
893 if args.ByName('RDB$ARGUMENT_POSITION').AsInteger > 0 then
894 begin
895 arglist := arglist + separator + Trim(args.ByName('RDB$ARGUMENT_NAME').AsString);
896 separator := ', :';
897 end;
898 args.FetchNext;
899 end;
900 Result := 'Select ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aFunctionName) + '(' + arglist + ') From RDB$DATABASE';
901 end;
902
903 function TFBUdrPluginEmulator.CreateExecProcedureSQL(aProcName: AnsiString): AnsiString;
904 const
905 sGetProcArgsSQL =
906 'SELECT * ' +
907 ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' +
908 ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
909 'WHERE ' +
910 ' PRM.RDB$PROCEDURE_NAME = ? AND ' +
911 ' PRM.RDB$PARAMETER_TYPE = 0 ' +
912 'ORDER BY PRM.RDB$PARAMETER_NUMBER';
913
914 sGetProcType = 'Select RDB$PROCEDURE_TYPE FROM RDB$PROCEDURES ' +
915 'Where Trim(RDB$PROCEDURE_NAME) = ?';
916
917 var args: IResultset;
918 arglist: AnsiString;
919 separator: AnsiString;
920 ProcType: integer;
921 begin
922 if not FAttachment.HasProcedure(aProcName) then
923 aProcName := AnsiUpperCase(aProcName);
924 args := FAttachment.OpenCursorAtStart(sGetProcArgsSQL,[aProcName]);
925 arglist := '';
926 separator := ':';
927 while not args.IsEof do
928 begin
929 arglist := arglist + separator + Trim(args.ByName('RDB$PARAMETER_NAME').AsString);
930 separator := ', :';
931 args.FetchNext;
932 end;
933 ProcType := FAttachment.OpenCursorAtStart(sGetProcType,[aProcName])[0].AsInteger;
934 case ProcType of
935 1:
936 if arglist <> '' then
937 Result := 'Select * From ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName) + '(' + arglist + ')'
938 else
939 Result := 'Select * From ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName);
940 2:
941 if arglist <> '' then
942 Result := 'Execute Procedure ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName) + '(' + arglist + ')'
943 else
944 Result := 'Execute Procedure ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName);
945 else
946 raise Exception.CreateFmt('Unknown Procedure Type %d for %s',[ProcType,aProcName]);
947
948 end;
949 end;
950
951 procedure TFBUdrPluginEmulator.SetAttachment(AValue: IAttachment);
952 begin
953 if FAttachment = AValue then Exit;
954 if (AValue = nil) or (AValue.getFirebirdAPI = nil) or not AValue.getFirebirdAPI.HasMasterIntf then
955 raise Exception.Create(SNoMasterInterface);
956 FAttachment := AValue;
957 end;
958
959 function TFBUdrPluginEmulator.makeFunction(aFunctionName, aPackageName,
960 aEntryPoint: AnsiString): TExternalFunctionWrapper;
961 var index: integer;
962 aTransaction: ITransaction;
963 aModuleName,aRoutineName,aInfo: AnsiString;
964 begin
965 Result := nil;
966 if FAttachment = nil then
967 raise Exception.Create(SNoAttachment);
968 TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
969 index := FFunctionFactories.IndexOf(aRoutineName);
970 if (index <> -1) and (FFunctionFactories.Objects[index] <> nil) then
971 begin
972 aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
973 Result := TExternalFunctionWrapper.Create(self,aFunctionName, aPackageName, aEntryPoint,
974 FFunctionFactories.Objects[index] as TFBUDRFunctionFactory,
975 FAttachment.PrepareWithNamedParameters(aTransaction,
976 CreateSelectFunctionSQL(aFunctionName),
977 true));
978 end;
979 end;
980
981 function TFBUdrPluginEmulator.makeProcedure(aProcName, aPackageName,
982 aEntryPoint: AnsiString): TExternalProcedureWrapper;
983 var index: integer;
984 aTransaction: ITransaction;
985 aModuleName,aRoutineName,aInfo: AnsiString;
986 begin
987 Result := nil;
988 if FAttachment = nil then
989 raise Exception.Create(SNoAttachment);
990 TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
991 index := FProcedureFactories.IndexOf(aRoutineName);
992 if (index <> -1) and (FProcedureFactories.Objects[index] <> nil) then
993 begin
994 aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
995 Result := TExternalProcedureWrapper.Create(self,aProcName, aPackageName, aEntryPoint,
996 FProcedureFactories.Objects[index] as TFBUDRProcedureFactory,
997 FAttachment.PrepareWithNamedParameters(aTransaction,
998 CreateExecProcedureSQL(aProcName),true));
999 end;
1000 end;
1001
1002 function TFBUdrPluginEmulator.makeTrigger(aName, aEntryPoint,
1003 datasetName: AnsiString; aTriggerType: cardinal): TExternalTriggerWrapper;
1004 var index: integer;
1005 aTransaction: ITransaction;
1006 sql: AnsiString;
1007 aModuleName,aRoutineName,aInfo: AnsiString;
1008 begin
1009 Result := nil;
1010 sql := 'Select * from ' + datasetName;
1011 if FAttachment = nil then
1012 raise Exception.Create(SNoAttachment);
1013 TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
1014 index := FTriggerFactories.IndexOf(aRoutineName);
1015 if (index <> -1) and (FTriggerFactories.Objects[index] <> nil) then
1016 begin
1017 aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
1018 Result := TExternalTriggerWrapper.Create(self,aName, datasetName, aEntryPoint, aTriggerType,
1019 FTriggerFactories.Objects[index] as TFBUDRTriggerFactory,
1020 FAttachment.PrepareWithNamedParameters(aTransaction,sql,true));
1021 end;
1022 end;
1023
1024 end.
1025

Properties

Name Value
svn:eol-style native