ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBSQLMonitor.pas
Revision: 33
Committed: Sat Jul 18 12:30:52 2015 UTC (8 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 31558 byte(s)
Log Message:
Committing updates for Release R1-3-1

File Contents

# Content
1 {************************************************************************}
2 { }
3 { Borland Delphi Visual Component Library }
4 { InterBase Express core components }
5 { }
6 { Copyright (c) 1998-2000 Inprise Corporation }
7 { }
8 { InterBase Express is based in part on the product }
9 { Free IB Components, written by Gregory H. Deatz for }
10 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11 { Free IB Components is used under license. }
12 { }
13 { The contents of this file are subject to the InterBase }
14 { Public License Version 1.0 (the "License"); you may not }
15 { use this file except in compliance with the License. You }
16 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 { Software distributed under the License is distributed on }
18 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19 { express or implied. See the License for the specific language }
20 { governing rights and limitations under the License. }
21 { The Original Code was created by InterBase Software Corporation }
22 { and its successors. }
23 { Portions created by Inprise Corporation are Copyright (C) Inprise }
24 { Corporation. All Rights Reserved. }
25 { Contributor(s): Jeff Overcash }
26 { }
27 { IBX For Lazarus (Firebird Express) }
28 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 { Portions created by MWA Software are copyright McCallum Whyman }
30 { Associates Ltd 2011 }
31 { }
32 {************************************************************************}
33
34 {
35 This unit has been significantly revised for the Lazarus port. Specially,
36 there was a need to re-organise the code to isolate the Windows specific
37 IPC and to introduce SV5 IPC as an alternative for Linux and other platforms.
38 }
39
40 unit IBSQLMonitor;
41
42 {$Mode Delphi}
43
44 interface
45
46 uses
47 IB, IBUtils, IBSQL, IBCustomDataSet, IBDatabase, IBServices, IBXConst,SysUtils,
48 Classes,
49 {$IFDEF WINDOWS }
50 Windows
51 {$ELSE}
52 unix
53 {$ENDIF}
54 ;
55
56 {Note that the original inter-thread communication between the Reader Thread and
57 the ISQL Monitor used the Windows PostMessage interface. This is currently not
58 useable under the FPC RTL as AllocateHWnd is not functional. It has been replaced
59 by the use of the Synchronize method.}
60
61 {$IFDEF WINDOWS}
62 {$DEFINE USE_WINDOWS_IPC}
63 {$ENDIF}
64
65 {$IFDEF UNIX}
66 {$DEFINE USE_SV5_IPC}
67 {$ENDIF}
68
69 {$IFDEF LINUX}
70 {$DEFINE HAS_SEMTIMEDOP}
71 {$ENDIF}
72
73 type
74 TIBCustomSQLMonitor = class;
75
76 TSQLEvent = procedure(EventText: String; EventTime : TDateTime) of object;
77
78 { TIBCustomSQLMonitor }
79
80 TIBCustomSQLMonitor = class(TComponent)
81 private
82 FOnSQLEvent: TSQLEvent;
83 FTraceFlags: TTraceFlags;
84 FEnabled: Boolean;
85 procedure SetEnabled(const Value: Boolean);
86 protected
87 procedure ReleaseObject; {Called from Writer Thread}
88 procedure ReceiveMessage(Msg: TObject); {Called from Reader Thread}
89 property OnSQL: TSQLEvent read FOnSQLEvent write FOnSQLEvent;
90 property TraceFlags: TTraceFlags read FTraceFlags write FTraceFlags;
91 property Enabled : Boolean read FEnabled write SetEnabled default true;
92 public
93 constructor Create(AOwner: TComponent); override;
94 destructor Destroy; override;
95 procedure Release;
96 end;
97
98 { TIBSQLMonitor }
99
100 TIBSQLMonitor = class(TIBCustomSQLMonitor)
101 published
102 property OnSQL;
103 property TraceFlags;
104 property Enabled;
105 end;
106
107 IIBSQLMonitorHook = interface
108 ['{CF65434C-9B75-4298-BA7E-E6B85B3C769D}']
109 procedure RegisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
110 procedure UnregisterMonitor(SQLMonitor : TIBCustomSQLMonitor);
111 procedure ReleaseMonitor(Arg : TIBCustomSQLMonitor);
112 procedure SQLPrepare(qry: TIBSQL);
113 procedure SQLExecute(qry: TIBSQL);
114 procedure SQLFetch(qry: TIBSQL);
115 procedure DBConnect(db: TIBDatabase);
116 procedure DBDisconnect(db: TIBDatabase);
117 procedure TRStart(tr: TIBTransaction);
118 procedure TRCommit(tr: TIBTransaction);
119 procedure TRCommitRetaining(tr: TIBTransaction);
120 procedure TRRollback(tr: TIBTransaction);
121 procedure TRRollbackRetaining(tr: TIBTransaction);
122 procedure ServiceAttach(service: TIBCustomService);
123 procedure ServiceDetach(service: TIBCustomService);
124 procedure ServiceQuery(service: TIBCustomService);
125 procedure ServiceStart(service: TIBCustomService);
126 procedure SendMisc(Msg : String);
127 function GetTraceFlags : TTraceFlags;
128 function GetMonitorCount : Integer;
129 procedure SetTraceFlags(const Value : TTraceFlags);
130 function GetEnabled : boolean;
131 procedure SetEnabled(const Value : Boolean);
132 property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
133 property Enabled : Boolean read GetEnabled write SetEnabled;
134 end;
135
136
137 function MonitorHook: IIBSQLMonitorHook;
138 procedure EnableMonitoring;
139 procedure DisableMonitoring;
140 function MonitoringEnabled: Boolean;
141
142 implementation
143
144 uses
145 contnrs, syncobjs, CustApp
146 {$IFDEF USE_SV5_IPC}
147 ,ipc, Errors, baseunix
148 {$IF FPC_FULLVERSION <= 20402 } , initc {$ENDIF}
149 {$ENDIF};
150
151 {$IF FPC_FULLVERSION < 20600 }{$STATIC ON} {$ENDIF}
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.Count > 0 then begin
534 for i := 0 to qry.Params.Count - 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 Resume;
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 Resume;
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 FpGetEnv('FBSQL_IPCFILENAME') <> nil then
1103 IPCFileName := strpas(FpGetEnv('FBSQL_IPCFILENAME'))
1104 else
1105 IPCFileName := '/tmp/' + IPCFileName + '.' + strpas(FpGetEnv('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.