ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQLMonitor.pas
(Generate patch)

Comparing ibx/trunk/runtime/IBSQLMonitor.pas (file contents):
Revision 16 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC

# Line 1 | Line 1
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.
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.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines