ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/udr/testbed/FBUdrPlugin.pas
Revision: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 34277 byte(s)
Log Message:
set line ending property

File Contents

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

Properties

Name Value
svn:eol-style native