ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQLMonitor.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (10 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 32606 byte(s)
Log Message:
Committing updates for Release R1-0-5

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