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