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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines