ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBSQLMonitor.pas
Revision: 221
Committed: Mon Mar 19 09:48:37 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 34206 byte(s)
Log Message:
Fixes merged

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, FBMessages
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 if Value and not IsMultiThread then
577 IBError(ibxeMultiThreadRequired,['IBSQLMonitor']);
578 if FEnabled <> Value then
579 FEnabled := Value;
580 if (not FEnabled) and (Assigned(FWriterThread)) then
581 begin
582 FWriterThread.Terminate;
583 FWriterThread.WaitFor;
584 FreeAndNil(FWriterThread);
585 end;
586 end;
587
588 procedure TIBSQLMonitorHook.SetTraceFlags(const Value: TTraceFlags);
589 begin
590 FTraceFlags := Value
591 end;
592
593 procedure TIBSQLMonitorHook.ForceRelease;
594 begin
595 if Assigned(FReaderThread) then
596 begin
597 FReaderThread.Terminate;
598 if not Assigned(FWriterThread) then
599 FWriterThread := TWriterThread.Create(FGlobalInterface);
600 FWriterThread.WriteSQLData(' ', tfMisc);
601 end;
602 end;
603
604 procedure TIBSQLMonitorHook.SQLExecute(qry: TIBSQL);
605 var
606 st: String;
607 i: Integer;
608 begin
609 if FEnabled then
610 begin
611 if not ((tfQExecute in (FTraceFlags * qry.Database.TraceFlags)) or
612 (tfStmt in (FTraceFlags * qry.Database.TraceFlags)) ) then
613 Exit;
614 if qry.Owner is TIBCustomDataSet then
615 st := TIBCustomDataSet(qry.Owner).Name
616 else
617 st := qry.Name;
618 st := st + ': [Execute] ' + qry.SQL.Text; {do not localize}
619 if qry.Params.GetCount > 0 then begin
620 for i := 0 to qry.Params.GetCount - 1 do begin
621 st := st + CRLF + ' ' + qry.Params[i].Name + ' = ';
622 try
623 if qry.Params[i].IsNull then
624 st := st + '<NULL>'; {do not localize}
625 st := st + qry.Params[i].AsString;
626 except
627 st := st + '<' + SCantPrintValue + '>';
628 end;
629 end;
630 end;
631 WriteSQLData(st, tfQExecute);
632 end;
633 end;
634
635 procedure TIBSQLMonitorHook.SQLFetch(qry: TIBSQL);
636 var
637 st: String;
638 begin
639 if FEnabled then
640 begin
641 if not ((tfQFetch in (FTraceFlags * qry.Database.TraceFlags)) or
642 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
643 Exit;
644 if qry.Owner is TIBCustomDataSet then
645 st := TIBCustomDataSet(qry.Owner).Name
646 else
647 st := qry.Name;
648 st := st + ': [Fetch] ' + qry.SQL.Text; {do not localize}
649 if (qry.EOF) then
650 st := st + CRLF + ' ' + SEOFReached;
651 WriteSQLData(st, tfQFetch);
652 end;
653 end;
654
655 procedure TIBSQLMonitorHook.SQLPrepare(qry: TIBSQL);
656 var
657 st: String;
658 begin
659 if FEnabled then
660 begin
661 if not ((tfQPrepare in (FTraceFlags * qry.Database.TraceFlags)) or
662 (tfStmt in (FTraceFlags * qry.Database.TraceFlags))) then
663 Exit;
664 if qry.Owner is TIBCustomDataSet then
665 st := TIBCustomDataSet(qry.Owner).Name
666 else
667 st := qry.Name;
668 st := st + ': [Prepare] ' + qry.SQL.Text + CRLF; {do not localize}
669 st := st + ' Plan: ' + qry.Plan; {do not localize}
670 WriteSQLData(st, tfQPrepare);
671 end;
672 end;
673
674 procedure TIBSQLMonitorHook.TRCommit(tr: TIBTransaction);
675 var
676 st: String;
677 begin
678 if FEnabled then
679 begin
680 if Assigned(tr.DefaultDatabase) and
681 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
682 Exit;
683 st := tr.Name + ': [Commit (Hard commit)]'; {do not localize}
684 WriteSQLData(st, tfTransact);
685 end;
686 end;
687
688 procedure TIBSQLMonitorHook.TRCommitRetaining(tr: TIBTransaction);
689 var
690 st: String;
691 begin
692 if FEnabled then
693 begin
694 if Assigned(tr.DefaultDatabase) and
695 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
696 Exit;
697 st := tr.Name + ': [Commit retaining (Soft commit)]'; {do not localize}
698 WriteSQLData(st, tfTransact);
699 end;
700 end;
701
702 procedure TIBSQLMonitorHook.TRRollback(tr: TIBTransaction);
703 var
704 st: String;
705 begin
706 if FEnabled then
707 begin
708 if Assigned(tr.DefaultDatabase) and
709 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
710 Exit;
711 st := tr.Name + ': [Rollback]'; {do not localize}
712 WriteSQLData(st, tfTransact);
713 end;
714 end;
715
716 procedure TIBSQLMonitorHook.TRRollbackRetaining(tr: TIBTransaction);
717 var
718 st: String;
719 begin
720 if FEnabled then
721 begin
722 if Assigned(tr.DefaultDatabase) and
723 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
724 Exit;
725 st := tr.Name + ': [Rollback retaining (Soft rollback)]'; {do not localize}
726 WriteSQLData(st, tfTransact);
727 end;
728 end;
729
730 procedure TIBSQLMonitorHook.TRStart(tr: TIBTransaction);
731 var
732 st: String;
733 begin
734 if FEnabled then
735 begin
736 if Assigned(tr.DefaultDatabase) and
737 (not (tfTransact in (FTraceFlags * tr.DefaultDatabase.TraceFlags))) then
738 Exit;
739 st := tr.Name + ': [Start transaction]'; {do not localize}
740 WriteSQLData(st, tfTransact);
741 end;
742 end;
743
744 procedure TIBSQLMonitorHook.UnregisterMonitor(SQLMonitor: TIBCustomSQLMonitor);
745 var
746 Created : Boolean;
747 begin
748 {$IFDEF DEBUG}writeln('Unregister Monitor');{$ENDIF}
749 if assigned(FReaderThread) then
750 begin
751 FReaderThread.RemoveMonitor(SQLMonitor);
752 if FReaderThread.FMonitors.Count = 0 then
753 begin
754 FReaderThread.Terminate;
755
756 { There is a possibility of a reader thread, but no writer one.
757 When in that situation, the reader needs to be released after
758 the terminate is set. To do that, create a Writer thread, send
759 the release code (a string of ' ' and type tfMisc) and then free
760 it up. }
761
762 Created := false;
763 if not Assigned(FWriterThread) then
764 begin
765 FWriterThread := TWriterThread.Create(FGlobalInterface);
766 Created := true;
767 end;
768 FWriterThread.WriteSQLData(' ', tfMisc);
769 {$IFDEF DEBUG}writeln('Wait for read Terminate');{$ENDIF}
770 FReaderThread.WaitFor;
771 if assigned(FReaderThread.FatalException) then
772 IBError(ibxeThreadFailed,['Reader',Exception(FReaderThread.FatalException).Message]);
773 {$IFDEF DEBUG}writeln('Freeing Reader Thread');{$ENDIF}
774 FreeAndNil(FReaderThread);
775 {$IFDEF DEBUG}writeln('Reader Thread Freed');{$ENDIF}
776 if Created then
777 begin
778 FWriterThread.Terminate;
779 {$IFDEF DEBUG}writeln('Wait for write Terminate');{$ENDIF}
780 FWriterThread.WaitFor;
781 if assigned(FWriterThread.FatalException) then
782 IBError(ibxeThreadFailed,['Writer',Exception(FWriterThread.FatalException).Message]);
783 FreeAndNil(FWriterThread);
784 end;
785 end;
786 end;
787 {$IFDEF DEBUG}writeln('Unregister done'){$ENDIF}
788 end;
789
790 procedure TIBSQLMonitorHook.WriteSQLData(Text: String;
791 DataType: TTraceFlag);
792 begin
793 {$IFDEF DEBUG}writeln('Write SQL Data: '+Text);{$ENDIF}
794 if not assigned(FGlobalInterface) then
795 FGlobalInterface := TGlobalInterface.Create;
796 Text := CRLF + '[Application: ' + ApplicationTitle + ']' + CRLF + Text; {do not localize}
797 if not Assigned(FWriterThread) then
798 FWriterThread := TWriterThread.Create(FGLobalInterface);
799 FWriterThread.WriteSQLData(Text, DataType);
800 end;
801
802 { TWriterThread }
803
804 constructor TWriterThread.Create(GlobalInterface: TGlobalInterface);
805
806 begin
807 inherited Create(true);
808 {$IFDEF DEBUG}writeln('Write Object Created');{$ENDIF}
809 FGlobalInterface := GlobalInterface;
810 FMsgs := TObjectList.Create(true);
811 FCriticalSection := TCriticalSection.Create;
812 FMsgAvailable := TEventObject.Create(FGlobalInterface.Sa,true,false,cWriteMessageAvailable);
813 Start;
814 end;
815
816 destructor TWriterThread.Destroy;
817 begin
818 if assigned(FMsgs) then FMsgs.Free;
819 if assigned(FCriticalSection) then FCriticalSection.Free;
820 if assigned(FMsgAvailable) then FMsgAvailable.Free;
821 inherited Destroy;
822 end;
823
824 procedure TWriterThread.Execute;
825 begin
826 {$IFDEF DEBUG}writeln('Write Thread starts');{$ENDIF}
827 try
828 { Place thread code here }
829 while ((not Terminated) and (not bDone)) or
830 (FMsgs.Count <> 0) do
831 begin
832 FMsgAvailable.WaitFor(cMsgWaitTime);
833 { Any one listening? }
834 if FGlobalInterface.MonitorCount = 0 then
835 begin
836 if FMsgs.Count <> 0 then
837 begin
838 {$IFDEF DEBUG}writeln('Write Thread Drop Message');{$ENDIF}
839 RemoveFromList;
840 end;
841 end
842 else
843 { Anything to process? }
844 if FMsgs.Count <> 0 then
845 begin
846 { If the current queued message is a release release the object }
847 if FMsgs.Items[0] is TReleaseObject then
848 begin
849 {$IFDEF DEBUG}writeln('Post Release');{$ENDIF}
850 if not Terminated then
851 Synchronize(PostRelease);
852 end
853 else
854 { Otherwise write the TraceObject to the buffer }
855 begin
856 WriteToBuffer;
857 end;
858 end
859 else
860 begin
861 FCriticalSection.Enter;
862 try
863 if FMsgs.Count = 0 then
864 FMsgAvailable.ResetEvent
865 finally
866 FCriticalSection.Leave
867 end;
868 end;
869 end;
870 except on E: Exception do
871 begin
872 {$IFDEF DEBUG}writeln('Write Thread raised Exception: ' + E.Message);{$ENDIF}
873 raise
874 end
875 end;
876 {$IFDEF DEBUG}writeln('Write Thread Ends');{$ENDIF}
877 end;
878
879 procedure TWriterThread.WriteSQLData(Msg : String; DataType: TTraceFlag);
880 begin
881 FCriticalSection.Enter;
882 try
883 FMsgs.Add(TTraceObject.Create(Msg, DataType));
884 finally
885 FCriticalSection.Leave;
886 end;
887 FMsgAvailable.SetEvent
888 end;
889
890 procedure TWriterThread.BeginWrite;
891 begin
892 {$IFDEF DEBUG}writeln('Begin Write');{$ENDIF}
893 with FGlobalInterface do
894 begin
895 ReadReadyEvent.PassThroughGate; {Wait for readers to become ready }
896 WriterBusyEvent.Lock; {Set Busy State}
897 end;
898 {$IFDEF DEBUG}writeln('Begin Write Complete');{$ENDIF}
899 end;
900
901 procedure TWriterThread.EndWrite;
902 begin
903 {$IFDEF DEBUG}writeln('End Write');{$ENDIF}
904 with FGlobalInterface do
905 begin
906 DataAvailableEvent.Unlock; { Signal Data Available. }
907 ReadFinishedEvent.PassThroughGate; {Wait for readers to finish }
908 DataAvailableEvent.Lock; {reset Data Available }
909 WriterBusyEvent.Unlock; {Signal not Busy }
910 end;
911 {$IFDEF DEBUG}writeln('End Write Complete');{$ENDIF}
912 end;
913
914 procedure TWriterThread.WriteToBuffer;
915 var I, len: integer;
916 Temp: TTraceObject;
917 begin
918 {$IFDEF DEBUG}writeln('Write to Buffer');{$ENDIF}
919 FGlobalInterface.WriteLock.Lock;
920 try
921 { If there are no monitors throw out the message
922 The alternative is to have messages queue up until a
923 monitor is ready.}
924
925 if FGlobalInterface.MonitorCount = 0 then
926 RemoveFromList
927 else
928 begin
929 i := 1;
930 len := Length(TTraceObject(FMsgs[0]).FMsg);
931 if len <= FGlobalInterface.MaxBufferSize then
932 begin
933 BeginWrite;
934 try
935 FGlobalInterface.SendTrace(TTraceObject(FMsgs[0]))
936 finally
937 RemoveFromList;
938 EndWrite
939 end;
940 end
941 else
942 try
943 while len > 0 do
944 begin
945 {$IFDEF DEBUG}writeln('Sending Partial Message, len = ',len);{$ENDIF}
946 Temp := TTraceObject.Create(TTraceObject(FMsgs[0]),i,Min(len,FGlobalInterface.MaxBufferSize));
947 try
948 BeginWrite;
949 FGlobalInterface.SendTrace(Temp);
950 Inc(i,FGlobalInterface.MaxBufferSize);
951 Dec(len,FGlobalInterface.MaxBufferSize);
952 finally
953 Temp.Free;
954 EndWrite
955 end
956 end;
957 finally
958 RemoveFromList;
959 end
960 end;
961 finally
962 FGlobalInterface.WriteLock.Unlock;
963 end;
964 {$IFDEF DEBUG}writeln('Done Write');{$ENDIF}
965 end;
966
967 procedure TWriterThread.RemoveFromList;
968 begin
969 {$IFDEF DEBUG}writeln('Write Thread: Remove object From List');{$ENDIF}
970 FCriticalSection.Enter;
971 try
972 FMsgs.Remove(FMsgs[0]); { Pop the written item }
973 finally
974 FCriticalSection.Leave;
975 end;
976 end;
977
978 procedure TWriterThread.PostRelease;
979 var Monitor: TIBCustomSQLMonitor;
980 begin
981 Monitor := TReleaseObject(FMsgs.Items[0]).FMonitor;
982 Monitor.ReleaseObject
983 end;
984
985 procedure TWriterThread.ReleaseMonitor(Arg : TIBCustomSQLMonitor);
986 begin
987 FMsgs.Add(TReleaseObject.Create(Arg));
988 end;
989
990 { TTraceObject }
991
992 constructor TTraceObject.Create(Msg : String; DataType: TTraceFlag);
993 begin
994 FMsg := Msg;
995 FDataType := DataType;
996 FTimeStamp := Now;
997 end;
998
999 constructor TTraceObject.Create(obj: TTraceObject);
1000 begin
1001 FMsg := obj.FMsg;
1002 FDataType := obj.FDataType;
1003 FTimeStamp := obj.FTimeStamp;
1004 end;
1005
1006 constructor TTraceObject.Create(obj: TTraceObject; MsgOffset, MsgLen: integer);
1007 begin
1008 FDataType := obj.FDataType;
1009 FTimeStamp := obj.FTimeStamp;
1010 FMsg := copy(obj.FMsg,MsgOffset,MsgLen)
1011 end;
1012
1013 { TReleaseObject }
1014
1015 constructor TReleaseObject.Create(Monitor : TIBCustomSQLMonitor);
1016 begin
1017 FMonitor := Monitor;
1018 end;
1019
1020 { ReaderThread }
1021
1022 procedure TReaderThread.AddMonitor(Arg: TIBCustomSQLMonitor);
1023 begin
1024 FCriticalSection.Enter;
1025 try
1026 if FMonitors.IndexOf(Arg) < 0 then
1027 FMonitors.Add(Arg);
1028 finally
1029 FCriticalSection.Leave
1030 end;
1031 end;
1032
1033 procedure TReaderThread.AlertMonitors;
1034 var i : Integer;
1035 FTemp : TTraceObject;
1036 Monitor: TIBCustomSQLMonitor;
1037 begin
1038 for i := 0 to FMonitors.Count - 1 do
1039 begin
1040 {$IFDEF DEBUG}writeln('Sending Message to Monitor ' +IntToStr(i));{$ENDIF}
1041 FTemp := TTraceObject.Create(st);
1042 Monitor := TIBCustomSQLMonitor(FMonitors[i]);
1043 Monitor.ReceiveMessage(FTemp);
1044 end;
1045 end;
1046
1047 procedure TReaderThread.BeginRead;
1048 begin
1049 {$IFDEF DEBUG}writeln('Begin Read');{$ENDIF}
1050 with FGlobalInterface do
1051 begin
1052 WriterBusyEvent.PassthroughGate; { Wait for Writer not busy}
1053 ReadFinishedEvent.Lock; { Prepare Read Finished Gate}
1054 ReadReadyEvent.Unlock; { Signal read ready }
1055 {$IFDEF DEBUG}writeln('Read Ready Unlocked');{$ENDIF}
1056 DataAvailableEvent.PassthroughGate; { Wait for a Data Available }
1057 end;
1058 {$IFDEF DEBUG}writeln('Begin Read Complete');{$ENDIF}
1059 end;
1060
1061 constructor TReaderThread.Create(GlobalInterface: TGlobalInterface);
1062 begin
1063 inherited Create(true);
1064 FGlobalInterface := GlobalInterface;
1065 st := TTraceObject.Create('', tfMisc);
1066 FGlobalInterface.IncMonitorCount;
1067 FMonitors := TObjectList.Create(false);
1068 FCriticalSection := TCriticalSection.Create;
1069 {$IFDEF DEBUG}writeln('Reader Thread Created');{$ENDIF}
1070 FGlobalInterface.ReadReadyEvent.Lock; { Initialise Read Ready}
1071 Start;
1072 end;
1073
1074 destructor TReaderThread.Destroy;
1075 begin
1076 {$IFDEF DEBUG}writeln('Reader Thread Destory');{$ENDIF}
1077 FGlobalInterface.ReadReadyEvent.UnLock;
1078 if assigned(FGlobalInterface) and (FGlobalInterface.MonitorCount > 0) then
1079 FGlobalInterface.DecMonitorCount;
1080 FMonitors.Free;
1081 if assigned(FCriticalSection) then FCriticalSection.Free;
1082 st.Free;
1083 inherited Destroy;
1084 end;
1085
1086 procedure TReaderThread.EndRead;
1087 begin
1088 {$IFDEF DEBUG}writeln('End Read');{$ENDIF}
1089 FGlobalInterface.ReadReadyEvent.Lock; { reset Read Ready}
1090 FGlobalInterface.ReadFinishedEvent.Unlock; {Signal Read completed }
1091 {$IFDEF DEBUG}writeln('End Read Complete');{$ENDIF}
1092 end;
1093
1094 procedure TReaderThread.Execute;
1095 begin
1096 {$IFDEF DEBUG}writeln('Read Thread Starts');{$ENDIF}
1097 { Place thread code here }
1098 while (not Terminated) and (not bDone) do
1099 begin
1100 ReadSQLData;
1101 if (st.FMsg <> '') and
1102 not ((st.FMsg = ' ') and (st.FDataType = tfMisc)) then
1103 begin
1104 {$IFDEF DEBUG}writeln('Sending Message to Monitors');{$ENDIF}
1105 if not Terminated then
1106 Synchronize(AlertMonitors);
1107 end;
1108 end;
1109 {$IFDEF DEBUG}writeln('Read Thread Ends');{$ENDIF}
1110 end;
1111
1112 procedure TReaderThread.ReadSQLData;
1113 begin
1114 st.FMsg := '';
1115 BeginRead;
1116 if not bDone then
1117 try
1118 FGlobalInterface.ReceiveTrace(st)
1119 finally
1120 EndRead;
1121 end;
1122 end;
1123
1124 procedure TReaderThread.RemoveMonitor(Arg: TIBCustomSQLMonitor);
1125 begin
1126 FCriticalSection.Enter;
1127 try
1128 FMonitors.Remove(Arg);
1129 finally
1130 FCriticalSection.Leave
1131 end;
1132 end;
1133
1134 { Misc methods }
1135
1136 function MonitorHook: IIBSQLMonitorHook;
1137 begin
1138 if (_MonitorHook = nil) and (not bDone) then
1139 begin
1140 CS.Enter;
1141 if (_MonitorHook = nil) and (not bDone) then
1142 begin
1143 _MonitorHook := TIBSQLMonitorHook.Create;
1144 _MonitorHook._AddRef;
1145 end;
1146 CS.Leave;
1147 end;
1148 result := _MonitorHook;
1149 end;
1150
1151 procedure EnableMonitoring;
1152 begin
1153 MonitorHook.Enabled := True;
1154 end;
1155
1156 procedure DisableMonitoring;
1157 begin
1158 MonitorHook.Enabled := False;
1159 end;
1160
1161 function MonitoringEnabled: Boolean;
1162 begin
1163 result := MonitorHook.Enabled;
1164 end;
1165
1166 procedure CloseThreads;
1167 begin
1168 {$IFDEF DEBUG}writeln('Closed Threads Called');{$ENDIF}
1169 if Assigned(FReaderThread) then
1170 begin
1171 FReaderThread.Terminate;
1172 FReaderThread.WaitFor;
1173 FreeAndNil(FReaderThread);
1174 end;
1175 if Assigned(FWriterThread) then
1176 begin
1177 FWriterThread.Terminate;
1178 FWriterThread.WaitFor;
1179 FreeAndNil(FWriterThread);
1180 end;
1181 end;
1182
1183 initialization
1184 CS := TCriticalSection.Create;
1185 _MonitorHook := nil;
1186 FWriterThread := nil;
1187 FReaderThread := nil;
1188 bDone := False;
1189 {$IFDEF USE_SV5_IPC}
1190 if GetEnvironmentVariable('FBSQL_IPCFILENAME') <> '' then
1191 IPCFileName := GetEnvironmentVariable('FBSQL_IPCFILENAME')
1192 else
1193 IPCFileName := GetTempDir(true) + IPCFileName + '.' + GetEnvironmentVariable('USER');
1194 {$ENDIF}
1195
1196 finalization
1197 {$IFDEF DEBUG}writeln('Entered Finalisation');{$ENDIF}
1198 try
1199 { Write an empty string to force the reader to unlock during termination }
1200 bDone := True;
1201 if Assigned(_MonitorHook) then
1202 _MonitorHook.ForceRelease;
1203 CloseThreads;
1204 if Assigned(_MonitorHook) then
1205 _MonitorHook._Release;
1206
1207 finally
1208 _MonitorHook := nil;
1209 if assigned(CS) then CS.Free;
1210 end;
1211 end.