ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBSQLMonitor.pas
Revision: 291
Committed: Fri Apr 17 10:26:08 2020 UTC (3 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 34233 byte(s)
Log Message:
Changed for 2.3.4 merged into public release

File Contents

# Content
1 {************************************************************************}
2 { }
3 { Borland Delphi Visual Component Library }
4 { InterBase Express core components }
5 { }
6 { Copyright (c) 1998-2000 Inprise Corporation }
7 { }
8 { InterBase Express is based in part on the product }
9 { Free IB Components, written by Gregory H. Deatz for }
10 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11 { Free IB Components is used under license. }
12 { }
13 { The contents of this file are subject to the InterBase }
14 { Public License Version 1.0 (the "License"); you may not }
15 { use this file except in compliance with the License. You }
16 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 { Software distributed under the License is distributed on }
18 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19 { express or implied. See the License for the specific language }
20 { governing rights and limitations under the License. }
21 { The Original Code was created by InterBase Software Corporation }
22 { and its successors. }
23 { Portions created by Inprise Corporation are Copyright (C) Inprise }
24 { Corporation. All Rights Reserved. }
25 { Contributor(s): Jeff Overcash }
26 { }
27 { IBX For Lazarus (Firebird Express) }
28 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 { Portions created by MWA Software are copyright McCallum Whyman }
30 { Associates Ltd 2011 - 2018 }
31 { }
32 {************************************************************************}
33
34 {
35 This unit has been significantly revised for the Lazarus port. Specially,
36 there was a need to re-organise the code to isolate the Windows specific
37 IPC and to introduce SV5 IPC as an alternative for Linux and other platforms.
38 }
39
40 unit IBSQLMonitor;
41
42 {$Mode Delphi}
43
44 {$codepage UTF8}
45
46 interface
47
48 uses
49 IB, IBUtils, IBSQL, IBCustomDataSet, IBDatabase, DB,
50 IBTypes ,SysUtils, Classes,
51 {$IFDEF WINDOWS }
52 Windows
53 {$ENDIF}
54 {$IFDEF UNIX}
55 unix
56 {$ENDIF}
57 ;
58
59 {Note that the original inter-thread communication between the Reader Thread and
60 the ISQL Monitor used the Windows PostMessage interface. This is currently not
61 useable under the FPC RTL as AllocateHWnd is not functional. It has been replaced
62 by the use of the Synchronize method.}
63
64 {$IFDEF WINDOWS}
65 {$DEFINE USE_WINDOWS_IPC}
66 {$ENDIF}
67
68 {$IFDEF UNIX}
69 {$DEFINE USE_SV5_IPC}
70 {$ENDIF}
71
72 {$IFDEF LINUX}
73 {$DEFINE HAS_SEMTIMEDOP}
74 {$ENDIF}
75
76 type
77 TIBCustomSQLMonitor = class;
78
79 TSQLEvent = procedure(EventText: String; EventTime : TDateTime) of object;
80
81 { TIBCustomSQLMonitor }
82
83 TIBCustomSQLMonitor = class(TComponent)
84 private
85 FOnSQLEvent: TSQLEvent;
86 FTraceFlags: TTraceFlags;
87 FEnabled: Boolean;
88 procedure SetEnabled(const Value: Boolean);
89 protected
90 procedure ReleaseObject; {Called from Writer Thread}
91 procedure ReceiveMessage(Msg: TObject); {Called from Reader Thread}
92 property OnSQL: TSQLEvent read FOnSQLEvent write FOnSQLEvent;
93 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
94 property Enabled : Boolean read FEnabled write SetEnabled default true;
95 public
96 constructor Create(AOwner: TComponent); override;
97 destructor Destroy; override;
98 procedure Release;
99 end;
100
101 { TIBSQLMonitor }
102
103 TIBSQLMonitor = class(TIBCustomSQLMonitor)
104 published
105 property OnSQL;
106 property TraceFlags;
107 property Enabled;
108 end;
109
110 TIBMonitoredService = class(TComponent)
111 private
112 FTraceFlags: TTraceFlags;
113 protected
114 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
115 end;
116
117 { TIBXMonitoredService }
118
119 TIBXMonitoredService = class(TComponent)
120 private
121 FTraceFlags: TTraceFlags;
122 protected
123 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
124 end;
125
126 TIBXMonitoredConnection = class(TCustomConnection)
127 private
128 FTraceFlags: TTraceFlags;
129 protected
130 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
131 end;
132
133 IIBSQLMonitorHook = interface
134 ['{CF65434C-9B75-4298-BA7E-E6B85B3C769D}']
135 procedure RegisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
136 procedure UnregisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
137 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
138 procedure SQLPrepare(qry: TIBSQL);
139 procedure SQLExecute(qry: TIBSQL);
140 procedure SQLFetch(qry: TIBSQL);
141 procedure DBConnect(db: TIBDatabase);
142 procedure DBDisconnect(db: TIBDatabase);
143 procedure TRStart(tr: TIBTransaction);
144 procedure TRCommit(tr: TIBTransaction);
145 procedure TRCommitRetaining(tr: TIBTransaction);
146 procedure TRRollback(tr: TIBTransaction);
147 procedure TRRollbackRetaining(tr: TIBTransaction);
148 procedure ServiceAttach(service: TIBMonitoredService); overload;
149 procedure ServiceDetach(service: TIBMonitoredService); overload;
150 procedure ServiceQuery(service: TIBMonitoredService); overload;
151 procedure ServiceStart(service: TIBMonitoredService); overload;
152 procedure ServiceAttach(service: TIBXMonitoredConnection); overload;
153 procedure ServiceDetach(service: TIBXMonitoredConnection); overload;
154 procedure ServiceQuery(service: TIBXMonitoredService); overload;
155 procedure ServiceStart(service: TIBXMonitoredService); overload;
156 procedure SendMisc(Msg : String);
157 function GetTraceFlags : TTraceFlags;
158 function GetMonitorCount : Integer;
159 procedure SetTraceFlags(const Value : TTraceFlags);
160 function GetEnabled : boolean;
161 procedure SetEnabled(const Value : Boolean);
162 property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
163 property Enabled : Boolean read GetEnabled write SetEnabled;
164 end;
165
166
167 function MonitorHook: IIBSQLMonitorHook;
168 procedure EnableMonitoring;
169 procedure DisableMonitoring;
170 function MonitoringEnabled: Boolean;
171
172 implementation
173
174 uses
175 contnrs, syncobjs, CustApp, IBMessages
176 {$IFDEF USE_SV5_IPC}
177 ,ipc, Errors, baseunix
178 {$ENDIF};
179
180
181 const
182 cMonitorHookSize = 1024;
183 cMsgWaitTime = 1000;
184 cWriteMessageAvailable = 'WriterMsgQueue';
185
186 type
187 { There are two possible objects. One is a trace message object.
188 This object holds the flag of the trace type plus the message.
189 The second object is a Release object. It holds the handle that
190 the CM_RELEASE message is to be queued to. }
191
192 { TTraceObject }
193
194 TTraceObject = Class(TObject)
195 FDataType : TTraceFlag;
196 FMsg : String;
197 FTimeStamp : TDateTime;
198 public
199 constructor Create(Msg : String; DataType : TTraceFlag); overload;
200 constructor Create(obj : TTraceObject); overload;
201 constructor Create(obj : TTraceObject; MsgOffset, MsgLen: integer); overload;
202 end;
203
204 { TReleaseObject }
205
206 TReleaseObject = Class(TObject)
207 FMonitor : TIBCustomSQLMonitor;
208 public
209 constructor Create(Monitor : TIBCustomSQLMonitor);
210 end;
211
212 {$IFDEF USE_SV5_IPC}
213 {$I sv5ipc.inc}
214 {$ENDIF}
215 {$IFDEF USE_WINDOWS_IPC}
216 {$I winipc.inc}
217 {$ENDIF}
218
219 type
220
221 { TIBSQLMonitorHook }
222
223 TIBSQLMonitorHook = class(TInterfacedObject, IIBSQLMonitorHook)
224 private
225 FGlobalInterface: TGlobalInterface;
226 FTraceFlags: TTraceFlags;
227 FEnabled: Boolean;
228 protected
229 procedure WriteSQLData(Text: String; DataType: TTraceFlag);
230 public
231 constructor Create;
232 destructor Destroy; override;
233 procedure RegisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
234 procedure UnregisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
235 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
236 procedure SQLPrepare(qry: TIBSQL); virtual;
237 procedure SQLExecute(qry: TIBSQL); virtual;
238 procedure SQLFetch(qry: TIBSQL); virtual;
239 procedure DBConnect(db: TIBDatabase); virtual;
240 procedure DBDisconnect(db: TIBDatabase); virtual;
241 procedure TRStart(tr: TIBTransaction); virtual;
242 procedure TRCommit(tr: TIBTransaction); virtual;
243 procedure TRCommitRetaining(tr: TIBTransaction); virtual;
244 procedure TRRollback(tr: TIBTransaction); virtual;
245 procedure TRRollbackRetaining(tr: TIBTransaction); virtual;
246 procedure ServiceAttach(service: TIBMonitoredService); virtual; overload;
247 procedure ServiceDetach(service: TIBMonitoredService); virtual; overload;
248 procedure ServiceQuery(service: TIBMonitoredService); virtual; overload;
249 procedure ServiceStart(service: TIBMonitoredService); virtual; overload;
250 procedure ServiceAttach(service: TIBXMonitoredConnection); virtual; overload;
251 procedure ServiceDetach(service: TIBXMonitoredConnection); virtual; overload;
252 procedure ServiceQuery(service: TIBXMonitoredService); virtual; overload;
253 procedure ServiceStart(service: TIBXMonitoredService); virtual; overload;
254 procedure SendMisc(Msg : String);
255 function GetEnabled: Boolean;
256 function GetTraceFlags: TTraceFlags;
257 function GetMonitorCount : Integer;
258 procedure SetEnabled(const Value: Boolean);
259 procedure SetTraceFlags(const Value: TTraceFlags);
260 procedure ForceRelease;
261 property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
262 property Enabled : Boolean read GetEnabled write SetEnabled default true;
263 end;
264
265 { TWriterThread }
266
267 TWriterThread = class(TThread)
268 private
269 { Private declarations }
270 FGlobalInterface: TGlobalInterface;
271 FMsgs : TObjectList;
272 FCriticalSection: TCriticalSection;
273 FMsgAvailable: TEventObject;
274 procedure RemoveFromList;
275 procedure PostRelease;
276 public
277 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
278 protected
279 procedure BeginWrite;
280 procedure EndWrite;
281 procedure Execute; override;
282 procedure WriteToBuffer;
283 public
284 constructor Create(GlobalInterface: TGlobalInterface);
285 destructor Destroy; override;
286 procedure WriteSQLData(Msg : String; DataType : TTraceFlag);
287 end;
288
289 { TReaderThread }
290
291 TReaderThread = class(TThread)
292 private
293 { Private declarations }
294 st : TTraceObject;
295 FMonitors : TObjectList;
296 FGlobalInterface: TGlobalInterface;
297 FCriticalSection: TCriticalSection;
298 procedure AlertMonitors;
299 protected
300 procedure BeginRead;
301 procedure EndRead;
302 procedure ReadSQLData;
303 procedure Execute; override;
304 public
305 constructor Create(GlobalInterface: TGlobalInterface);
306 destructor Destroy; override;
307 procedure AddMonitor(Arg : TIBCustomSQLMonitor);
308 procedure RemoveMonitor(Arg : TIBCustomSQLMonitor);
309 end;
310
311
312 var
313 FWriterThread : TWriterThread;
314 FReaderThread : TReaderThread;
315 _MonitorHook: TIBSQLMonitorHook;
316 bDone: Boolean;
317 CS : TCriticalSection;
318
319 const
320 ApplicationTitle: string = 'Unknown';
321
322 { TIBCustomSQLMonitor }
323
324 constructor TIBCustomSQLMonitor.Create(AOwner: TComponent);
325 var aParent: TComponent;
326 begin
327 inherited Create(AOwner);
328 FTraceFlags := [tfqPrepare .. tfMisc];
329 if not (csDesigning in ComponentState) then
330 begin
331 aParent := AOwner;
332 while aParent <> nil do
333 begin
334 if aParent is TCustomApplication then
335 begin
336 ApplicationTitle := TCustomApplication(aParent).Title;
337 break;
338 end;
339 aParent := aParent.Owner;
340 end;
341 MonitorHook.RegisterMonitor(self);
342 end;
343 FEnabled := true;
344 end;
345
346 destructor TIBCustomSQLMonitor.Destroy;
347 begin
348 if not (csDesigning in ComponentState) then
349 begin
350 if FEnabled and assigned(_MonitorHook) then
351 MonitorHook.UnregisterMonitor(self);
352 end;
353 inherited Destroy;
354 end;
355
356 procedure TIBCustomSQLMonitor.Release;
357 begin
358 MonitorHook.ReleaseMonitor(self);
359 end;
360
361 procedure TIBCustomSQLMonitor.ReleaseObject;
362 begin
363 Free
364 end;
365
366 procedure TIBCustomSQLMonitor.ReceiveMessage(Msg: TObject);
367 var
368 st: TTraceObject;
369 begin
370 st := (Msg as TTraceObject);
371 if (Assigned(FOnSQLEvent)) and
372 (st.FDataType in FTraceFlags) then
373 FOnSQLEvent(st.FMsg, st.FTimeStamp);
374 st.Free;
375 end;
376
377 procedure TIBCustomSQLMonitor.SetEnabled(const Value: Boolean);
378 begin
379 if Value <> FEnabled then
380 begin
381 FEnabled := Value;
382 if not (csDesigning in ComponentState) then
383 if FEnabled then
384 Monitorhook.RegisterMonitor(self)
385 else
386 MonitorHook.UnregisterMonitor(self);
387 end;
388 end;
389
390 { TIBSQLMonitorHook }
391
392 constructor TIBSQLMonitorHook.Create;
393 begin
394 inherited Create;
395 FTraceFlags := [tfQPrepare..tfMisc];
396 FEnabled := false;
397 end;
398
399 destructor TIBSQLMonitorHook.Destroy;
400 begin
401 if assigned(FGlobalInterface) then FGlobalInterface.Free;
402 inherited Destroy;
403 end;
404
405 procedure TIBSQLMonitorHook.DBConnect(db: TIBDatabase);
406 var
407 st : String;
408 begin
409 if FEnabled then
410 begin
411 if not (tfConnect in FTraceFlags * db.TraceFlags) then
412 Exit;
413 st := db.Name + ': [Connect]'; {do not localize}
414 WriteSQLData(st, tfConnect);
415 end;
416 end;
417
418 procedure TIBSQLMonitorHook.DBDisconnect(db: TIBDatabase);
419 var
420 st: String;
421 begin
422 if (Self = nil) then exit;
423 if FEnabled then
424 begin
425 if not (tfConnect in FTraceFlags * db.TraceFlags) then
426 Exit;
427 st := db.Name + ': [Disconnect]'; {do not localize}
428 WriteSQLData(st, tfConnect);
429 end;
430 end;
431
432 function TIBSQLMonitorHook.GetEnabled: Boolean;
433 begin
434 Result := FEnabled;
435 end;
436
437 function TIBSQLMonitorHook.GetMonitorCount: Integer;
438 begin
439 Result := FGlobalInterface.MonitorCount
440 end;
441
442 function TIBSQLMonitorHook.GetTraceFlags: TTraceFlags;
443 begin
444 Result := FTraceFlags;
445 end;
446
447 procedure TIBSQLMonitorHook.RegisterMonitor(SQLMonitor: TIBCustomSQLMonitor);
448 begin
449 {$IFDEF DEBUG}writeln('Register Monitor');{$ENDIF}
450 if not assigned(FGlobalInterface) then
451 FGlobalInterface := TGlobalInterface.Create;
452 if not Assigned(FReaderThread) then
453 FReaderThread := TReaderThread.Create(FGlobalInterface);
454 FReaderThread.AddMonitor(SQLMonitor);
455 end;
456
457 procedure TIBSQLMonitorHook.ReleaseMonitor(Arg: TIBCustomSQLMonitor);
458 begin
459 FWriterThread.ReleaseMonitor(Arg);
460 end;
461
462 procedure TIBSQLMonitorHook.SendMisc(Msg: String);
463 begin
464 if FEnabled then
465 begin
466 WriteSQLData(Msg, tfMisc);
467 end;
468 end;
469
470 procedure TIBSQLMonitorHook.ServiceAttach(service: TIBMonitoredService);
471 var
472 st: String;
473 begin
474 if FEnabled then
475 begin
476 if not (tfService in (FTraceFlags * service.TraceFlags)) then
477 Exit;
478 st := service.Name + ': [Attach]'; {do not localize}
479 WriteSQLData(st, tfService);
480 end;
481 end;
482
483 procedure TIBSQLMonitorHook.ServiceDetach(service: TIBMonitoredService);
484 var
485 st: String;
486 begin
487 if FEnabled then
488 begin
489 if not (tfService in (FTraceFlags * service.TraceFlags)) then
490 Exit;
491 st := service.Name + ': [Detach]'; {do not localize}
492 WriteSQLData(st, tfService);
493 end;
494 end;
495
496 procedure TIBSQLMonitorHook.ServiceQuery(service: TIBMonitoredService);
497 var
498 st: String;
499 begin
500 if FEnabled then
501 begin
502 if not (tfService in (FTraceFlags * service.TraceFlags)) then
503 Exit;
504 st := service.Name + ': [Query]'; {do not localize}
505 WriteSQLData(st, tfService);
506 end;
507 end;
508
509 procedure TIBSQLMonitorHook.ServiceStart(service: TIBMonitoredService);
510 var
511 st: String;
512 begin
513 if FEnabled then
514 begin
515 if not (tfService in (FTraceFlags * service.TraceFlags)) then
516 Exit;
517 st := service.Name + ': [Start]'; {do not localize}
518 WriteSQLData(st, tfService);
519 end;
520 end;
521
522 procedure TIBSQLMonitorHook.ServiceAttach(service: TIBXMonitoredConnection);
523 var
524 st: String;
525 begin
526 if FEnabled then
527 begin
528 if not (tfService in (FTraceFlags * service.TraceFlags)) then
529 Exit;
530 st := service.Name + ': [Attach]'; {do not localize}
531 WriteSQLData(st, tfService);
532 end;
533 end;
534
535 procedure TIBSQLMonitorHook.ServiceDetach(service: TIBXMonitoredConnection);
536 var
537 st: String;
538 begin
539 if FEnabled then
540 begin
541 if not (tfService in (FTraceFlags * service.TraceFlags)) then
542 Exit;
543 st := service.Name + ': [Detach]'; {do not localize}
544 WriteSQLData(st, tfService);
545 end;
546 end;
547
548 procedure TIBSQLMonitorHook.ServiceQuery(service: TIBXMonitoredService);
549 var
550 st: String;
551 begin
552 if FEnabled then
553 begin
554 if not (tfService in (FTraceFlags * service.TraceFlags)) then
555 Exit;
556 st := service.Name + ': [Query]'; {do not localize}
557 WriteSQLData(st, tfService);
558 end;
559 end;
560
561 procedure TIBSQLMonitorHook.ServiceStart(service: TIBXMonitoredService);
562 var
563 st: String;
564 begin
565 if FEnabled then
566 begin
567 if not (tfService in (FTraceFlags * service.TraceFlags)) then
568 Exit;
569 st := service.Name + ': [Start]'; {do not localize}
570 WriteSQLData(st, tfService);
571 end;
572 end;
573
574 procedure TIBSQLMonitorHook.SetEnabled(const Value: Boolean);
575 begin
576 {$ifdef UNIX}
577 if Value and not IsMultiThread then
578 IBError(ibxeMultiThreadRequired,['IBSQLMonitor']);
579 {$endif}
580 if FEnabled <> Value then
581 FEnabled := Value;
582 if (not FEnabled) and (Assigned(FWriterThread)) then
583 begin
584 FWriterThread.Terminate;
585 FWriterThread.WaitFor;
586 FreeAndNil(FWriterThread);
587 end;
588 end;
589
590 procedure TIBSQLMonitorHook.SetTraceFlags(const Value: TTraceFlags);
591 begin
592 FTraceFlags := Value
593 end;
594
595 procedure TIBSQLMonitorHook.ForceRelease;
596 begin
597 if Assigned(FReaderThread) then
598 begin
599 FReaderThread.Terminate;
600 if not Assigned(FWriterThread) then
601 FWriterThread := TWriterThread.Create(FGlobalInterface);
602 FWriterThread.WriteSQLData(' ', tfMisc);
603 end;
604 end;
605
606 procedure TIBSQLMonitorHook.SQLExecute(qry: TIBSQL);
607 var
608 st: String;
609 i: Integer;
610 begin
611 if FEnabled then
612 begin
613 if not ((tfQExecute in (FTraceFlags * qry.Database.TraceFlags)) or
614 (tfStmt in (FTraceFlags * qry.Database.TraceFlags)) ) then
615 Exit;
616 if qry.Owner is TIBCustomDataSet then
617 st := TIBCustomDataSet(qry.Owner).Name
618 else
619 st := qry.Name;
620 st := st + ': [Execute] ' + qry.SQL.Text; {do not localize}
621 if qry.Params.GetCount > 0 then begin
622 for i := 0 to qry.Params.GetCount - 1 do begin
623 st := st + CRLF + ' ' + qry.Params[i].Name + ' = ';
624 try
625 if qry.Params[i].IsNull then
626 st := st + '<NULL>'; {do not localize}
627 st := st + qry.Params[i].AsString;
628 except
629 st := st + '<' + SCantPrintValue + '>';
630 end;
631 end;
632 end;
633 WriteSQLData(st, tfQExecute);
634 end;
635 end;
636
637 procedure TIBSQLMonitorHook.SQLFetch(qry: TIBSQL);
638 var
639 st: String;
640 begin
641 if FEnabled then
642 begin
643 if not ((tfQFetch in (FTraceFlags * qry.Database.TraceFlags)) or
644 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
645 Exit;
646 if qry.Owner is TIBCustomDataSet then
647 st := TIBCustomDataSet(qry.Owner).Name
648 else
649 st := qry.Name;
650 st := st + ': [Fetch] ' + qry.SQL.Text; {do not localize}
651 if (qry.EOF) then
652 st := st + CRLF + ' ' + SEOFReached;
653 WriteSQLData(st, tfQFetch);
654 end;
655 end;
656
657 procedure TIBSQLMonitorHook.SQLPrepare(qry: TIBSQL);
658 var
659 st: String;
660 begin
661 if FEnabled then
662 begin
663 if not ((tfQPrepare in (FTraceFlags * qry.Database.TraceFlags)) or
664 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
665 Exit;
666 if qry.Owner is TIBCustomDataSet then
667 st := TIBCustomDataSet(qry.Owner).Name
668 else
669 st := qry.Name;
670 st := st + ': [Prepare] ' + qry.SQL.Text + CRLF; {do not localize}
671 st := st + ' Plan: ' + qry.Plan; {do not localize}
672 WriteSQLData(st, tfQPrepare);
673 end;
674 end;
675
676 procedure TIBSQLMonitorHook.TRCommit(tr: TIBTransaction);
677 var
678 st: String;
679 begin
680 if FEnabled then
681 begin
682 if Assigned(tr.DefaultDatabase) and
683 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
684 Exit;
685 st := tr.Name + ': [Commit (Hard commit)]'; {do not localize}
686 WriteSQLData(st, tfTransact);
687 end;
688 end;
689
690 procedure TIBSQLMonitorHook.TRCommitRetaining(tr: TIBTransaction);
691 var
692 st: String;
693 begin
694 if FEnabled then
695 begin
696 if Assigned(tr.DefaultDatabase) and
697 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
698 Exit;
699 st := tr.Name + ': [Commit retaining (Soft commit)]'; {do not localize}
700 WriteSQLData(st, tfTransact);
701 end;
702 end;
703
704 procedure TIBSQLMonitorHook.TRRollback(tr: TIBTransaction);
705 var
706 st: String;
707 begin
708 if FEnabled then
709 begin
710 if Assigned(tr.DefaultDatabase) and
711 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
712 Exit;
713 st := tr.Name + ': [Rollback]'; {do not localize}
714 WriteSQLData(st, tfTransact);
715 end;
716 end;
717
718 procedure TIBSQLMonitorHook.TRRollbackRetaining(tr: TIBTransaction);
719 var
720 st: String;
721 begin
722 if FEnabled then
723 begin
724 if Assigned(tr.DefaultDatabase) and
725 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
726 Exit;
727 st := tr.Name + ': [Rollback retaining (Soft rollback)]'; {do not localize}
728 WriteSQLData(st, tfTransact);
729 end;
730 end;
731
732 procedure TIBSQLMonitorHook.TRStart(tr: TIBTransaction);
733 var
734 st: String;
735 begin
736 if FEnabled then
737 begin
738 if Assigned(tr.DefaultDatabase) and
739 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
740 Exit;
741 st := tr.Name + ': [Start transaction]'; {do not localize}
742 WriteSQLData(st, tfTransact);
743 end;
744 end;
745
746 procedure TIBSQLMonitorHook.UnregisterMonitor(SQLMonitor: TIBCustomSQLMonitor);
747 var
748 Created : Boolean;
749 begin
750 {$IFDEF DEBUG}writeln('Unregister Monitor');{$ENDIF}
751 if assigned(FReaderThread) then
752 begin
753 FReaderThread.RemoveMonitor(SQLMonitor);
754 if FReaderThread.FMonitors.Count = 0 then
755 begin
756 FReaderThread.Terminate;
757
758 { There is a possibility of a reader thread, but no writer one.
759 When in that situation, the reader needs to be released after
760 the terminate is set. To do that, create a Writer thread, send
761 the release code (a string of ' ' and type tfMisc) and then free
762 it up. }
763
764 Created := false;
765 if not Assigned(FWriterThread) then
766 begin
767 FWriterThread := TWriterThread.Create(FGlobalInterface);
768 Created := true;
769 end;
770 FWriterThread.WriteSQLData(' ', tfMisc);
771 {$IFDEF DEBUG}writeln('Wait for read Terminate');{$ENDIF}
772 FReaderThread.WaitFor;
773 if assigned(FReaderThread.FatalException) then
774 IBError(ibxeThreadFailed,['Reader',Exception(FReaderThread.FatalException).Message]);
775 {$IFDEF DEBUG}writeln('Freeing Reader Thread');{$ENDIF}
776 FreeAndNil(FReaderThread);
777 {$IFDEF DEBUG}writeln('Reader Thread Freed');{$ENDIF}
778 if Created then
779 begin
780 FWriterThread.Terminate;
781 {$IFDEF DEBUG}writeln('Wait for write Terminate');{$ENDIF}
782 FWriterThread.WaitFor;
783 if assigned(FWriterThread.FatalException) then
784 IBError(ibxeThreadFailed,['Writer',Exception(FWriterThread.FatalException).Message]);
785 FreeAndNil(FWriterThread);
786 end;
787 end;
788 end;
789 {$IFDEF DEBUG}writeln('Unregister done'){$ENDIF}
790 end;
791
792 procedure TIBSQLMonitorHook.WriteSQLData(Text: String;
793 DataType: TTraceFlag);
794 begin
795 {$IFDEF DEBUG}writeln('Write SQL Data: '+Text);{$ENDIF}
796 if not assigned(FGlobalInterface) then
797 FGlobalInterface := TGlobalInterface.Create;
798 Text := CRLF + '[Application: ' + ApplicationTitle + ']' + CRLF + Text; {do not localize}
799 if not Assigned(FWriterThread) then
800 FWriterThread := TWriterThread.Create(FGLobalInterface);
801 FWriterThread.WriteSQLData(Text, DataType);
802 end;
803
804 { TWriterThread }
805
806 constructor TWriterThread.Create(GlobalInterface: TGlobalInterface);
807
808 begin
809 inherited Create(true);
810 {$IFDEF DEBUG}writeln('Write Object Created');{$ENDIF}
811 FGlobalInterface := GlobalInterface;
812 FMsgs := TObjectList.Create(true);
813 FCriticalSection := TCriticalSection.Create;
814 FMsgAvailable := TEventObject.Create(FGlobalInterface.Sa,true,false,cWriteMessageAvailable);
815 Start;
816 end;
817
818 destructor TWriterThread.Destroy;
819 begin
820 if assigned(FMsgs) then FMsgs.Free;
821 if assigned(FCriticalSection) then FCriticalSection.Free;
822 if assigned(FMsgAvailable) then FMsgAvailable.Free;
823 inherited Destroy;
824 end;
825
826 procedure TWriterThread.Execute;
827 begin
828 {$IFDEF DEBUG}writeln('Write Thread starts');{$ENDIF}
829 try
830 { Place thread code here }
831 while ((not Terminated) and (not bDone)) or
832 (FMsgs.Count <> 0) do
833 begin
834 FMsgAvailable.WaitFor(cMsgWaitTime);
835 { Any one listening? }
836 if FGlobalInterface.MonitorCount = 0 then
837 begin
838 if FMsgs.Count <> 0 then
839 begin
840 {$IFDEF DEBUG}writeln('Write Thread Drop Message');{$ENDIF}
841 RemoveFromList;
842 end;
843 end
844 else
845 { Anything to process? }
846 if FMsgs.Count <> 0 then
847 begin
848 { If the current queued message is a release release the object }
849 if FMsgs.Items[0] is TReleaseObject then
850 begin
851 {$IFDEF DEBUG}writeln('Post Release');{$ENDIF}
852 if not Terminated then
853 Synchronize(PostRelease);
854 end
855 else
856 { Otherwise write the TraceObject to the buffer }
857 begin
858 WriteToBuffer;
859 end;
860 end
861 else
862 begin
863 FCriticalSection.Enter;
864 try
865 if FMsgs.Count = 0 then
866 FMsgAvailable.ResetEvent
867 finally
868 FCriticalSection.Leave
869 end;
870 end;
871 end;
872 except on E: Exception do
873 begin
874 {$IFDEF DEBUG}writeln('Write Thread raised Exception: ' + E.Message);{$ENDIF}
875 raise
876 end
877 end;
878 {$IFDEF DEBUG}writeln('Write Thread Ends');{$ENDIF}
879 end;
880
881 procedure TWriterThread.WriteSQLData(Msg : String; DataType: TTraceFlag);
882 begin
883 FCriticalSection.Enter;
884 try
885 FMsgs.Add(TTraceObject.Create(Msg, DataType));
886 finally
887 FCriticalSection.Leave;
888 end;
889 FMsgAvailable.SetEvent
890 end;
891
892 procedure TWriterThread.BeginWrite;
893 begin
894 {$IFDEF DEBUG}writeln('Begin Write');{$ENDIF}
895 with FGlobalInterface do
896 begin
897 ReadReadyEvent.PassThroughGate; {Wait for readers to become ready }
898 WriterBusyEvent.Lock; {Set Busy State}
899 end;
900 {$IFDEF DEBUG}writeln('Begin Write Complete');{$ENDIF}
901 end;
902
903 procedure TWriterThread.EndWrite;
904 begin
905 {$IFDEF DEBUG}writeln('End Write');{$ENDIF}
906 with FGlobalInterface do
907 begin
908 DataAvailableEvent.Unlock; { Signal Data Available. }
909 ReadFinishedEvent.PassThroughGate; {Wait for readers to finish }
910 DataAvailableEvent.Lock; {reset Data Available }
911 WriterBusyEvent.Unlock; {Signal not Busy }
912 end;
913 {$IFDEF DEBUG}writeln('End Write Complete');{$ENDIF}
914 end;
915
916 procedure TWriterThread.WriteToBuffer;
917 var I, len: integer;
918 Temp: TTraceObject;
919 begin
920 {$IFDEF DEBUG}writeln('Write to Buffer');{$ENDIF}
921 FGlobalInterface.WriteLock.Lock;
922 try
923 { If there are no monitors throw out the message
924 The alternative is to have messages queue up until a
925 monitor is ready.}
926
927 if FGlobalInterface.MonitorCount = 0 then
928 RemoveFromList
929 else
930 begin
931 i := 1;
932 len := Length(TTraceObject(FMsgs[0]).FMsg);
933 if len <= FGlobalInterface.MaxBufferSize then
934 begin
935 BeginWrite;
936 try
937 FGlobalInterface.SendTrace(TTraceObject(FMsgs[0]))
938 finally
939 RemoveFromList;
940 EndWrite
941 end;
942 end
943 else
944 try
945 while len > 0 do
946 begin
947 {$IFDEF DEBUG}writeln('Sending Partial Message, len = ',len);{$ENDIF}
948 Temp := TTraceObject.Create(TTraceObject(FMsgs[0]),i,Min(len,FGlobalInterface.MaxBufferSize));
949 try
950 BeginWrite;
951 FGlobalInterface.SendTrace(Temp);
952 Inc(i,FGlobalInterface.MaxBufferSize);
953 Dec(len,FGlobalInterface.MaxBufferSize);
954 finally
955 Temp.Free;
956 EndWrite
957 end
958 end;
959 finally
960 RemoveFromList;
961 end
962 end;
963 finally
964 FGlobalInterface.WriteLock.Unlock;
965 end;
966 {$IFDEF DEBUG}writeln('Done Write');{$ENDIF}
967 end;
968
969 procedure TWriterThread.RemoveFromList;
970 begin
971 {$IFDEF DEBUG}writeln('Write Thread: Remove object From List');{$ENDIF}
972 FCriticalSection.Enter;
973 try
974 FMsgs.Remove(FMsgs[0]); { Pop the written item }
975 finally
976 FCriticalSection.Leave;
977 end;
978 end;
979
980 procedure TWriterThread.PostRelease;
981 var Monitor: TIBCustomSQLMonitor;
982 begin
983 Monitor := TReleaseObject(FMsgs.Items[0]).FMonitor;
984 Monitor.ReleaseObject
985 end;
986
987 procedure TWriterThread.ReleaseMonitor(Arg : TIBCustomSQLMonitor);
988 begin
989 FMsgs.Add(TReleaseObject.Create(Arg));
990 end;
991
992 { TTraceObject }
993
994 constructor TTraceObject.Create(Msg : String; DataType: TTraceFlag);
995 begin
996 FMsg := Msg;
997 FDataType := DataType;
998 FTimeStamp := Now;
999 end;
1000
1001 constructor TTraceObject.Create(obj: TTraceObject);
1002 begin
1003 FMsg := obj.FMsg;
1004 FDataType := obj.FDataType;
1005 FTimeStamp := obj.FTimeStamp;
1006 end;
1007
1008 constructor TTraceObject.Create(obj: TTraceObject; MsgOffset, MsgLen: integer);
1009 begin
1010 FDataType := obj.FDataType;
1011 FTimeStamp := obj.FTimeStamp;
1012 FMsg := copy(obj.FMsg,MsgOffset,MsgLen)
1013 end;
1014
1015 { TReleaseObject }
1016
1017 constructor TReleaseObject.Create(Monitor : TIBCustomSQLMonitor);
1018 begin
1019 FMonitor := Monitor;
1020 end;
1021
1022 { ReaderThread }
1023
1024 procedure TReaderThread.AddMonitor(Arg: TIBCustomSQLMonitor);
1025 begin
1026 FCriticalSection.Enter;
1027 try
1028 if FMonitors.IndexOf(Arg) < 0 then
1029 FMonitors.Add(Arg);
1030 finally
1031 FCriticalSection.Leave
1032 end;
1033 end;
1034
1035 procedure TReaderThread.AlertMonitors;
1036 var i : Integer;
1037 FTemp : TTraceObject;
1038 Monitor: TIBCustomSQLMonitor;
1039 begin
1040 for i := 0 to FMonitors.Count - 1 do
1041 begin
1042 {$IFDEF DEBUG}writeln('Sending Message to Monitor ' +IntToStr(i));{$ENDIF}
1043 FTemp := TTraceObject.Create(st);
1044 Monitor := TIBCustomSQLMonitor(FMonitors[i]);
1045 Monitor.ReceiveMessage(FTemp);
1046 end;
1047 end;
1048
1049 procedure TReaderThread.BeginRead;
1050 begin
1051 {$IFDEF DEBUG}writeln('Begin Read');{$ENDIF}
1052 with FGlobalInterface do
1053 begin
1054 WriterBusyEvent.PassthroughGate; { Wait for Writer not busy}
1055 ReadFinishedEvent.Lock; { Prepare Read Finished Gate}
1056 ReadReadyEvent.Unlock; { Signal read ready }
1057 {$IFDEF DEBUG}writeln('Read Ready Unlocked');{$ENDIF}
1058 DataAvailableEvent.PassthroughGate; { Wait for a Data Available }
1059 end;
1060 {$IFDEF DEBUG}writeln('Begin Read Complete');{$ENDIF}
1061 end;
1062
1063 constructor TReaderThread.Create(GlobalInterface: TGlobalInterface);
1064 begin
1065 inherited Create(true);
1066 FGlobalInterface := GlobalInterface;
1067 st := TTraceObject.Create('', tfMisc);
1068 FGlobalInterface.IncMonitorCount;
1069 FMonitors := TObjectList.Create(false);
1070 FCriticalSection := TCriticalSection.Create;
1071 {$IFDEF DEBUG}writeln('Reader Thread Created');{$ENDIF}
1072 FGlobalInterface.ReadReadyEvent.Lock; { Initialise Read Ready}
1073 Start;
1074 end;
1075
1076 destructor TReaderThread.Destroy;
1077 begin
1078 {$IFDEF DEBUG}writeln('Reader Thread Destory');{$ENDIF}
1079 FGlobalInterface.ReadReadyEvent.UnLock;
1080 if assigned(FGlobalInterface) and (FGlobalInterface.MonitorCount > 0) then
1081 FGlobalInterface.DecMonitorCount;
1082 FMonitors.Free;
1083 if assigned(FCriticalSection) then FCriticalSection.Free;
1084 st.Free;
1085 inherited Destroy;
1086 end;
1087
1088 procedure TReaderThread.EndRead;
1089 begin
1090 {$IFDEF DEBUG}writeln('End Read');{$ENDIF}
1091 FGlobalInterface.ReadReadyEvent.Lock; { reset Read Ready}
1092 FGlobalInterface.ReadFinishedEvent.Unlock; {Signal Read completed }
1093 {$IFDEF DEBUG}writeln('End Read Complete');{$ENDIF}
1094 end;
1095
1096 procedure TReaderThread.Execute;
1097 begin
1098 {$IFDEF DEBUG}writeln('Read Thread Starts');{$ENDIF}
1099 { Place thread code here }
1100 while (not Terminated) and (not bDone) do
1101 begin
1102 ReadSQLData;
1103 if (st.FMsg <> '') and
1104 not ((st.FMsg = ' ') and (st.FDataType = tfMisc)) then
1105 begin
1106 {$IFDEF DEBUG}writeln('Sending Message to Monitors');{$ENDIF}
1107 if not Terminated then
1108 Synchronize(AlertMonitors);
1109 end;
1110 end;
1111 {$IFDEF DEBUG}writeln('Read Thread Ends');{$ENDIF}
1112 end;
1113
1114 procedure TReaderThread.ReadSQLData;
1115 begin
1116 st.FMsg := '';
1117 BeginRead;
1118 if not bDone then
1119 try
1120 FGlobalInterface.ReceiveTrace(st)
1121 finally
1122 EndRead;
1123 end;
1124 end;
1125
1126 procedure TReaderThread.RemoveMonitor(Arg: TIBCustomSQLMonitor);
1127 begin
1128 FCriticalSection.Enter;
1129 try
1130 FMonitors.Remove(Arg);
1131 finally
1132 FCriticalSection.Leave
1133 end;
1134 end;
1135
1136 { Misc methods }
1137
1138 function MonitorHook: IIBSQLMonitorHook;
1139 begin
1140 if (_MonitorHook = nil) and (not bDone) then
1141 begin
1142 CS.Enter;
1143 if (_MonitorHook = nil) and (not bDone) then
1144 begin
1145 _MonitorHook := TIBSQLMonitorHook.Create;
1146 _MonitorHook._AddRef;
1147 end;
1148 CS.Leave;
1149 end;
1150 result := _MonitorHook;
1151 end;
1152
1153 procedure EnableMonitoring;
1154 begin
1155 MonitorHook.Enabled := True;
1156 end;
1157
1158 procedure DisableMonitoring;
1159 begin
1160 MonitorHook.Enabled := False;
1161 end;
1162
1163 function MonitoringEnabled: Boolean;
1164 begin
1165 result := MonitorHook.Enabled;
1166 end;
1167
1168 procedure CloseThreads;
1169 begin
1170 {$IFDEF DEBUG}writeln('Closed Threads Called');{$ENDIF}
1171 if Assigned(FReaderThread) then
1172 begin
1173 FReaderThread.Terminate;
1174 FReaderThread.WaitFor;
1175 FreeAndNil(FReaderThread);
1176 end;
1177 if Assigned(FWriterThread) then
1178 begin
1179 FWriterThread.Terminate;
1180 FWriterThread.WaitFor;
1181 FreeAndNil(FWriterThread);
1182 end;
1183 end;
1184
1185 initialization
1186 CS := TCriticalSection.Create;
1187 _MonitorHook := nil;
1188 FWriterThread := nil;
1189 FReaderThread := nil;
1190 bDone := False;
1191 {$IFDEF USE_SV5_IPC}
1192 if GetEnvironmentVariable('FBSQL_IPCFILENAME') <> '' then
1193 IPCFileName := GetEnvironmentVariable('FBSQL_IPCFILENAME')
1194 else
1195 IPCFileName := GetTempDir(true) + IPCFileName + '.' + GetEnvironmentVariable('USER');
1196 {$ENDIF}
1197
1198 finalization
1199 {$IFDEF DEBUG}writeln('Entered Finalisation');{$ENDIF}
1200 try
1201 { Write an empty string to force the reader to unlock during termination }
1202 bDone := True;
1203 if Assigned(_MonitorHook) then
1204 _MonitorHook.ForceRelease;
1205 CloseThreads;
1206 if Assigned(_MonitorHook) then
1207 _MonitorHook._Release;
1208
1209 finally
1210 _MonitorHook := nil;
1211 if assigned(CS) then CS.Free;
1212 end;
1213 end.