ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQLMonitor.pas
Revision: 7
Committed: Sun Aug 5 18:28:19 2012 UTC (8 years ago) by tony
File size: 31488 byte(s)
Log Message:
Committing updates for Release R1-0-0
Line User Rev File contents
1 tony 7 {************************************************************************}
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.